suzanne.soy/racket-pkg-website
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Show links to test results. Closes #21.

Browse Source
This commit is contained in:
Tony Garnock-Jones 2016-08-10 15:52:15 -04:00
parent 4f84fb2511
commit d1259dfd65
1 changed files with 59 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
src/site.rkt
View File

@ -556,6 +556,8 @@
;; Optional -- sometimes #f ;; Optional -- sometimes #f
(define (package-build-failure-log pkg) (@ pkg build failure-log)) (define (package-build-failure-log pkg) (@ pkg build failure-log))
(define (package-build-success-log pkg) (@ pkg build success-log)) (define (package-build-success-log pkg) (@ pkg build success-log))
(define (package-build-test-failure-log pkg) (@ pkg build test-failure-log))
(define (package-build-test-success-log pkg) (@ pkg build test-success-log))
(define (package-build-dep-failure-log pkg) (@ pkg build dep-failure-log)) (define (package-build-dep-failure-log pkg) (@ pkg build dep-failure-log))
(define (package-build-conflicts-log pkg) (@ pkg build conflicts-log)) (define (package-build-conflicts-log pkg) (@ pkg build conflicts-log))
(define (package-ring pkg) (@ pkg ring)) (define (package-ring pkg) (@ pkg ring))
@ -625,23 +627,34 @@
`(div `(div
(span ((class "doctags-label")) "Tags: ") (span ((class "doctags-label")) "Tags: ")
,(tag-links (package-tags pkg))))) ,(tag-links (package-tags pkg)))))
,(cond ,(build-status-td pkg))))))
[(package-build-failure-log pkg)
`(td ((class "build_red")) (define (build-status-td pkg)
,(buildhost-link (package-build-failure-log pkg) "fails"))] ;; Build the index page cell for summarizing a package's build status.
[(and (package-build-success-log pkg) ;; Nothing at all is for no information on build success or failure.
(package-build-dep-failure-log pkg)) ;; Green is for build succeeded along with everything else.
`(td ((class "build_yellow")) ;; Red is for build failed.
,(buildhost-link (package-build-success-log pkg) ;; Yellow is for build succeeded, but some other problems exist.
"succeeds")
" with " (define failure-log-url (package-build-failure-log pkg))
,(buildhost-link (package-build-dep-failure-log pkg) (define success-log-url (package-build-success-log pkg))
"dependency problems"))] (define dep-failure-log-url (package-build-dep-failure-log pkg))
[(package-build-success-log pkg) (define test-failure-log-url (package-build-test-failure-log pkg))
`(td ((class "build_green")) (define test-success-log-url (package-build-test-success-log pkg))
,(buildhost-link (package-build-success-log pkg) "succeeds"))]
[else (define td-class (cond [failure-log-url "build_red"]
`(td)])))))) [(not success-log-url) ""]
[(or dep-failure-log-url test-failure-log-url) "build_yellow"]
[else "build_green"]))
`(td ((class ,td-class))
,@(for/list [(e (list (list failure-log-url "" "fails")
(list success-log-url "" "succeeds")
(list dep-failure-log-url "; has " "dependency problems")
(list test-failure-log-url "; has " "failing tests")
(list test-success-log-url "; " "tests pass")))]
(match-define (list u p l) e)
(if u `(span ,p ,(buildhost-link u l)) `(span)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -689,11 +702,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (build-status buildhost-url str label-type glyphicon-type) (define (build-status-button buildhost-url str label-type glyphicon-type)
`(p ((class "build-status")) (buildhost-link buildhost-url
"Build status: " `(span " " (span ((class ,(format "build-status-button label label-~a" label-type)))
,(buildhost-link buildhost-url
`(span ((class ,(format "label label-~a" label-type)))
,(glyphicon glyphicon-type) " " ,str)))) ,(glyphicon glyphicon-type) " " ,str))))
(define (dependencies->package-names deps) (define (dependencies->package-names deps)
@ -755,19 +766,21 @@
`(div ((class "jumbotron")) `(div ((class "jumbotron"))
(h1 ,(~a package-name)) (h1 ,(~a package-name))
(p ,(package-description pkg)) (p ,(package-description pkg))
,(cond (p ((class "build-status"))
[(package-build-failure-log pkg) "Build status: "
(build-status (package-build-failure-log pkg) ,@(for/list [(e (list (list package-build-failure-log
"failed" "danger" "fire")] "failed" "danger" "fire")
[(and (package-build-success-log pkg) (list package-build-success-log
(package-build-dep-failure-log pkg)) "ok" "success" "ok")
(build-status (package-build-dep-failure-log pkg) (list package-build-dep-failure-log
"problems" "warning" "question-sign")] "dependency problems" "warning" "question-sign")
[(package-build-success-log pkg) (list package-build-test-failure-log
(build-status (package-build-success-log pkg) "failing tests" "warning" "question-sign")
"ok" "success" "ok")] (list package-build-test-success-log
[else "passing tests" "success" "ok")))]
""]) (match-define (list url-proc str label-type glyphicon-type) e)
(define u (url-proc pkg))
(if (not u) `(span) (build-status-button u str label-type glyphicon-type))))
(div ((class "dropdown")) (div ((class "dropdown"))
,@(let ((docs (package-docs pkg))) ,@(let ((docs (package-docs pkg)))
(match docs (match docs
@ -886,6 +899,16 @@
`(li "Dependency problems: " `(li "Dependency problems: "
,(buildhost-link (package-build-dep-failure-log pkg) ,(buildhost-link (package-build-dep-failure-log pkg)
"details"))) "details")))
,@(maybe-splice
(package-build-test-failure-log pkg)
`(li "Tests failed: "
,(buildhost-link (package-build-test-failure-log pkg)
"transcript")))
,@(maybe-splice
(package-build-test-success-log pkg)
`(li "Tests succeeded: "
,(buildhost-link (package-build-test-success-log pkg)
"transcript")))
))) )))
,@(let* ((vs (package-versions pkg)) ,@(let* ((vs (package-versions pkg))
(empty-checksum "9f098dddde7f217879070816090c1e8e74d49432") (empty-checksum "9f098dddde7f217879070816090c1e8e74d49432")