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

Support querying builds by build servers

Browse source
This commit is contained in:
Christopher Baines 2019-12-01 22:18:00 +00:00
parent f7069456b5
commit a0ce016c02
3 changed files with 60 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

33
guix-data-service/model/build.scm
View file

@ -28,7 +28,24 @@ ORDER BY status")
(exec-query conn query))
(define (select-builds-with-context conn build-statuses)
(define (select-builds-with-context conn build-statuses build-server-ids)
(define where-conditions
(filter
string?
(list
(when (list? build-statuses)
(string-append
"latest_build_status.status IN ("
(string-join (map quote-string build-statuses)
",")
")"))
(when (list? build-server-ids)
(string-append
"builds.build_server_id IN ("
(string-join (map number->string build-server-ids)
", ")
")")))))
(define query
(string-append "
SELECT builds.id, build_servers.url, derivations.file_name,
@ -44,14 +61,12 @@ INNER JOIN
) AS latest_build_status
ON latest_build_status.build_id = builds.id
"
(if (list? build-statuses)
(string-append
"WHERE latest_build_status.status IN ("
(string-join (map quote-string build-statuses)
",")
")")
"")
"
(if (null? where-conditions)
""
(string-append
"WHERE "
(string-join where-conditions " AND ")))
"
ORDER BY latest_build_status.timestamp DESC
LIMIT 100"))

28
guix-data-service/web/build/controller.scm
View file

@ -16,11 +16,13 @@
;;; <http://www.gnu.org/licenses/>.
(define-module (guix-data-service web build controller)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service model build)
#:use-module (guix-data-service model build-status)
#:use-module (guix-data-service model build-server)
#:use-module (guix-data-service web build html)
#:export (build-controller))
@ -32,6 +34,20 @@
(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 (build-controller request
method-and-path-components
mime-types
@ -48,18 +64,26 @@
(let ((parsed-query-parameters
(parse-query-parameters
request
`((build_status ,parse-build-status #:multi-value)))))
`((build_status ,parse-build-status #:multi-value)
(build_server ,(parse-build-server conn) #:multi-value)))))
(if (any-invalid-query-parameters? parsed-query-parameters)
(render-html
#:sxml (view-builds parsed-query-parameters
build-status-strings
'()
'()
'()))
(render-html
#:sxml (view-builds parsed-query-parameters
build-status-strings
(map (match-lambda
((id url lookup-all-derivations)
(cons url id)))
(select-build-servers conn))
(select-build-stats conn)
(select-builds-with-context
conn
(assq-ref parsed-query-parameters
'build_status)))))))
'build_status)
(assq-ref parsed-query-parameters
'build_server)))))))

11
guix-data-service/web/build/html.scm
View file

@ -21,7 +21,11 @@
#:use-module (guix-data-service web view html)
#:export (view-builds))
(define (view-builds query-parameters build-status-strings stats builds)
(define (view-builds query-parameters
build-status-strings
build-server-options
stats
builds)
(layout
#:body
`(,(header)
@ -64,6 +68,11 @@
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")