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 | |
parent | 1fb291be40172d9337c5bbec3119fbe1b908f7df (diff) | |
download | data-service-989916b740b88a6aedb9787d359c47740a86eb9c.tar data-service-989916b740b88a6aedb9787d359c47740a86eb9c.tar.gz |
Add a blocking builds page
Diffstat (limited to 'guix-data-service')
-rw-r--r-- | guix-data-service/model/blocked-builds.scm | 115 | ||||
-rw-r--r-- | guix-data-service/web/revision/controller.scm | 83 | ||||
-rw-r--r-- | guix-data-service/web/revision/html.scm | 94 |
3 files changed, 291 insertions, 1 deletions
diff --git a/guix-data-service/model/blocked-builds.scm b/guix-data-service/model/blocked-builds.scm index bde410f..58ec205 100644 --- a/guix-data-service/model/blocked-builds.scm +++ b/guix-data-service/model/blocked-builds.scm @@ -17,17 +17,23 @@ (define-module (guix-data-service model blocked-builds) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (squee) + #:use-module (json) #:use-module (guix-data-service database) #:use-module (guix-data-service utils) #:use-module (guix-data-service model utils) + #:use-module (guix-data-service model system) + #:use-module (guix-data-service model guix-revision) #:use-module (guix-data-service model build) #:export (handle-populating-blocked-builds-for-scheduled-builds handle-populating-blocked-builds-for-build-failures handle-removing-blocking-build-entries-for-successful-builds - backfill-blocked-builds)) + backfill-blocked-builds + + select-blocking-builds)) (define (select-blocked-derivation-output-details-set-ids-for-blocking-build conn @@ -301,3 +307,110 @@ FROM latest_build_status (simple-format #t "processed chunk...\n")))) 1000 build-ids))) + +(define* (select-blocking-builds conn revision-commit + #:key build-server-ids + system target + limit) + (define query + (string-append + " +WITH RECURSIVE all_derivations AS ( + ( + SELECT derivation_id + FROM package_derivations + INNER JOIN guix_revision_package_derivations + ON package_derivations.id + = guix_revision_package_derivations.package_derivation_id + WHERE revision_id = $1" + (if system + (simple-format + #f " + AND system_id = ~A\n" + (system->system-id conn system)) + "") + (if target + (simple-format + #f " + AND target = ~A\n" + (quote-string target)) + "") + " + ) + UNION + SELECT derivation_outputs.derivation_id + FROM all_derivations + INNER JOIN derivation_inputs + ON all_derivations.derivation_id = derivation_inputs.derivation_id + INNER JOIN derivation_outputs + ON derivation_inputs.derivation_output_id = derivation_outputs.id +), all_derivation_output_details_set_ids AS ( + SELECT derivations_by_output_details_set.* + FROM derivations_by_output_details_set + WHERE derivation_id IN ( + SELECT derivation_id FROM all_derivations + ) +), blocked_build_counts AS ( + SELECT blocking_derivation_output_details_set_id, COUNT(*) + FROM blocked_builds + WHERE blocked_derivation_output_details_set_id IN + ( + SELECT derivation_output_details_set_id + FROM all_derivation_output_details_set_ids + ) + GROUP BY 1 +) +SELECT derivations.file_name, + blocked_build_counts.count, + ( + SELECT JSON_AGG( + json_build_object( + 'build_server_id', builds.build_server_id, + 'build_server_build_id', builds.build_server_build_id, + 'status', latest_build_status.status, + 'timestamp', latest_build_status.timestamp, + 'build_for_equivalent_derivation', + builds.derivation_file_name != derivations.file_name + ) + ORDER BY latest_build_status.timestamp + ) + FROM builds + INNER JOIN latest_build_status + ON builds.id = latest_build_status.build_id + WHERE builds.derivation_output_details_set_id = + blocked_build_counts.blocking_derivation_output_details_set_id" + (if (and build-server-ids + (not (null? build-server-ids))) + (string-append + " + AND builds.build_server_id IN (" + (string-join build-server-ids ", ") + ")") + "") + " + ) AS builds +FROM blocked_build_counts +INNER JOIN all_derivation_output_details_set_ids + ON blocked_build_counts.blocking_derivation_output_details_set_id + = all_derivation_output_details_set_ids.derivation_output_details_set_id +INNER JOIN derivations + ON all_derivation_output_details_set_ids.derivation_id + = derivations.id +ORDER BY 2 DESC" + (if limit + (string-append + " +LIMIT " (number->string limit)) + ""))) + + (map + (match-lambda + ((derivation_file_name blocked_build_count builds) + `((derivation_file_name . ,derivation_file_name) + (blocked_build_count . ,blocked_build_count) + (builds + . ,(if (or (and (string? builds) (string-null? builds)) + (eq? #f builds)) + #() + (json-string->scm builds)))))) + (exec-query conn query (list (commit->revision-id conn revision-commit))))) 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 |