From 3d718b4f54b1d3b81f639cc8be974c63af44ac76 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 8 Nov 2013 08:03:46 -0700 Subject: [PATCH] make snapshot-site: better failure display & linking Make the "current" links more stable by linking to the most recent success when a build fails. Also, add links to the build logs. --- pkgs/distro-build/assemble-site.rkt | 1 + pkgs/distro-build/download-page.rkt | 123 +++++++++++++++++-------- pkgs/distro-build/manage-snapshots.rkt | 53 ++++++++--- 3 files changed, 127 insertions(+), 50 deletions(-) diff --git a/pkgs/distro-build/assemble-site.rkt b/pkgs/distro-build/assemble-site.rkt index 9547e24196..120a5d39d1 100644 --- a/pkgs/distro-build/assemble-site.rkt +++ b/pkgs/distro-build/assemble-site.rkt @@ -114,6 +114,7 @@ installers-dir "table.rktd") #:installers-url "installers/" + #:log-dir-url "log/" #:docs-url (and (directory-exists? doc-path) "doc/index.html") #:pdf-docs-url (and (directory-exists? pdf-doc-path) diff --git a/pkgs/distro-build/download-page.rkt b/pkgs/distro-build/download-page.rkt index 45bbddc3f6..def8552b24 100644 --- a/pkgs/distro-build/download-page.rkt +++ b/pkgs/distro-build/download-page.rkt @@ -7,7 +7,9 @@ openssl/sha1 xml) -(provide make-download-page) +(provide make-download-page + get-installers-table + (struct-out past-success)) (module+ main (require racket/cmdline) @@ -35,9 +37,24 @@ (map cdr args) (list table-file)))) +(define (get-installers-table table-file) + (define table (call-with-input-file table-file read)) + (unless (hash? table) + (raise-user-error + 'make-download-page + (~a "given file does not contain a hash table\n" + " file: ~a") + table-file)) + table) + +(struct past-success (name relative-url file) #:prefab) + (define (make-download-page table-file + #:past-successes [past-successes (hash)] #:dest [dest "index.html"] #:installers-url [installers-url "./"] + #:log-dir [log-dir #f] + #:log-dir-url [log-dir-url #f] #:docs-url [docs-url #f] #:pdf-docs-url [pdf-docs-url #f] #:title [title "Racket Downloads"] @@ -45,20 +62,22 @@ #:git-clone [git-clone #f] #:post-content [post-content null]) - (define table (call-with-input-file table-file read)) + (define base-table (get-installers-table table-file)) - (unless (hash? table) - (raise-user-error - 'make-download-page - (~a "given file does not contain a hash table\n" - " file: ~a") - 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 (system*/string . args) (define s (open-output-string)) (parameterize ([current-output-port s]) (apply system* args)) (get-output-string s)) + + (define log-link + (and log-dir-url + `((div (a ([class "detail"] [href ,log-dir-url]) "Build Logs"))))) (define sorted (sort (hash-keys table) stringstring - (combine-url/relative - (string->url installers-url) - inst)))) - ,last-col)) + ,(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))) (td nbsp) - (td (span ([class "detail"]) - ,(~r (/ (file-size (build-path (path-only table-file) - inst)) - (* 1024 1024)) - #:precision 1) - " MB")) + (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 (span ([class "detail"]) - "SHA1: " - (span ([class "checksum"]) - ,(call-with-input-file* - (build-path (path-only table-file) - inst) - sha1)))) + (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"]) - ,(if (regexp-match? current-rx inst) - `(a ([href ,(url->string - (combine-url/relative - (string->url installers-url) - (bytes->string/utf-8 - (regexp-replace current-rx - (string->bytes/utf-8 inst) - #"current"))))]) - "as " ldquo "current" rdquo) - 'nbsp)))) + ,(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) @@ -202,7 +245,11 @@ (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)))))) + (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) diff --git a/pkgs/distro-build/manage-snapshots.rkt b/pkgs/distro-build/manage-snapshots.rkt index 4e62611971..eefddc0319 100644 --- a/pkgs/distro-build/manage-snapshots.rkt +++ b/pkgs/distro-build/manage-snapshots.rkt @@ -50,28 +50,57 @@ (flush-output) (delete-directory/files (build-path snapshots-dir s))))) +(printf "Loading past successes\n") +(define table-file (build-path site-dir installers-dir "table.rktd")) +(define past-successes + (let ([current-table (get-installers-table table-file)]) + (for/fold ([table (hash)]) ([s (in-list (reverse (remove current-snapshot (get-snapshots))))]) + (define past-table (get-installers-table + (build-path snapshots-dir s installers-dir "table.rktd"))) + (for/fold ([table table]) ([(k v) (in-hash past-table)]) + (if (or (hash-ref current-table k #f) + (hash-ref table k #f)) + table + (hash-set table k (past-success s + (string-append s "/index.html") + v))))))) + (define current-rx (regexp (regexp-quote (version)))) (printf "Creating \"current\" links\n") (flush-output) (make-file-or-directory-link current-snapshot link-file) (let ([installer-dir (build-path snapshots-dir current-snapshot "installers")]) + (define (currentize f) + (regexp-replace current-rx + (path->bytes f) + "current")) + (define (make-link f to-file) + (define file-link (build-path + installer-dir + (bytes->path (currentize f)))) + (when (link-exists? file-link) + (delete-file file-link)) + (make-file-or-directory-link to-file file-link)) + ;; Current successes: (for ([f (in-list (directory-list installer-dir))]) (when (regexp-match? current-rx f) - (define file-link (build-path - installer-dir - (bytes->path - (regexp-replace current-rx - (path->bytes f) - "current")))) - (when (link-exists? file-link) - (delete-file file-link)) - (make-file-or-directory-link f file-link)))) + (make-link f f))) + ;; Past successes: + (for ([v (in-hash-values past-successes)]) + (when (regexp-match? current-rx (past-success-file v)) + (make-link (string->path (past-success-file v)) + (build-path 'up 'up + (past-success-name v) installers-dir + (past-success-file v)))))) -(make-download-page (build-path site-dir - installers-dir - "table.rktd") + +(printf "Generating web page\n") +(make-download-page table-file + #:past-successes past-successes #:installers-url "current/installers/" + #:log-dir (build-path site-dir "log") + #:log-dir-url "current/log/" #:docs-url (and (directory-exists? (build-path site-dir "doc")) "current/doc/index.html") #:pdf-docs-url (and (directory-exists? (build-path site-dir "pdf-doc"))