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

make snapshot-site: better failure display & linking

Browse Source 
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 2013-11-08 08:03:46 -07:00
parent 5dc96910fa
commit 99a3c16e38
3 changed files with 127 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
pkgs/distro-build/assemble-site.rkt
View File

@ -114,6 +114,7 @@
installers-dir installers-dir
"table.rktd") "table.rktd")
#:installers-url "installers/" #:installers-url "installers/"
#:log-dir-url "log/"
#:docs-url (and (directory-exists? doc-path) #:docs-url (and (directory-exists? doc-path)
"doc/index.html") "doc/index.html")
#:pdf-docs-url (and (directory-exists? pdf-doc-path) #:pdf-docs-url (and (directory-exists? pdf-doc-path)

123
pkgs/distro-build/download-page.rkt
View File

@ -7,7 +7,9 @@
openssl/sha1 openssl/sha1
xml) xml)
(provide make-download-page) (provide make-download-page
get-installers-table
(struct-out past-success))
(module+ main (module+ main
(require racket/cmdline) (require racket/cmdline)
@ -35,9 +37,24 @@
(map cdr args) (map cdr args)
(list table-file)))) (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 (define (make-download-page table-file
#:past-successes [past-successes (hash)]
#:dest [dest "index.html"] #:dest [dest "index.html"]
#:installers-url [installers-url "./"] #:installers-url [installers-url "./"]
#:log-dir [log-dir #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 [title "Racket Downloads"]
@ -45,20 +62,22 @@
#:git-clone [git-clone #f] #:git-clone [git-clone #f]
#:post-content [post-content null]) #: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) (define table (for/fold ([table base-table]) ([(k v) (in-hash past-successes)])
(raise-user-error (if (hash-ref table k #f)
'make-download-page table
(~a "given file does not contain a hash table\n" (hash-set table k v))))
" file: ~a")
table-file))
(define (system*/string . args) (define (system*/string . args)
(define s (open-output-string)) (define s (open-output-string))
(parameterize ([current-output-port s]) (parameterize ([current-output-port s])
(apply system* args)) (apply system* args))
(get-output-string s)) (get-output-string s))
(define log-link
(and log-dir-url
`((div (a ([class "detail"] [href ,log-dir-url]) "Build Logs")))))
(define sorted (define sorted
(sort (hash-keys table) string<?)) (sort (hash-keys table) string<?))
@ -142,40 +161,64 @@
`(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))
(a ((class ,(string-append "installer " level-class)) ,(if (past-success? inst)
(href ,(url->string ;; Show missing installer
(combine-url/relative `(span ((class ,(string-append "no-installer " level-class)))
(string->url installers-url) ,last-col)
inst)))) ;; Link to installer
,last-col)) `(a ((class ,(string-append "installer " level-class))
(href ,(url->string
(combine-url/relative
(string->url installers-url)
inst))))
,last-col)))
(td nbsp) (td nbsp)
(td (span ([class "detail"]) (td ,(if (past-success? inst)
,(~r (/ (file-size (build-path (path-only table-file) `(span ([class "detail"]) "")
inst)) `(span ([class "detail"])
(* 1024 1024)) ,(~r (/ (file-size (build-path (path-only table-file)
#:precision 1) inst))
" MB")) (* 1024 1024))
#:precision 1)
" MB")))
(td nbsp) (td nbsp)
(td (span ([class "detail"]) (td ,(if (past-success? inst)
"SHA1: " `(span ([class "detail"])
(span ([class "checksum"]) ,@(if (and log-dir
,(call-with-input-file* (file-exists? (build-path log-dir key)))
(build-path (path-only table-file) `((a ([href ,(url->string
inst) (combine-url/relative
sha1)))) (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 ,@(if current-rx
`((td nbsp) `((td nbsp)
(td (span ([class "detail"]) (td (span ([class "detail"])
,(if (regexp-match? current-rx inst) ,(let ([inst-path (if (past-success? inst)
`(a ([href ,(url->string (past-success-file inst)
(combine-url/relative inst)])
(string->url installers-url) (if (regexp-match? current-rx inst-path)
(bytes->string/utf-8 `(a ([href ,(url->string
(regexp-replace current-rx (combine-url/relative
(string->bytes/utf-8 inst) (string->url installers-url)
#"current"))))]) (bytes->string/utf-8
"as " ldquo "current" rdquo) (regexp-replace current-rx
'nbsp)))) (string->bytes/utf-8 inst-path)
#"current"))))])
"as " ldquo "current" rdquo)
'nbsp)))))
null))] null))]
[else [else
`(tr (td ((class ,level-class) `(tr (td ((class ,level-class)
@ -202,7 +245,11 @@
(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))))
null)
,@(if (and log-link (not git-clone))
`((p ,@log-link))
null) null)
,@post-content)) ,@post-content))
o) o)

53
pkgs/distro-build/manage-snapshots.rkt
View File

@ -50,28 +50,57 @@
(flush-output) (flush-output)
(delete-directory/files (build-path snapshots-dir s))))) (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)))) (define current-rx (regexp (regexp-quote (version))))
(printf "Creating \"current\" links\n") (printf "Creating \"current\" links\n")
(flush-output) (flush-output)
(make-file-or-directory-link current-snapshot link-file) (make-file-or-directory-link current-snapshot link-file)
(let ([installer-dir (build-path snapshots-dir current-snapshot "installers")]) (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))]) (for ([f (in-list (directory-list installer-dir))])
(when (regexp-match? current-rx f) (when (regexp-match? current-rx f)
(define file-link (build-path (make-link f f)))
installer-dir ;; Past successes:
(bytes->path (for ([v (in-hash-values past-successes)])
(regexp-replace current-rx (when (regexp-match? current-rx (past-success-file v))
(path->bytes f) (make-link (string->path (past-success-file v))
"current")))) (build-path 'up 'up
(when (link-exists? file-link) (past-success-name v) installers-dir
(delete-file file-link)) (past-success-file v))))))
(make-file-or-directory-link f file-link))))
(make-download-page (build-path site-dir
installers-dir (printf "Generating web page\n")
"table.rktd") (make-download-page table-file
#:past-successes past-successes
#:installers-url "current/installers/" #: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")) #:docs-url (and (directory-exists? (build-path site-dir "doc"))
"current/doc/index.html") "current/doc/index.html")
#:pdf-docs-url (and (directory-exists? (build-path site-dir "pdf-doc")) #:pdf-docs-url (and (directory-exists? (build-path site-dir "pdf-doc"))