commit c043fed508ade6f520b04843b38cf8c44765c629
parent 37b51c6b7b78b67939e1ef7990ce263b14099321
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 20 Mar 2014 13:28:21 -0600
distro-build: use `plt-web` style for site or snapshot page
original commit: 23fa168309e2df86641794ff0cd668468e8e5143
Diffstat:
7 files changed, 338 insertions(+), 182 deletions(-)
diff --git a/pkgs/distro-build-pkgs/distro-build-client/doc.txt b/pkgs/distro-build-pkgs/distro-build-client/doc.txt
@@ -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
diff --git a/pkgs/distro-build-pkgs/distro-build-server/assemble-site.rkt b/pkgs/distro-build-pkgs/distro-build-server/assemble-site.rkt
@@ -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)
diff --git a/pkgs/distro-build-pkgs/distro-build-server/config.rkt b/pkgs/distro-build-pkgs/distro-build-server/config.rkt
@@ -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)
diff --git a/pkgs/distro-build-pkgs/distro-build-server/download-page.rkt b/pkgs/distro-build-pkgs/distro-build-server/download-page.rkt
@@ -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)))]))))
diff --git a/pkgs/distro-build-pkgs/distro-build-server/indexes.rkt b/pkgs/distro-build-pkgs/distro-build-server/indexes.rkt
@@ -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)))]))
+
diff --git a/pkgs/distro-build-pkgs/distro-build-server/info.rkt b/pkgs/distro-build-pkgs/distro-build-server/info.rkt
@@ -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\"")
diff --git a/pkgs/distro-build-pkgs/distro-build-server/manage-snapshots.rkt b/pkgs/distro-build-pkgs/distro-build-server/manage-snapshots.rkt
@@ -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))))))))
