diff options
author | Christopher Baines <mail@cbaines.net> | 2022-11-10 22:53:21 +0000 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2022-11-11 10:35:09 +0000 |
commit | 989916b740b88a6aedb9787d359c47740a86eb9c (patch) | |
tree | adc461bd33b49d0cf420526dc636e6b2f571da6b /guix-data-service/web/revision | |
parent | 1fb291be40172d9337c5bbec3119fbe1b908f7df (diff) | |
download | data-service-989916b740b88a6aedb9787d359c47740a86eb9c.tar data-service-989916b740b88a6aedb9787d359c47740a86eb9c.tar.gz |
Add a blocking builds page
Diffstat (limited to 'guix-data-service/web/revision')
-rw-r--r-- | guix-data-service/web/revision/controller.scm | 83 | ||||
-rw-r--r-- | guix-data-service/web/revision/html.scm | 94 |
2 files changed, 177 insertions, 0 deletions
diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm index 87dd63c..564bc35 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -35,6 +35,7 @@ #: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 blocked-builds) #:use-module (guix-data-service model system) #:use-module (guix-data-service model channel-news) #:use-module (guix-data-service model channel-instance) @@ -355,6 +356,30 @@ #:path-base path)) (render-unprocessed-revision mime-types commit-hash))) + (('GET "revision" commit-hash "blocking-builds") + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-revision-loaded-successfully? conn commit-hash)))) + (let ((parsed-query-parameters + (guard-against-mutually-exclusive-query-parameters + (parse-query-parameters + request + `((build_server ,parse-build-server #:multi-value) + (system ,parse-system #:default "x86_64-linux") + (target ,parse-target #:default "") + (limit_results ,parse-result-limit + #:no-default-when (all_results) + #:default 50) + (all_results ,parse-checkbox-value))) + '((limit_results all_results))))) + + (render-revision-blocking-builds mime-types + commit-hash + parsed-query-parameters + #:path-base path)) + (render-unprocessed-revision mime-types + commit-hash))) (('GET "revision" commit-hash "lint-warnings") (if (parallel-via-thread-pool-channel (with-thread-postgresql-connection @@ -1458,6 +1483,64 @@ stats builds)))))) +(define* (render-revision-blocking-builds mime-types + 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) + (letpar& ((systems + (with-thread-postgresql-connection list-systems)) + (targets + (with-thread-postgresql-connection valid-targets))) + (render-html + #:sxml + (view-revision-blocking-builds query-parameters + commit-hash + build-status-strings + systems + (valid-targets->options targets) + '() + '()))) + (let ((system (assq-ref query-parameters 'system)) + (target (assq-ref query-parameters 'target))) + (letpar& ((systems + (with-thread-postgresql-connection list-systems)) + (targets + (with-thread-postgresql-connection valid-targets)) + (build-server-options + (with-thread-postgresql-connection + (lambda (conn) + (map (match-lambda + ((id url lookup-all-derivations + lookup-builds) + (cons url id))) + (select-build-servers conn))))) + (blocking-builds + (with-thread-postgresql-connection + (lambda (conn) + (select-blocking-builds + conn + commit-hash + #:build-server-ids + (assq-ref query-parameters 'build_server) + #:system system + #:target target + #:limit (assq-ref query-parameters + 'limit_results)))))) + (render-html + #:sxml (view-revision-blocking-builds query-parameters + commit-hash + build-status-strings + systems + (valid-targets->options targets) + build-server-options + blocking-builds)))))) + (define* (render-revision-lint-warnings mime-types commit-hash query-parameters diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm index 013674d..85ea579 100644 --- a/guix-data-service/web/revision/html.scm +++ b/guix-data-service/web/revision/html.scm @@ -41,6 +41,7 @@ view-revision-system-tests view-revision-channel-instances view-revision-builds + view-revision-blocking-builds view-revision-lint-warnings unknown-revision unprocessed-revision)) @@ -2228,6 +2229,99 @@ figure { "View build on " ,build-server-url))))) builds))))))))) +(define (view-revision-blocking-builds query-parameters + commit-hash + build-status-strings + valid-systems + valid-targets + build-server-options + blocking-builds) + (layout + #:title + (string-append "Blocking builds - Revision " (string-take commit-hash 7)) + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (h3 (a (@ (style "white-space: nowrap;") + (href ,(string-append "/revision/" commit-hash))) + "Revision " (samp ,commit-hash))) + (h1 "Blocking builds") + (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.") + ,(form-horizontal-control + "System" query-parameters + #:options valid-systems + #:allow-selecting-multiple-options #f + #:help-text "Only include derivations for this system." + #:font-family "monospace") + ,(form-horizontal-control + "Target" query-parameters + #:options valid-targets + #:allow-selecting-multiple-options #f + #:help-text "Only include derivations that are build for this system." + #:font-family "monospace") + ,(form-horizontal-control + "Limit results" query-parameters + #:help-text "The maximum number of results to return.") + ,(form-horizontal-control + "All results" query-parameters + #:type "checkbox" + #:help-text "Return all results") + (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")) + (p "Showing " ,(length blocking-builds) " results") + (div + (@ (class "col-sm-12")) + (table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-xs-10")) "Derivation") + (th (@ (class "col-xs-2")) "Blocked builds") + (tbody + ,@(map + (lambda (data) + (let ((derivation-file-name + (assq-ref data 'derivation_file_name)) + (blocked-builds-count + (assq-ref data 'blocked_build_count)) + (builds + (assq-ref data 'builds))) + `(tr + (td (a (@ (href ,derivation-file-name)) + ,@(build-statuses->build-status-labels + (vector->list builds)) + ,(display-store-item derivation-file-name))) + (td ,blocked-builds-count)))) + blocking-builds))))))))))) + (define* (view-revision-lint-warnings revision-commit-hash query-parameters lint-warnings |