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
This commit is contained in:
Matthew Flatt
parent
5dc96910fa
commit
99a3c16e38
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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,14 +62,12 @@
|
|||
#: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))
|
||||
|
|
@ -60,6 +75,10 @@
|
|||
(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<?))
|
||||
(define sorted-and-split
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user