commit 99a3c16e38787a8acb20cb30b1c332dbc075a99b
parent 5dc96910fae40efd3209587908596d5aded99397
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 8 Nov 2013 08:03:46 -0700
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.
original commit: 3d718b4f54b1d3b81f639cc8be974c63af44ac76
Diffstat:
3 files changed, 128 insertions(+), 51 deletions(-)
diff --git 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
@@ -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) string<?))
@@ -142,40 +161,64 @@
`(tr (td
,@(for/list ([col (in-list mid-cols)])
`(span nbsp nbsp nbsp))
- (a ((class ,(string-append "installer " level-class))
- (href ,(url->string
- (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
@@ -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-download-page (build-path site-dir
- installers-dir
- "table.rktd")
+ (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))))))
+
+
+(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"))
