suzanne.soy/distro-build
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

distro-build: use plt-web style for site or snapshot page

Browse Source 
original commit: 23fa168309e2df86641794ff0cd668468e8e5143
This commit is contained in:
Matthew Flatt 2014-03-20 13:28:21 -06:00
parent 37b51c6b7b
commit c043fed508
7 changed files with 338 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
pkgs/distro-build-pkgs/distro-build-client/doc.txt
View File

@ -253,17 +253,14 @@ Site-configuration keywords (where <string*> means no spaces, etc.):
clients typically have no native-library packages; the default is clients typically have no native-library packages; the default is
the value of `#:source?' the value of `#:source?'
#:source-pkgs? --- if true, then packages are included in the #:source-pkgs? <boolean> --- if true, then packages are included in
installer/archive only in source form; a true value works best th installer/archive only in source form; a true value works best
when the `#:source-runtime?' value is also #t; the default is the when the `#:source-runtime?' value is also #t; the default is the
value of `#:source?' 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 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 #:pause-before <nonnegative-number> --- a pause in seconds to
wait before starting a machine, which may help a virtual machine wait before starting a machine, which may help a virtual machine
avoid confusion from being stopped and started too quickly; the 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 removing "{...}"), and the values are X-expressions for the help
content 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 More precisely, the `distro-build/config' language is like
`racket/base' except that the module body must have exactly one `racket/base' except that the module body must have exactly one
expression (plus any number of definitions, etc.) that produces a expression (plus any number of definitions, etc.) that produces a

20
pkgs/distro-build-pkgs/distro-build-server/assemble-site.rkt
View File

@ -3,7 +3,9 @@
racket/file racket/file
net/url net/url
"download-page.rkt" "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) (module test racket/base)
@ -32,6 +34,15 @@
'#:site-dest '#:site-dest
(build-path build-dir "site"))) (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) (printf "Assembling site as ~a\n" dest-dir)
(define (copy dir [build-dir build-dir]) (define (copy dir [build-dir build-dir])
@ -100,21 +111,26 @@
(newline o)))) (newline o))))
(copy log-dir) (copy log-dir)
(generate-index-html dest-dir log-dir www-site)
(copy installers-dir) (copy installers-dir)
(generate-index-html dest-dir installers-dir www-site)
(define doc-path (build-path docs-dir doc-dir)) (define doc-path (build-path docs-dir doc-dir))
(when (directory-exists? doc-path) (when (directory-exists? doc-path)
(copy doc-dir docs-dir)) (copy doc-dir docs-dir))
(define pdf-doc-path (build-path build-dir pdf-doc-dir)) (define pdf-doc-path (build-path build-dir pdf-doc-dir))
(when (directory-exists? pdf-doc-path) (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 "stamp.txt")
(copy (build-path "origin" "collects.tgz")) (copy (build-path "origin" "collects.tgz"))
(make-download-page (build-path build-dir (make-download-page (build-path build-dir
installers-dir installers-dir
"table.rktd") "table.rktd")
#:plt-www-site www-site
#:title site-title
#:installers-url "installers/" #:installers-url "installers/"
#:log-dir-url "log/" #:log-dir-url "log/"
#:docs-url (and (directory-exists? doc-path) #:docs-url (and (directory-exists? doc-path)

2
pkgs/distro-build-pkgs/distro-build-server/config.rkt
View File

@ -148,8 +148,10 @@
[(#:mac-pkg?) (boolean? val)] [(#:mac-pkg?) (boolean? val)]
[(#:site-dest) (path-string? val)] [(#:site-dest) (path-string? val)]
[(#:site-help) (hash? val)] [(#:site-help) (hash? val)]
[(#:site-title) (string? val)]
[(#:pdf-doc?) (boolean? val)] [(#:pdf-doc?) (boolean? val)]
[(#:max-snapshots) (real? val)] [(#:max-snapshots) (real? val)]
[(#:plt-web-style?) (boolean? val)]
[(#:pause-before) (and (real? val) (not (negative? val)))] [(#:pause-before) (and (real? val) (not (negative? val)))]
[(#:pause-after) (and (real? val) (not (negative? val)))] [(#:pause-after) (and (real? val) (not (negative? val)))]
[(#:readme) (or (string? val) [(#:readme) (or (string? val)

271
pkgs/distro-build-pkgs/distro-build-server/download-page.rkt
View File

@ -3,9 +3,13 @@
racket/path racket/path
racket/system racket/system
racket/list racket/list
racket/date
racket/file
net/url net/url
openssl/sha1 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 (provide make-download-page
get-installers-table get-installers-table
@ -21,12 +25,14 @@
(define table-file (define table-file
(command-line (command-line
#:once-each #:once-each
[("--at") url "URL for installaters reletaive to download page" [("--at") url "URL for installers relative to download page"
(arg! '#:installers-url url)] (arg! '#:installers-url url)]
[("--dest") file "Write to <dest>" [("--dest") file "Write to <dest>"
(arg! '#:dest file)] (arg! '#:dest file)]
[("--git") dir "Report information from git clone <dir>" [("--git") dir "Report information from git clone <dir>"
(arg! '#:git-clone dir)] (arg! '#:git-clone dir)]
[("--plt") "Use PLT web page style"
(arg! '#:plt-web-style? #t)]
#:args #:args
(table-file) (table-file)
table-file)) table-file))
@ -57,18 +63,20 @@
#:log-dir-url [log-dir-url #f] #:log-dir-url [log-dir-url #f]
#:docs-url [docs-url #f] #:docs-url [docs-url #f]
#:pdf-docs-url [pdf-docs-url #f] #:pdf-docs-url [pdf-docs-url #f]
#:title [title "Racket Downloads"] #:title [page-title "Racket Downloads"]
#:current-rx [current-rx #f] #:current-rx [current-rx #f]
#:git-clone [git-clone #f] #:git-clone [git-clone #f]
#:help-table [site-help (hash)] #: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 base-table (get-installers-table table-file))
(define table (for/fold ([table base-table]) ([(k v) (in-hash past-successes)]) (define table-data (for/fold ([table-data base-table]) ([(k v) (in-hash past-successes)])
(if (hash-ref table k #f) (if (hash-ref table-data k #f)
table table-data
(hash-set table k v)))) (hash-set table-data k v))))
(define (system*/string . args) (define (system*/string . args)
(define s (open-output-string)) (define s (open-output-string))
@ -78,10 +86,10 @@
(define log-link (define log-link
(and log-dir-url (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 (define sorted
(sort (hash-keys table) string<?)) (sort (hash-keys table-data) string<?))
(define sorted-and-split (define sorted-and-split
(map (lambda (s) (map (lambda (s)
(map (lambda (e) (map (lambda (e)
@ -103,7 +111,7 @@
(cons '(#f) l) (cons '(#f) l)
l)) l))
(cond (cond
[(null? l) '((#f) (#f nbsp))] [(null? l) `((#f) (#f ,nbsp))]
[(not (equal? prev (take (car l) len))) [(not (equal? prev (take (car l) len)))
;; move out a layer: ;; move out a layer:
(loop l keys (drop-right prev 1) #t)] (loop l keys (drop-right prev 1) #t)]
@ -111,7 +119,7 @@
;; a leaf entry: ;; a leaf entry:
(add-sep (add-sep
(cons (cons (car keys) (cons (cons (car keys)
(append (make-list len 'nbsp) (append (make-list len nbsp)
(list (list-ref (car l) len)))) (list (list-ref (car l) len))))
(loop (cdr l) (cdr keys) prev #t)))] (loop (cdr l) (cdr keys) prev #t)))]
[else [else
@ -119,10 +127,24 @@
(define section (list-ref (car l) len)) (define section (list-ref (car l) len))
(add-sep (add-sep
(cons (cons #f (cons (cons #f
(append (make-list len 'nbsp) (append (make-list len nbsp)
(list section))) (list section)))
(loop l keys (append prev (list section)) #t)))]))) (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) (define (get-site-help last-col)
(let ([h (hash-ref site-help last-col #f)]) (let ([h (hash-ref site-help last-col #f)])
(if h (if h
@ -130,36 +152,50 @@
[toggle (let ([elem (~a "document.getElementById" "('" id "')")]) [toggle (let ([elem (~a "document.getElementById" "('" id "')")])
(~a elem ".style.display = ((" elem ".style.display == 'inline') ? 'none' : 'inline');" (~a elem ".style.display = ((" elem ".style.display == 'inline') ? 'none' : 'inline');"
" return false;"))]) " return false;"))])
`(" " (list
(div ([class "helpbutton"]) " "
(a ([href "#"] (div class: "helpbutton"
[class "helpbuttonlabel"] (a href: "#"
[onclick ,toggle] class: "helpbuttonlabel"
[title "explain"]) onclick: toggle
title: "explain"
nbsp "?" nbsp)) nbsp "?" nbsp))
(div ([class "hiddenhelp"] (div class: "hiddenhelp"
[id ,id] id: id
[onclick ,toggle] onclick: toggle
[style "display: none"]) style: "display: none"
(div ([class "helpcontent"]) (div class: "helpcontent"
(div ([class "helptext"]) (div class: "helptext"
,h))))) (xexpr->html h))))))
null))) null)))
(call-with-output-file* (define page-site (and plt-style?
dest (site "download-page"
#:exists 'truncate/replace #:url "http://page.racket-lang.org/"
(lambda (o) #:navigation (if docs-url
(parameterize ([empty-tag-shorthand html-empty-tags]) (list nbsp
(write-xexpr nbsp
`(html (a href: docs-url "Documentation")
(head (title ,title) (if pdf-docs-url
(style @,~a|{ (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; } .detail { font-size: small; }
.checksum, .path { font-family: monospace; } .checksum, .path { font-family: monospace; }
.group { background-color : #ccccff; padding-left: 0.5ex; } .group { background-color : #ccccff; padding-left: 0.5ex; }
.major { font-weight : bold; font-size : large; left-border: 1ex; } .major { font-weight : bold; font-size : large; left-border: 1ex; }
.minor { font-weight : bold; } .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 { .helpbutton {
display: inline; display: inline;
font-family: sans-serif; font-family: sans-serif;
@ -175,7 +211,6 @@
} }
.helpcontent { .helpcontent {
width: 20em; width: 20em;
font-family: serif;
font-size : small; font-size : small;
font-weight : normal; font-weight : normal;
background-color: #ffffee; background-color: #ffffee;
@ -184,12 +219,17 @@
} }
a { text-decoration: none; } a { text-decoration: none; }
}|)) }|))
(body
(h2 ,title) (define page-body
(list
(if page-title
((if plt-style? h3 h2) page-title)
null)
(table (table
,@(for/list ([elem (in-list elems)]) class: "download-table"
(for/list ([elem (in-list elems)])
(define key (car elem)) (define key (car elem))
(define inst (and key (hash-ref table key))) (define inst (and key (hash-ref table-data key)))
(define mid-cols (if (null? (cdr elem)) (define mid-cols (if (null? (cdr elem))
#f #f
(drop-right (cdr elem) 1))) (drop-right (cdr elem) 1)))
@ -204,88 +244,92 @@
"5")) "5"))
(cond (cond
[(not mid-cols) [(not mid-cols)
`(tr (td ((colspan ,num-cols)) nbsp))] (tr (td colspan: num-cols nbsp))]
[inst [inst
`(tr (td (tr (td
,@(for/list ([col (in-list mid-cols)]) (for/list ([col (in-list mid-cols)])
`(span nbsp nbsp nbsp)) (span nbsp nbsp nbsp))
,(if (past-success? inst) (if (past-success? inst)
;; Show missing installer ;; Show missing installer
`(span ((class ,(string-append "no-installer " level-class))) (span class: (string-append "no-installer " level-class)
,last-col) last-col)
;; Link to installer ;; Link to installer
`(a ((class ,(string-append "installer " level-class)) (a class: (string-append "installer " level-class)
(href ,(url->string href: (url->string
(combine-url/relative (combine-url/relative
(string->url installers-url) (string->url installers-url)
inst)))) inst))
,last-col)) last-col))
,@(get-site-help last-col)) (get-site-help last-col))
(td nbsp) (td nbsp)
(td ,(if (past-success? inst) (td (if (past-success? inst)
`(span ([class "detail"]) "") (span class: "detail" "")
`(span ([class "detail"]) (span class: "detail"
,(~r (/ (file-size (build-path (path-only table-file) (~r (/ (file-size (build-path (path-only table-file)
inst)) inst))
(* 1024 1024)) (* 1024 1024))
#:precision 1) #:precision 1)
" MB"))) " MB")))
(td nbsp) (td nbsp)
(td ,(if (past-success? inst) (td (if (past-success? inst)
`(span ([class "detail"]) (span class: "detail"
,@(if (and log-dir (if (and log-dir
(file-exists? (build-path log-dir key))) (file-exists? (build-path log-dir key)))
`((a ([href ,(url->string (list
(a href: (url->string
(combine-url/relative (combine-url/relative
(string->url log-dir-url) (string->url log-dir-url)
key))]) key))
"build failed") "build failed")
"; ") "; ")
null) null)
"last success: " "last success: "
(a ((href ,(~a (past-success-relative-url inst)))) (a href: (~a (past-success-relative-url inst))
,(past-success-name inst))) (past-success-name inst)))
`(span ([class "detail"]) (span class: "detail"
"SHA1: " "SHA1: "
(span ([class "checksum"]) (span class: "checksum"
,(call-with-input-file* (call-with-input-file*
(build-path (path-only table-file) (build-path (path-only table-file)
inst) inst)
sha1))))) sha1)))))
,@(if current-rx (if current-rx
`((td nbsp) (list
(td (span ([class "detail"]) (td nbsp)
,(let ([inst-path (if (past-success? inst) (td (span class: "detail"
(let ([inst-path (if (past-success? inst)
(past-success-file inst) (past-success-file inst)
inst)]) inst)])
(if (regexp-match? current-rx inst-path) (if (regexp-match? current-rx inst-path)
`(a ([href ,(url->string (a href: (url->string
(combine-url/relative (combine-url/relative
(string->url installers-url) (string->url installers-url)
(bytes->string/utf-8 (bytes->string/utf-8
(regexp-replace current-rx (regexp-replace current-rx
(string->bytes/utf-8 inst-path) (string->bytes/utf-8 inst-path)
#"current"))))]) #"current"))))
"as " ldquo "current" rdquo) "as " ldquo "current" rdquo)
'nbsp))))) nbsp)))))
null))] null))]
[else [else
`(tr (td ((class ,level-class) (tr (td class: level-class
(colspan ,num-cols)) colspan: num-cols
,@(for/list ([col (in-list mid-cols)]) (for/list ([col (in-list mid-cols)])
`(span nbsp nbsp nbsp)) (span nbsp nbsp nbsp))
,last-col last-col
,@(get-site-help last-col)))]))) (get-site-help last-col)))])))
,@(if docs-url (if (and docs-url
`((p (a ((href ,docs-url)) "Documentation") (not site))
,@(if pdf-docs-url (p (a href: docs-url "Documentation")
`(nbsp (if pdf-docs-url
(list
nbsp nbsp
(span ([class "detail"]) nbsp
(a ((href ,pdf-docs-url)) "[also available as PDF]"))) (span class: "detail"
null))) (a href: pdf-docs-url "[also available as PDF]")))
null))
null) null)
,@(if git-clone (if git-clone
(let ([git (find-executable-path "git")]) (let ([git (find-executable-path "git")])
(define origin (let ([s (system*/string git "remote" "show" "origin")]) (define origin (let ([s (system*/string git "remote" "show" "origin")])
(define m (regexp-match #rx"(?m:Fetch URL: (.*)$)" s)) (define m (regexp-match #rx"(?m:Fetch URL: (.*)$)" s))
@ -293,14 +337,49 @@
(cadr m) (cadr m)
"???"))) "???")))
(define stamp (system*/string git "log" "-1" "--format=%H")) (define stamp (system*/string git "log" "-1" "--format=%H"))
`((p (p
(div (span ([class "detail"]) "Repository: " (span ([class "path"]) ,origin))) (div (span class: "detail" "Repository: " (span class: "path" origin)))
(div (span ([class "detail"]) "Commit: " (span ([class "checksum"]) ,stamp))) (div (span class: "detail" "Commit: " (span class: "checksum" stamp)))
,@(or log-link null)))) (or log-link null)))
null) null)
,@(if (and log-link (not git-clone)) (if (and log-link (not git-clone))
`((p ,@log-link)) (p log-link)
null) null)
,@post-content)) post-content))
o)
(void))))) (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
View 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)))]))

4
pkgs/distro-build-pkgs/distro-build-server/info.rkt
View File

@ -6,7 +6,9 @@
"distro-build-client" "distro-build-client"
"web-server-lib" "web-server-lib"
"ds-store-lib" "ds-store-lib"
"net-lib")) "net-lib"
"scribble-html-lib"
"plt-web-lib"))
(define build-deps '("at-exp-lib")) (define build-deps '("at-exp-lib"))
(define pkg-desc "server-side part of \"distro-build\"") (define pkg-desc "server-side part of \"distro-build\"")

28
pkgs/distro-build-pkgs/distro-build-server/manage-snapshots.rkt
View File

@ -2,6 +2,7 @@
(require racket/cmdline (require racket/cmdline
racket/file racket/file
net/url net/url
scribble/html
"download-page.rkt" "download-page.rkt"
(only-in distro-build/config extract-options)) (only-in distro-build/config extract-options))
@ -22,6 +23,10 @@
'#:site-dest '#:site-dest
(build-path build-dir "site"))) (build-path build-dir "site")))
(define site-title (hash-ref config
'#:site-title
"Racket Downloads"))
(define current-snapshot (define current-snapshot
(let-values ([(base name dir?) (split-path site-dir)]) (let-values ([(base name dir?) (split-path site-dir)])
(path-element->string name))) (path-element->string name)))
@ -100,6 +105,8 @@
(printf "Generating web page\n") (printf "Generating web page\n")
(make-download-page table-file (make-download-page table-file
#:title site-title
#:plt-web-style? (hash-ref config '#:plt-web-style? #t)
#:past-successes past-successes #:past-successes past-successes
#:installers-url "current/installers/" #:installers-url "current/installers/"
#:log-dir (build-path site-dir "log") #:log-dir (build-path site-dir "log")
@ -113,19 +120,20 @@
#:current-rx current-rx #:current-rx current-rx
#:git-clone (current-directory) #:git-clone (current-directory)
#:help-table (hash-ref config '#:site-help (hash)) #:help-table (hash-ref config '#:site-help (hash))
#:post-content `((p "Snapshot ID: " #:post-content (list
(a ((href ,(string-append current-snapshot (p "Snapshot ID: "
"/index.html"))) (a href: (string-append current-snapshot
,current-snapshot)) "/index.html")
,@(let ([snapshots (get-snapshots)]) current-snapshot))
(let ([snapshots (get-snapshots)])
(if ((length snapshots) . < . 2) (if ((length snapshots) . < . 2)
null null
`((div ([class "detail"]) (div class: "detail"
"Other available snapshots:" "Other available snapshots:"
,@(for/list ([s (remove "current" (for/list ([s (remove "current"
(remove current-snapshot (remove current-snapshot
(sort snapshots string>?)))]) (sort snapshots string>?)))])
`(span ([class "detail"]) (span class: "detail"
nbsp nbsp
(a ([href ,(string-append s "/index.html")]) (a href: (string-append s "/index.html")
,s))))))))) s))))))))