[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/03: Add a blocking builds page
|
From: |
Christopher Baines |
|
Subject: |
02/03: Add a blocking builds page |
|
Date: |
Fri, 11 Nov 2022 05:36:43 -0500 (EST) |
cbaines pushed a commit to branch master
in repository data-service.
commit 989916b740b88a6aedb9787d359c47740a86eb9c
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Thu Nov 10 22:53:21 2022 +0000
Add a blocking builds page
---
guix-data-service/model/blocked-builds.scm | 115 +++++++++++++++++++++++++-
guix-data-service/web/revision/controller.scm | 83 +++++++++++++++++++
guix-data-service/web/revision/html.scm | 94 +++++++++++++++++++++
3 files changed, 291 insertions(+), 1 deletion(-)
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