Support showing blocking builds

This is useful to find builds that have failed, and in failing blocked other
builds from being attempted.

4 files changed, 81 insertions, 0 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 6f5e38c..86f75d8 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -41,6 +41,7 @@
             request-build-details
             request-output-details
             request-agents-list
+            request-failed-builds-with-blocking-count-list
             send-create-agent-request
             send-create-agent-password-request))
 
@@ -132,6 +133,11 @@
              `(,@build-details
                (derivation-inputs . ,(list->vector derivation-inputs))
                (setup-failures    . ,(list->vector setup-failures))))))))
+      (('GET "builds" "blocking")
+       (render-json
+        `((builds
+           . ,(list->vector
+               (datastore-list-failed-builds-with-blocking-count datastore))))))
       (('GET "output" output-components ...)
        (let* ((output (string-append
                        "/" (string-join output-components "/")))
@@ -300,6 +306,11 @@
                 'GET
                 (string-append "/agents")))
 
+(define (request-failed-builds-with-blocking-count-list coordinator-uri)
+  (send-request coordinator-uri
+                'GET
+                (string-append "/builds/blocking")))
+
 (define* (send-create-agent-request coordinator-uri
                                     #:key
                                     requested-uuid
diff --git a/guix-build-coordinator/datastore.scm b/guix-build-coordinator/datastore.scm
index 7f49583..1a890d4 100644
--- a/guix-build-coordinator/datastore.scm
+++ b/guix-build-coordinator/datastore.scm
@@ -21,6 +21,7 @@
 (re-export datastore-fetch-setup-failures)
 (re-export datastore-list-build-outputs)
 (re-export datastore-list-related-derivations-with-no-build-for-outputs)
+(re-export datastore-list-failed-builds-with-blocking-count)
 (re-export datastore-list-builds-for-derivation-recursive-inputs)
 (re-export datastore-store-setup-failure)
 (re-export datastore-store-setup-failure/missing-inputs)
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 4f43c5b..5c1fddc 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -13,6 +13,7 @@
             datastore-update
             datastore-store-derivation
             datastore-list-related-derivations-with-no-build-for-outputs
+            datastore-list-failed-builds-with-blocking-count
             datastore-list-builds-for-derivation-recursive-inputs
             datastore-store-build
             datastore-count-builds
@@ -291,6 +292,60 @@ WHERE related_derivations.name != :derivation
 
          result)))))
 
+(define-method (datastore-list-failed-builds-with-blocking-count
+                (datastore <sqlite-datastore>))
+  (call-with-worker-thread
+   (slot-ref datastore 'worker-reader-thread-channel)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT
+  builds.uuid,
+  builds.derivation_name,
+  (
+    SELECT COUNT(DISTINCT blocked_builds.uuid)
+    FROM derivation_outputs
+    INNER JOIN derivation_outputs AS matching_derivation_outputs
+      ON derivation_outputs.output = matching_derivation_outputs.output
+    INNER JOIN derivation_inputs
+     ON matching_derivation_outputs.id =
+        derivation_inputs.derivation_output_id
+    INNER JOIN builds AS blocked_builds
+      ON derivation_inputs.derivation_name = blocked_builds.derivation_name
+     AND blocked_builds.processed = 0
+    WHERE derivation_outputs.derivation_name = builds.derivation_name
+  )
+FROM builds
+INNER JOIN build_results
+  ON builds.uuid = build_results.build_id
+WHERE builds.processed = 1
+  AND build_results.result = 'failure'
+  AND NOT EXISTS (
+    SELECT 1
+    FROM derivation_outputs
+    INNER JOIN derivation_outputs AS other_build_derivation_outputs
+      ON derivation_outputs.output = other_build_derivation_outputs.output
+    INNER JOIN builds AS other_builds
+      ON other_build_derivation_outputs.derivation_name = other_builds.derivation_name
+    INNER JOIN build_results AS other_build_results
+      ON other_builds.uuid = other_build_results.build_id
+    WHERE derivation_outputs.derivation_name = builds.derivation_name
+  AND other_build_results.result = 'success'
+) ORDER BY 3 DESC")))
+
+       (let ((result (sqlite-map
+                      (match-lambda
+                        (#(uuid derivation-name blocked-count)
+                         `((uuid            . ,uuid)
+                           (derivation_name . ,derivation-name)
+                           (blocked_count   . ,blocked-count))))
+                      statement)))
+         (sqlite-reset statement)
+
+         result)))))
+
 (define-method (datastore-list-builds-for-derivation-recursive-inputs
                 (datastore <sqlite-datastore>)
                 derivation)
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 77ab46e..480dda0 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -312,6 +312,20 @@ processed?:      ~A
                          build-id)))
           (display-build `(("uuid" . ,build-id)
                            ,@response)))))))
+  (("build" "show-blocking" rest ...)
+   (let ((opts (parse-options %base-options
+                              %base-option-defaults
+                              rest)))
+     (let ((response (request-failed-builds-with-blocking-count-list
+                      (assq-ref opts 'coordinator))))
+       (for-each
+        (lambda (build)
+          (format
+           #t "~a (~5d): ~a~%"
+           (assoc-ref build "uuid")
+           (assoc-ref build "blocked_count")
+           (assoc-ref build "derivation_name")))
+        (vector->list (assoc-ref response "builds"))))))
   (("build" rest ...)
    (let ((opts (parse-options (append %build-options
                                       %base-options)