From c043fed508ade6f520b04843b38cf8c44765c629 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 Mar 2014 13:28:21 -0600 Subject: [PATCH] distro-build: use `plt-web` style for site or snapshot page original commit: 23fa168309e2df86641794ff0cd668468e8e5143 --- .../distro-build-client/doc.txt | 19 +- .../distro-build-server/assemble-site.rkt | 20 +- .../distro-build-server/config.rkt | 2 + .../distro-build-server/download-page.rkt | 393 +++++++++++------- .../distro-build-server/indexes.rkt | 42 ++ .../distro-build-server/info.rkt | 4 +- .../distro-build-server/manage-snapshots.rkt | 40 +- 7 files changed, 338 insertions(+), 182 deletions(-) create mode 100644 pkgs/distro-build-pkgs/distro-build-server/indexes.rkt diff --git a/pkgs/distro-build-pkgs/distro-build-client/doc.txt b/pkgs/distro-build-pkgs/distro-build-client/doc.txt index a9005ee..8d9d1b7 100644 --- 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 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? --- 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? --- if true, creates a ".pkg" for Mac OS X (in single-file format) instead of a ".dmg"; the default is #f - #:max-snapshots --- number of snapshots to keep, used by - the `snapshot-site' makefile target - #:pause-before --- 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 --- title for the main page generated + by the `site' or `snapshot-site' makefile target; the default + is "Racket Downloads" + + #:max-snapshots --- number of snapshots to keep, used by + the `snapshot-site' makefile target + + #:plt-web-style? --- 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 index e446422..72ccf7a 100644 --- 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 index 1c2548d..8d20fee 100644 --- 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 index 05e1922..fcb06e1 100644 --- 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 " (arg! '#:dest file)] [("--git") dir "Report information from git clone " (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) stringhtml 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 new file mode 100644 index 0000000..a0661ee --- /dev/null +++ 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 index 1d92f36..f2bb39a 100644 --- 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 index 560e5d7..53a857f 100644 --- 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))))))))