cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add a builds page for a specific revision

Browse source 
Like the /builds page, but filtered for a specific revision.
This commit is contained in:
Christopher Baines 2019-12-14 21:02:27 +00:00
parent a84fc954d1
commit 6a0332bed2
2 changed files with 177 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

78
guix-data-service/web/revision/controller.scm
View file

@ -16,6 +16,7 @@
;;; <http://www.gnu.org/licenses/>.
(define-module (guix-data-service web revision controller)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (web uri)
#:use-module (web request)
@ -28,6 +29,9 @@
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util)
#:use-module (guix-data-service jobs load-new-guix-revision)
#:use-module (guix-data-service model build)
#:use-module (guix-data-service model build-server)
#:use-module (guix-data-service model build-status)
#:use-module (guix-data-service model channel-news)
#:use-module (guix-data-service model package)
#:use-module (guix-data-service model git-branch)
@ -59,6 +63,28 @@
(define (parse-system s)
s)
(define (parse-build-status status)
(if (member status build-status-strings)
status
(make-invalid-query-parameter
status
(string-append "unknown build status: "
status))))
(define (parse-build-server conn)
(lambda (v)
(let ((build-servers (select-build-servers conn)))
(or (any (match-lambda
((id url lookup-all-derivations?)
(if (eq? (string->number v)
id)
id
#f)))
build-servers)
(make-invalid-query-parameter
v
"unknown build server")))))
(define (revision-controller request
method-and-path-components
mime-types
@ -189,6 +215,22 @@
(render-unknown-revision mime-types
conn
commit-hash)))
(('GET "revision" commit-hash "builds")
(if (guix-commit-exists? conn commit-hash)
(let ((parsed-query-parameters
(parse-query-parameters
request
`((build_status ,parse-build-status #:multi-value)
(build_server ,(parse-build-server conn) #:multi-value)))))
(render-revision-builds mime-types
conn
commit-hash
parsed-query-parameters
#:path-base path))
(render-unknown-revision mime-types
conn
commit-hash)))
(('GET "revision" commit-hash "lint-warnings")
(if (guix-commit-exists? conn commit-hash)
(let ((parsed-query-parameters
@ -647,6 +689,42 @@
#:header-text header-text
#:header-link header-link)))))))
(define* (render-revision-builds mime-types
conn
commit-hash
query-parameters
#:key
(path-base "/revision/")
(header-text
`("Revision " (samp ,commit-hash)))
(header-link
(string-append "/revision/" commit-hash)))
(if (any-invalid-query-parameters? query-parameters)
(render-html
#:sxml (view-revision-builds query-parameters
build-status-strings
'()
'()
'()))
(render-html
#:sxml (view-revision-builds query-parameters
build-status-strings
(map (match-lambda
((id url lookup-all-derivations)
(cons url id)))
(select-build-servers conn))
(select-build-stats
conn
(assq-ref query-parameters
'build_server)
#:revision-commit commit-hash)
(select-builds-with-context
conn
(assq-ref query-parameters
'build_status)
(assq-ref query-parameters
'build_server))))))
(define* (render-revision-lint-warnings mime-types
conn
commit-hash

99
guix-data-service/web/revision/html.scm
View file

@ -32,6 +32,7 @@
view-revision-packages
view-revision-derivations
view-revision-derivation-outputs
view-revision-builds
view-revision-lint-warnings
unknown-revision))
@ -867,6 +868,104 @@
"Next page")))
'())))))))
(define (view-revision-builds query-parameters
build-status-strings
build-server-options
stats
builds)
(layout
#:body
`(,(header)
(div
(@ (class "container"))
(div
(@ (class "row"))
(div
(@ (class "col-sm-12"))
(h1 "Builds")
(table
(@ (class "table"))
(thead
(tr
(th (@ (class "col-md-2")) "Status")
,@(map (match-lambda
((url . id)
`(th (@ (class "col-md-2"))
,url)))
build-server-options)))
(tbody
,@(map
(match-lambda
((status counts-by-build-server-id)
`(tr
(td ,(build-status-span status))
,@(map (lambda (id)
`(td ,(or (assq-ref counts-by-build-server-id
id)
0)))
(map cdr build-server-options)))))
stats)))))
(div
(@ (class "row"))
(div
(@ (class "col-md-12"))
(div
(@ (class "well"))
(form
(@ (method "get")
(action "")
(class "form-horizontal"))
,(form-horizontal-control
"Build status" query-parameters
#:options
(map (lambda (build-status)
(cons (build-status-value->display-string build-status)
build-status))
build-status-strings)
#:help-text "Return builds with these statuses.")
,(form-horizontal-control
"Build server"
query-parameters
#:options build-server-options
#:help-text "Return builds from these build servers.")
(div (@ (class "form-group form-group-lg"))
(div (@ (class "col-sm-offset-2 col-sm-10"))
(button (@ (type "submit")
(class "btn btn-lg btn-primary"))
"Update results")))))))
(div
(@ (class "row"))
(div
(@ (class "col-sm-12"))
(table
(@ (class "table"))
(thead
(tr
(th (@ (class "col-xs-2")) "Status")
(th (@ (class "col-xs-9")) "Derivation")
(th (@ (class "col-xs-1")) "Started at")
(th (@ (class "col-xs-1")) "Finished at")
(th (@ (class "col-xs-1")) "")))
(tbody
,@(map
(match-lambda
((build-id build-server-url derivation-file-name
timestamp status)
`(tr
(td (@ (class "text-center"))
,(build-status-span status))
(td (a (@ (href ,derivation-file-name))
,(display-store-item-short derivation-file-name)))
(td ,timestamp)
(td (a (@ (href ,(simple-format
#f "~Abuild/~A"
build-server-url
(string-drop
derivation-file-name
(string-length "/gnu/store/")))))
"View build on " ,build-server-url)))))
builds)))))))))
(define* (view-revision-lint-warnings revision-commit-hash
query-parameters
lint-warnings