distro-build: use plt-web style for site or snapshot page
original commit: 23fa168309e2df86641794ff0cd668468e8e5143
This commit is contained in:
Matthew Flatt
parent
37b51c6b7b
commit
c043fed508
|
|
@ -253,17 +253,14 @@ Site-configuration keywords (where <string*> means no spaces, etc.):
|
|||
clients typically have no native-library packages; the default is
|
||||
the value of `#:source?'
|
||||
|
||||
#:source-pkgs? --- if true, then packages are included in the
|
||||
installer/archive only in source form; a true value works best
|
||||
#:source-pkgs? <boolean> --- if true, then packages are included in
|
||||
th installer/archive only in source form; a true value works best
|
||||
when the `#:source-runtime?' value is also #t; the default is the
|
||||
value of `#:source?'
|
||||
|
||||
#:mac-pkg? --- if true, creates a ".pkg" for Mac OS X (in
|
||||
#:mac-pkg? <boolean> --- if true, creates a ".pkg" for Mac OS X (in
|
||||
single-file format) instead of a ".dmg"; the default is #f
|
||||
|
||||
#:max-snapshots <number> --- number of snapshots to keep, used by
|
||||
the `snapshot-site' makefile target
|
||||
|
||||
#:pause-before <nonnegative-number> --- a pause in seconds to
|
||||
wait before starting a machine, which may help a virtual machine
|
||||
avoid confusion from being stopped and started too quickly; the
|
||||
|
|
@ -313,6 +310,16 @@ Top keywords (recognized only in the configuration top-level):
|
|||
removing "{...}"), and the values are X-expressions for the help
|
||||
content
|
||||
|
||||
#:site-title <string> --- title for the main page generated
|
||||
by the `site' or `snapshot-site' makefile target; the default
|
||||
is "Racket Downloads"
|
||||
|
||||
#:max-snapshots <number> --- number of snapshots to keep, used by
|
||||
the `snapshot-site' makefile target
|
||||
|
||||
#:plt-web-style? <boolean> --- indicates whether `plt-web` should
|
||||
be used to generate a site or snapshot page; the default is #t
|
||||
|
||||
More precisely, the `distro-build/config' language is like
|
||||
`racket/base' except that the module body must have exactly one
|
||||
expression (plus any number of definitions, etc.) that produces a
|
||||
|
|
|
|||
|
|
@ -3,7 +3,9 @@
|
|||
racket/file
|
||||
net/url
|
||||
"download-page.rkt"
|
||||
(only-in distro-build/config extract-options))
|
||||
"indexes.rkt"
|
||||
(only-in distro-build/config extract-options)
|
||||
(only-in plt-web site))
|
||||
|
||||
(module test racket/base)
|
||||
|
||||
|
|
@ -32,6 +34,15 @@
|
|||
'#:site-dest
|
||||
(build-path build-dir "site")))
|
||||
|
||||
(define site-title (hash-ref config
|
||||
'#:site-title
|
||||
"Racket Downloads"))
|
||||
|
||||
(define www-site (and (hash-ref config '#:plt-web-style? #t)
|
||||
(site "www"
|
||||
#:url "http://racket-lang.org/"
|
||||
#:generate? #f)))
|
||||
|
||||
(printf "Assembling site as ~a\n" dest-dir)
|
||||
|
||||
(define (copy dir [build-dir build-dir])
|
||||
|
|
@ -100,21 +111,26 @@
|
|||
(newline o))))
|
||||
|
||||
(copy log-dir)
|
||||
(generate-index-html dest-dir log-dir www-site)
|
||||
|
||||
(copy installers-dir)
|
||||
(generate-index-html dest-dir installers-dir www-site)
|
||||
|
||||
(define doc-path (build-path docs-dir doc-dir))
|
||||
(when (directory-exists? doc-path)
|
||||
(copy doc-dir docs-dir))
|
||||
(define pdf-doc-path (build-path build-dir pdf-doc-dir))
|
||||
(when (directory-exists? pdf-doc-path)
|
||||
(copy pdf-doc-dir))
|
||||
(copy pdf-doc-dir)
|
||||
(generate-index-html dest-dir pdf-doc-dir www-site))
|
||||
(copy "stamp.txt")
|
||||
(copy (build-path "origin" "collects.tgz"))
|
||||
|
||||
(make-download-page (build-path build-dir
|
||||
installers-dir
|
||||
"table.rktd")
|
||||
#:plt-www-site www-site
|
||||
#:title site-title
|
||||
#:installers-url "installers/"
|
||||
#:log-dir-url "log/"
|
||||
#:docs-url (and (directory-exists? doc-path)
|
||||
|
|
|
|||
|
|
@ -148,8 +148,10 @@
|
|||
[(#:mac-pkg?) (boolean? val)]
|
||||
[(#:site-dest) (path-string? val)]
|
||||
[(#:site-help) (hash? val)]
|
||||
[(#:site-title) (string? val)]
|
||||
[(#:pdf-doc?) (boolean? val)]
|
||||
[(#:max-snapshots) (real? val)]
|
||||
[(#:plt-web-style?) (boolean? val)]
|
||||
[(#:pause-before) (and (real? val) (not (negative? val)))]
|
||||
[(#:pause-after) (and (real? val) (not (negative? val)))]
|
||||
[(#:readme) (or (string? val)
|
||||
|
|
|
|||
|
|
@ -3,9 +3,13 @@
|
|||
racket/path
|
||||
racket/system
|
||||
racket/list
|
||||
racket/date
|
||||
racket/file
|
||||
net/url
|
||||
openssl/sha1
|
||||
xml)
|
||||
scribble/html
|
||||
(only-in plt-web site page call-with-registered-roots)
|
||||
(only-in plt-web/style columns))
|
||||
|
||||
(provide make-download-page
|
||||
get-installers-table
|
||||
|
|
@ -21,12 +25,14 @@
|
|||
(define table-file
|
||||
(command-line
|
||||
#:once-each
|
||||
[("--at") url "URL for installaters reletaive to download page"
|
||||
[("--at") url "URL for installers relative to download page"
|
||||
(arg! '#:installers-url url)]
|
||||
[("--dest") file "Write to <dest>"
|
||||
(arg! '#:dest file)]
|
||||
[("--git") dir "Report information from git clone <dir>"
|
||||
(arg! '#:git-clone dir)]
|
||||
[("--plt") "Use PLT web page style"
|
||||
(arg! '#:plt-web-style? #t)]
|
||||
#:args
|
||||
(table-file)
|
||||
table-file))
|
||||
|
|
@ -57,18 +63,20 @@
|
|||
#:log-dir-url [log-dir-url #f]
|
||||
#:docs-url [docs-url #f]
|
||||
#:pdf-docs-url [pdf-docs-url #f]
|
||||
#:title [title "Racket Downloads"]
|
||||
#:title [page-title "Racket Downloads"]
|
||||
#:current-rx [current-rx #f]
|
||||
#:git-clone [git-clone #f]
|
||||
#:help-table [site-help (hash)]
|
||||
#:post-content [post-content null])
|
||||
#:post-content [post-content null]
|
||||
#:plt-www-site [www-site #f]
|
||||
#:plt-web-style? [plt-style? (and www-site #t)])
|
||||
|
||||
(define base-table (get-installers-table table-file))
|
||||
|
||||
(define table (for/fold ([table base-table]) ([(k v) (in-hash past-successes)])
|
||||
(if (hash-ref table k #f)
|
||||
table
|
||||
(hash-set table k v))))
|
||||
(define table-data (for/fold ([table-data base-table]) ([(k v) (in-hash past-successes)])
|
||||
(if (hash-ref table-data k #f)
|
||||
table-data
|
||||
(hash-set table-data k v))))
|
||||
|
||||
(define (system*/string . args)
|
||||
(define s (open-output-string))
|
||||
|
|
@ -78,10 +86,10 @@
|
|||
|
||||
(define log-link
|
||||
(and log-dir-url
|
||||
`((div (a ([class "detail"] [href ,log-dir-url]) "Build Logs")))))
|
||||
(div (a class: "detail" href: log-dir-url "Build Logs"))))
|
||||
|
||||
(define sorted
|
||||
(sort (hash-keys table) string<?))
|
||||
(sort (hash-keys table-data) string<?))
|
||||
(define sorted-and-split
|
||||
(map (lambda (s)
|
||||
(map (lambda (e)
|
||||
|
|
@ -103,7 +111,7 @@
|
|||
(cons '(#f) l)
|
||||
l))
|
||||
(cond
|
||||
[(null? l) '((#f) (#f nbsp))]
|
||||
[(null? l) `((#f) (#f ,nbsp))]
|
||||
[(not (equal? prev (take (car l) len)))
|
||||
;; move out a layer:
|
||||
(loop l keys (drop-right prev 1) #t)]
|
||||
|
|
@ -111,7 +119,7 @@
|
|||
;; a leaf entry:
|
||||
(add-sep
|
||||
(cons (cons (car keys)
|
||||
(append (make-list len 'nbsp)
|
||||
(append (make-list len nbsp)
|
||||
(list (list-ref (car l) len))))
|
||||
(loop (cdr l) (cdr keys) prev #t)))]
|
||||
[else
|
||||
|
|
@ -119,10 +127,24 @@
|
|||
(define section (list-ref (car l) len))
|
||||
(add-sep
|
||||
(cons (cons #f
|
||||
(append (make-list len 'nbsp)
|
||||
(append (make-list len nbsp)
|
||||
(list section)))
|
||||
(loop l keys (append prev (list section)) #t)))])))
|
||||
|
||||
(define (xexpr->html p)
|
||||
(cond
|
||||
[(pair? p)
|
||||
(define has-attr? (or (and (pair? (cadr p))
|
||||
(pair? (cadr p)))
|
||||
(null? (cadr p))))
|
||||
(apply element (car p) (if has-attr?
|
||||
(cadr p)
|
||||
null)
|
||||
(map xexpr->html (if has-attr? (cddr p) (cdr p))))]
|
||||
[(string? p) p]
|
||||
[(or (symbol? p) (number? p)) (entity p)]
|
||||
[else (error "unknown xexpr")]))
|
||||
|
||||
(define (get-site-help last-col)
|
||||
(let ([h (hash-ref site-help last-col #f)])
|
||||
(if h
|
||||
|
|
@ -130,36 +152,50 @@
|
|||
[toggle (let ([elem (~a "document.getElementById" "('" id "')")])
|
||||
(~a elem ".style.display = ((" elem ".style.display == 'inline') ? 'none' : 'inline');"
|
||||
" return false;"))])
|
||||
`(" "
|
||||
(div ([class "helpbutton"])
|
||||
(a ([href "#"]
|
||||
[class "helpbuttonlabel"]
|
||||
[onclick ,toggle]
|
||||
[title "explain"])
|
||||
nbsp "?" nbsp))
|
||||
(div ([class "hiddenhelp"]
|
||||
[id ,id]
|
||||
[onclick ,toggle]
|
||||
[style "display: none"])
|
||||
(div ([class "helpcontent"])
|
||||
(div ([class "helptext"])
|
||||
,h)))))
|
||||
(list
|
||||
" "
|
||||
(div class: "helpbutton"
|
||||
(a href: "#"
|
||||
class: "helpbuttonlabel"
|
||||
onclick: toggle
|
||||
title: "explain"
|
||||
nbsp "?" nbsp))
|
||||
(div class: "hiddenhelp"
|
||||
id: id
|
||||
onclick: toggle
|
||||
style: "display: none"
|
||||
(div class: "helpcontent"
|
||||
(div class: "helptext"
|
||||
(xexpr->html h))))))
|
||||
null)))
|
||||
|
||||
(call-with-output-file*
|
||||
dest
|
||||
#:exists 'truncate/replace
|
||||
(lambda (o)
|
||||
(parameterize ([empty-tag-shorthand html-empty-tags])
|
||||
(write-xexpr
|
||||
`(html
|
||||
(head (title ,title)
|
||||
(style @,~a|{
|
||||
(define page-site (and plt-style?
|
||||
(site "download-page"
|
||||
#:url "http://page.racket-lang.org/"
|
||||
#:navigation (if docs-url
|
||||
(list nbsp
|
||||
nbsp
|
||||
(a href: docs-url "Documentation")
|
||||
(if pdf-docs-url
|
||||
(a href: pdf-docs-url "PDF")
|
||||
nbsp))
|
||||
null)
|
||||
#:share-from (or www-site
|
||||
(site "www"
|
||||
#:url "http://racket-lang.org/"
|
||||
#:generate? #f)))))
|
||||
|
||||
(define orig-directory (current-directory))
|
||||
|
||||
(define page-headers
|
||||
(style/inline @~a|{
|
||||
.detail { font-size: small; }
|
||||
.checksum, .path { font-family: monospace; }
|
||||
.group { background-color : #ccccff; padding-left: 0.5ex; }
|
||||
.major { font-weight : bold; font-size : large; left-border: 1ex; }
|
||||
.minor { font-weight : bold; }
|
||||
.download-table { border: 0px solid white; }
|
||||
.download-table td { display: table-cell; padding: 0px 2px 0px 2px; border: 0px solid white; }
|
||||
.helpbutton {
|
||||
display: inline;
|
||||
font-family: sans-serif;
|
||||
|
|
@ -175,7 +211,6 @@
|
|||
}
|
||||
.helpcontent {
|
||||
width: 20em;
|
||||
font-family: serif;
|
||||
font-size : small;
|
||||
font-weight : normal;
|
||||
background-color: #ffffee;
|
||||
|
|
@ -184,123 +219,167 @@
|
|||
}
|
||||
a { text-decoration: none; }
|
||||
}|))
|
||||
(body
|
||||
(h2 ,title)
|
||||
(table
|
||||
,@(for/list ([elem (in-list elems)])
|
||||
(define key (car elem))
|
||||
(define inst (and key (hash-ref table key)))
|
||||
(define mid-cols (if (null? (cdr elem))
|
||||
#f
|
||||
(drop-right (cdr elem) 1)))
|
||||
(define last-col (last elem))
|
||||
(define level-class
|
||||
(case (length elem)
|
||||
[(2) (~a "major" (if key "" " group"))]
|
||||
[(3) "minor"]
|
||||
[else "subminor"]))
|
||||
(define num-cols (if current-rx
|
||||
"7"
|
||||
"5"))
|
||||
(cond
|
||||
[(not mid-cols)
|
||||
`(tr (td ((colspan ,num-cols)) nbsp))]
|
||||
[inst
|
||||
`(tr (td
|
||||
,@(for/list ([col (in-list mid-cols)])
|
||||
`(span nbsp nbsp nbsp))
|
||||
,(if (past-success? inst)
|
||||
;; Show missing installer
|
||||
`(span ((class ,(string-append "no-installer " level-class)))
|
||||
,last-col)
|
||||
;; Link to installer
|
||||
`(a ((class ,(string-append "installer " level-class))
|
||||
(href ,(url->string
|
||||
(combine-url/relative
|
||||
(string->url installers-url)
|
||||
inst))))
|
||||
,last-col))
|
||||
,@(get-site-help last-col))
|
||||
(td nbsp)
|
||||
(td ,(if (past-success? inst)
|
||||
`(span ([class "detail"]) "")
|
||||
`(span ([class "detail"])
|
||||
,(~r (/ (file-size (build-path (path-only table-file)
|
||||
inst))
|
||||
(* 1024 1024))
|
||||
#:precision 1)
|
||||
" MB")))
|
||||
(td nbsp)
|
||||
(td ,(if (past-success? inst)
|
||||
`(span ([class "detail"])
|
||||
,@(if (and log-dir
|
||||
(file-exists? (build-path log-dir key)))
|
||||
`((a ([href ,(url->string
|
||||
(combine-url/relative
|
||||
(string->url log-dir-url)
|
||||
key))])
|
||||
"build failed")
|
||||
"; ")
|
||||
null)
|
||||
"last success: "
|
||||
(a ((href ,(~a (past-success-relative-url inst))))
|
||||
,(past-success-name inst)))
|
||||
`(span ([class "detail"])
|
||||
"SHA1: "
|
||||
(span ([class "checksum"])
|
||||
,(call-with-input-file*
|
||||
(build-path (path-only table-file)
|
||||
inst)
|
||||
sha1)))))
|
||||
,@(if current-rx
|
||||
`((td nbsp)
|
||||
(td (span ([class "detail"])
|
||||
,(let ([inst-path (if (past-success? inst)
|
||||
(past-success-file inst)
|
||||
inst)])
|
||||
(if (regexp-match? current-rx inst-path)
|
||||
`(a ([href ,(url->string
|
||||
(combine-url/relative
|
||||
(string->url installers-url)
|
||||
(bytes->string/utf-8
|
||||
(regexp-replace current-rx
|
||||
(string->bytes/utf-8 inst-path)
|
||||
#"current"))))])
|
||||
"as " ldquo "current" rdquo)
|
||||
'nbsp)))))
|
||||
null))]
|
||||
[else
|
||||
`(tr (td ((class ,level-class)
|
||||
(colspan ,num-cols))
|
||||
,@(for/list ([col (in-list mid-cols)])
|
||||
`(span nbsp nbsp nbsp))
|
||||
,last-col
|
||||
,@(get-site-help last-col)))])))
|
||||
,@(if docs-url
|
||||
`((p (a ((href ,docs-url)) "Documentation")
|
||||
,@(if pdf-docs-url
|
||||
`(nbsp
|
||||
nbsp
|
||||
(span ([class "detail"])
|
||||
(a ((href ,pdf-docs-url)) "[also available as PDF]")))
|
||||
null)))
|
||||
null)
|
||||
,@(if git-clone
|
||||
(let ([git (find-executable-path "git")])
|
||||
(define origin (let ([s (system*/string git "remote" "show" "origin")])
|
||||
(define m (regexp-match #rx"(?m:Fetch URL: (.*)$)" s))
|
||||
(if m
|
||||
(cadr m)
|
||||
"???")))
|
||||
(define stamp (system*/string git "log" "-1" "--format=%H"))
|
||||
`((p
|
||||
(div (span ([class "detail"]) "Repository: " (span ([class "path"]) ,origin)))
|
||||
(div (span ([class "detail"]) "Commit: " (span ([class "checksum"]) ,stamp)))
|
||||
,@(or log-link null))))
|
||||
null)
|
||||
,@(if (and log-link (not git-clone))
|
||||
`((p ,@log-link))
|
||||
null)
|
||||
,@post-content))
|
||||
o)
|
||||
(void)))))
|
||||
|
||||
(define page-body
|
||||
(list
|
||||
(if page-title
|
||||
((if plt-style? h3 h2) page-title)
|
||||
null)
|
||||
(table
|
||||
class: "download-table"
|
||||
(for/list ([elem (in-list elems)])
|
||||
(define key (car elem))
|
||||
(define inst (and key (hash-ref table-data key)))
|
||||
(define mid-cols (if (null? (cdr elem))
|
||||
#f
|
||||
(drop-right (cdr elem) 1)))
|
||||
(define last-col (last elem))
|
||||
(define level-class
|
||||
(case (length elem)
|
||||
[(2) (~a "major" (if key "" " group"))]
|
||||
[(3) "minor"]
|
||||
[else "subminor"]))
|
||||
(define num-cols (if current-rx
|
||||
"7"
|
||||
"5"))
|
||||
(cond
|
||||
[(not mid-cols)
|
||||
(tr (td colspan: num-cols nbsp))]
|
||||
[inst
|
||||
(tr (td
|
||||
(for/list ([col (in-list mid-cols)])
|
||||
(span nbsp nbsp nbsp))
|
||||
(if (past-success? inst)
|
||||
;; Show missing installer
|
||||
(span class: (string-append "no-installer " level-class)
|
||||
last-col)
|
||||
;; Link to installer
|
||||
(a class: (string-append "installer " level-class)
|
||||
href: (url->string
|
||||
(combine-url/relative
|
||||
(string->url installers-url)
|
||||
inst))
|
||||
last-col))
|
||||
(get-site-help last-col))
|
||||
(td nbsp)
|
||||
(td (if (past-success? inst)
|
||||
(span class: "detail" "")
|
||||
(span class: "detail"
|
||||
(~r (/ (file-size (build-path (path-only table-file)
|
||||
inst))
|
||||
(* 1024 1024))
|
||||
#:precision 1)
|
||||
" MB")))
|
||||
(td nbsp)
|
||||
(td (if (past-success? inst)
|
||||
(span class: "detail"
|
||||
(if (and log-dir
|
||||
(file-exists? (build-path log-dir key)))
|
||||
(list
|
||||
(a href: (url->string
|
||||
(combine-url/relative
|
||||
(string->url log-dir-url)
|
||||
key))
|
||||
"build failed")
|
||||
"; ")
|
||||
null)
|
||||
"last success: "
|
||||
(a href: (~a (past-success-relative-url inst))
|
||||
(past-success-name inst)))
|
||||
(span class: "detail"
|
||||
"SHA1: "
|
||||
(span class: "checksum"
|
||||
(call-with-input-file*
|
||||
(build-path (path-only table-file)
|
||||
inst)
|
||||
sha1)))))
|
||||
(if current-rx
|
||||
(list
|
||||
(td nbsp)
|
||||
(td (span class: "detail"
|
||||
(let ([inst-path (if (past-success? inst)
|
||||
(past-success-file inst)
|
||||
inst)])
|
||||
(if (regexp-match? current-rx inst-path)
|
||||
(a href: (url->string
|
||||
(combine-url/relative
|
||||
(string->url installers-url)
|
||||
(bytes->string/utf-8
|
||||
(regexp-replace current-rx
|
||||
(string->bytes/utf-8 inst-path)
|
||||
#"current"))))
|
||||
"as " ldquo "current" rdquo)
|
||||
nbsp)))))
|
||||
null))]
|
||||
[else
|
||||
(tr (td class: level-class
|
||||
colspan: num-cols
|
||||
(for/list ([col (in-list mid-cols)])
|
||||
(span nbsp nbsp nbsp))
|
||||
last-col
|
||||
(get-site-help last-col)))])))
|
||||
(if (and docs-url
|
||||
(not site))
|
||||
(p (a href: docs-url "Documentation")
|
||||
(if pdf-docs-url
|
||||
(list
|
||||
nbsp
|
||||
nbsp
|
||||
(span class: "detail"
|
||||
(a href: pdf-docs-url "[also available as PDF]")))
|
||||
null))
|
||||
null)
|
||||
(if git-clone
|
||||
(let ([git (find-executable-path "git")])
|
||||
(define origin (let ([s (system*/string git "remote" "show" "origin")])
|
||||
(define m (regexp-match #rx"(?m:Fetch URL: (.*)$)" s))
|
||||
(if m
|
||||
(cadr m)
|
||||
"???")))
|
||||
(define stamp (system*/string git "log" "-1" "--format=%H"))
|
||||
(p
|
||||
(div (span class: "detail" "Repository: " (span class: "path" origin)))
|
||||
(div (span class: "detail" "Commit: " (span class: "checksum" stamp)))
|
||||
(or log-link null)))
|
||||
null)
|
||||
(if (and log-link (not git-clone))
|
||||
(p log-link)
|
||||
null)
|
||||
post-content))
|
||||
|
||||
(define-values (dest-dir dest-file dest-is-dir?) (split-path dest))
|
||||
|
||||
(define page-content
|
||||
(if page-site
|
||||
(page #:site page-site
|
||||
#:file (path-element->string dest-file)
|
||||
#:title page-title
|
||||
#:extra-headers page-headers
|
||||
(columns 12 #:row? #t
|
||||
page-body))
|
||||
(html (head (title page-title)
|
||||
page-headers)
|
||||
(body page-body))))
|
||||
|
||||
(call-with-registered-roots
|
||||
(lambda ()
|
||||
(cond
|
||||
[page-site
|
||||
;; Render to "download-page", then move up:
|
||||
(define base-dir (if (path? dest-dir)
|
||||
dest-dir
|
||||
(current-directory)))
|
||||
(parameterize ([current-directory base-dir])
|
||||
(render-all))
|
||||
(define dp-dir (build-path base-dir "download-page"))
|
||||
(for ([f (in-list (directory-list dp-dir))])
|
||||
(define f-dest (build-path base-dir f))
|
||||
(delete-directory/files f-dest #:must-exist? #f)
|
||||
(rename-file-or-directory (build-path dp-dir f) f-dest))
|
||||
(delete-directory dp-dir)]
|
||||
[else
|
||||
(call-with-output-file*
|
||||
dest
|
||||
#:exists 'truncate/replace
|
||||
(lambda (o)
|
||||
(output-xml page-content o)))]))))
|
||||
|
|
|
|||
42
pkgs/distro-build-pkgs/distro-build-server/indexes.rkt
Normal file
42
pkgs/distro-build-pkgs/distro-build-server/indexes.rkt
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
#lang racket/base
|
||||
(require racket/string
|
||||
scribble/html
|
||||
plt-web)
|
||||
|
||||
(provide generate-index-html)
|
||||
|
||||
(define (generate-index-html dest-dir sub-dir www-site)
|
||||
(define content
|
||||
(for/list ([f (directory-list (build-path dest-dir sub-dir))])
|
||||
(define fp (build-path dest-dir sub-dir f))
|
||||
(if (file-exists? fp)
|
||||
(cons f (file-size fp))
|
||||
(cons f 'dir))))
|
||||
(cond
|
||||
[www-site
|
||||
(define web-dir (string-join (map path-element->string (explode-path sub-dir)) "/"))
|
||||
(log-error "web ~s" web-dir)
|
||||
(define s
|
||||
(site web-dir
|
||||
#:url "http://index.racket-lang.org"
|
||||
#:share-from www-site
|
||||
#:always-abs-url? #f))
|
||||
(define is (index-site s))
|
||||
(index-page is 'same content)
|
||||
(void)]
|
||||
[else
|
||||
(define page-content
|
||||
(html (head (title "Index"))
|
||||
(body (table
|
||||
(for/list ([c (in-list content)])
|
||||
(tr (td (a href: (car c)
|
||||
((if (eq? 'dir (cdr c))
|
||||
(lambda (p)
|
||||
(format "[~a]" p))
|
||||
values)
|
||||
(car c))))))))))
|
||||
(call-with-output-file*
|
||||
(build-path dest-dir sub-dir "index.html")
|
||||
(lambda (o)
|
||||
(output-xml page-content o)))]))
|
||||
|
||||
|
|
@ -6,7 +6,9 @@
|
|||
"distro-build-client"
|
||||
"web-server-lib"
|
||||
"ds-store-lib"
|
||||
"net-lib"))
|
||||
"net-lib"
|
||||
"scribble-html-lib"
|
||||
"plt-web-lib"))
|
||||
(define build-deps '("at-exp-lib"))
|
||||
|
||||
(define pkg-desc "server-side part of \"distro-build\"")
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require racket/cmdline
|
||||
racket/file
|
||||
net/url
|
||||
scribble/html
|
||||
"download-page.rkt"
|
||||
(only-in distro-build/config extract-options))
|
||||
|
||||
|
|
@ -22,6 +23,10 @@
|
|||
'#:site-dest
|
||||
(build-path build-dir "site")))
|
||||
|
||||
(define site-title (hash-ref config
|
||||
'#:site-title
|
||||
"Racket Downloads"))
|
||||
|
||||
(define current-snapshot
|
||||
(let-values ([(base name dir?) (split-path site-dir)])
|
||||
(path-element->string name)))
|
||||
|
|
@ -100,6 +105,8 @@
|
|||
|
||||
(printf "Generating web page\n")
|
||||
(make-download-page table-file
|
||||
#:title site-title
|
||||
#:plt-web-style? (hash-ref config '#:plt-web-style? #t)
|
||||
#:past-successes past-successes
|
||||
#:installers-url "current/installers/"
|
||||
#:log-dir (build-path site-dir "log")
|
||||
|
|
@ -113,19 +120,20 @@
|
|||
#:current-rx current-rx
|
||||
#:git-clone (current-directory)
|
||||
#:help-table (hash-ref config '#:site-help (hash))
|
||||
#:post-content `((p "Snapshot ID: "
|
||||
(a ((href ,(string-append current-snapshot
|
||||
"/index.html")))
|
||||
,current-snapshot))
|
||||
,@(let ([snapshots (get-snapshots)])
|
||||
(if ((length snapshots) . < . 2)
|
||||
null
|
||||
`((div ([class "detail"])
|
||||
"Other available snapshots:"
|
||||
,@(for/list ([s (remove "current"
|
||||
(remove current-snapshot
|
||||
(sort snapshots string>?)))])
|
||||
`(span ([class "detail"])
|
||||
nbsp
|
||||
(a ([href ,(string-append s "/index.html")])
|
||||
,s)))))))))
|
||||
#:post-content (list
|
||||
(p "Snapshot ID: "
|
||||
(a href: (string-append current-snapshot
|
||||
"/index.html")
|
||||
current-snapshot))
|
||||
(let ([snapshots (get-snapshots)])
|
||||
(if ((length snapshots) . < . 2)
|
||||
null
|
||||
(div class: "detail"
|
||||
"Other available snapshots:"
|
||||
(for/list ([s (remove "current"
|
||||
(remove current-snapshot
|
||||
(sort snapshots string>?)))])
|
||||
(span class: "detail"
|
||||
nbsp
|
||||
(a href: (string-append s "/index.html")
|
||||
s))))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user