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

Add a blocking builds page

Browse source
This commit is contained in:
Christopher Baines 2022-11-10 22:53:21 +00:00
parent 1fb291be40
commit 989916b740
3 changed files with 291 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

115
guix-data-service/model/blocked-builds.scm
View file

@ -17,17 +17,23 @@
(define-module (guix-data-service model blocked-builds) (define-module (guix-data-service model blocked-builds)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (squee) #:use-module (squee)
#:use-module (json)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service utils) #:use-module (guix-data-service utils)
#:use-module (guix-data-service model 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) #:use-module (guix-data-service model build)
#:export (handle-populating-blocked-builds-for-scheduled-builds #:export (handle-populating-blocked-builds-for-scheduled-builds
handle-populating-blocked-builds-for-build-failures handle-populating-blocked-builds-for-build-failures
handle-removing-blocking-build-entries-for-successful-builds 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 (define (select-blocked-derivation-output-details-set-ids-for-blocking-build
conn conn
@ -301,3 +307,110 @@ FROM latest_build_status
(simple-format #t "processed chunk...\n")))) (simple-format #t "processed chunk...\n"))))
1000 1000
build-ids))) 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)))))

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

@ -35,6 +35,7 @@
#:use-module (guix-data-service model build) #:use-module (guix-data-service model build)
#:use-module (guix-data-service model build-server) #:use-module (guix-data-service model build-server)
#:use-module (guix-data-service model build-status) #: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 system)
#:use-module (guix-data-service model channel-news) #:use-module (guix-data-service model channel-news)
#:use-module (guix-data-service model channel-instance) #:use-module (guix-data-service model channel-instance)
@ -355,6 +356,30 @@
#:path-base path)) #:path-base path))
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) 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") (('GET "revision" commit-hash "lint-warnings")
(if (parallel-via-thread-pool-channel (if (parallel-via-thread-pool-channel
(with-thread-postgresql-connection (with-thread-postgresql-connection
@ -1458,6 +1483,64 @@
stats stats
builds)))))) 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 (define* (render-revision-lint-warnings mime-types
commit-hash commit-hash
query-parameters query-parameters

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

@ -41,6 +41,7 @@
view-revision-system-tests view-revision-system-tests
view-revision-channel-instances view-revision-channel-instances
view-revision-builds view-revision-builds
view-revision-blocking-builds
view-revision-lint-warnings view-revision-lint-warnings
unknown-revision unknown-revision
unprocessed-revision)) unprocessed-revision))
@ -2228,6 +2229,99 @@ figure {
"View build on " ,build-server-url))))) "View build on " ,build-server-url)))))
builds))))))))) 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 (define* (view-revision-lint-warnings revision-commit-hash
query-parameters query-parameters
lint-warnings lint-warnings