Add support for incrementally tracking blocked builds

This will hopefully provide a less expensive way of finding out if a scheduled
build is probably blocked by other builds failing or being canceled.

By working this out when the build events are recieved, it should be more
feasible to include information about whether builds are likely blocked or not
in various places (e.g. revision comparisons).

1 files changed, 105 insertions, 54 deletions

diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm
index 2514f53..7c2ace6 100644
--- a/guix-data-service/web/build-server/controller.scm
+++ b/guix-data-service/web/build-server/controller.scm
@@ -20,6 +20,7 @@
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:use-module (json)
+  #:use-module (fibers)
   #:use-module (guix-data-service utils)
   #:use-module (guix-data-service database)
   #:use-module (guix-data-service web render)
@@ -29,6 +30,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 nar)
   #:use-module (guix-data-service model build-server-token-seed)
   #:use-module (guix-data-service web util)
@@ -118,63 +120,112 @@
   (define build-server-id
     (string->number build-server-id-string))
 
+  (define (spawn-fiber-for-build-handler handler
+                                         statuses
+                                         data
+                                         build-ids)
+    (let ((ids
+           (delete-duplicates
+            (filter-map
+             (lambda (build-id item-data)
+               (if (and (string=? (assoc-ref item-data "type")
+                                  "build")
+                        (member (assoc-ref item-data "event")
+                                statuses))
+                   build-id
+                   #f))
+             build-ids
+             data)
+            =)))
+      (unless (null? ids)
+        (spawn-fiber
+         (lambda ()
+           (parallel-via-thread-pool-channel
+            (with-thread-postgresql-connection
+             (lambda (conn)
+               (handler conn ids)))))))))
+
   (define (handle-derivation-events conn items)
-    (unless (null? items)
-      (let ((build-ids
-             (insert-builds
-              conn
-              build-server-id
-              (map (lambda (item)
-                     (assoc-ref item "derivation"))
-                   items)
-              (map (lambda (item)
-                     (and=>
-                      (assoc-ref item "derivation_outputs")
-                      (lambda (outputs)
-                        (map
-                         (lambda (output)
-                           `((path           . ,(assoc-ref output "output"))
-                             (hash_algorithm
-                              . ,(or (assoc-ref output "hash_algorithm")
-                                     NULL))
-                             (hash           . ,(or (assoc-ref output "hash")
-                                                    NULL))
-                             (recursive      . ,(assoc-ref output "recursive"))))
-                         (vector->list outputs)))))
-                   items)
-              (map (lambda (item)
-                     (assoc-ref item "build_id"))
-                   items))))
-        (insert-build-statuses
-         conn
-         build-ids
-         (map
-          (lambda (item-data)
-            (list (assoc-ref item-data "timestamp")
-                  (assoc-ref item-data "event")))
-          items)
-         #:transaction? #f))))
+    (if (null? items)
+        '()
+        (let ((build-ids
+               (insert-builds
+                conn
+                build-server-id
+                (map (lambda (item)
+                       (assoc-ref item "derivation"))
+                     items)
+                (map (lambda (item)
+                       (and=>
+                        (assoc-ref item "derivation_outputs")
+                        (lambda (outputs)
+                          (map
+                           (lambda (output)
+                             `((path           . ,(assoc-ref output "output"))
+                               (hash_algorithm
+                                . ,(or (assoc-ref output "hash_algorithm")
+                                       NULL))
+                               (hash           . ,(or (assoc-ref output "hash")
+                                                      NULL))
+                               (recursive      . ,(assoc-ref output "recursive"))))
+                           (vector->list outputs)))))
+                     items)
+                (map (lambda (item)
+                       (assoc-ref item "build_id"))
+                     items))))
+          (insert-build-statuses
+           conn
+           build-ids
+           (map
+            (lambda (item-data)
+              (list (assoc-ref item-data "timestamp")
+                    (assoc-ref item-data "event")))
+            items)
+           #:transaction? #f)
+
+          build-ids)))
 
   (define (process-items items)
-    (parallel-via-thread-pool-channel
-     (with-thread-postgresql-connection
-      (lambda (conn)
-        (with-postgresql-transaction
-         conn
-         (lambda (conn)
-           (handle-derivation-events
-            conn
-            (filter (lambda (item)
-                      (let ((type (assoc-ref item "type")))
-                        (if type
-                            (string=? type "build")
-                            (begin
-                              (simple-format
-                               (current-error-port)
-                               "warning: unknown type for event: ~A\n"
-                               item)
-                              #f))))
-                    items))))))))
+    (define filtered-items
+      (filter (lambda (item)
+                (let ((type (assoc-ref item "type")))
+                  (if type
+                      (string=? type "build")
+                      (begin
+                        (simple-format
+                         (current-error-port)
+                         "warning: unknown type for event: ~A\n"
+                         item)
+                        #f))))
+              items))
+
+    (letpar& ((build-ids
+               (with-thread-postgresql-connection
+                (lambda (conn)
+                  (with-postgresql-transaction
+                   conn
+                   (lambda (conn)
+                     (handle-derivation-events
+                      conn
+                      filtered-items)))))))
+
+      (spawn-fiber-for-build-handler
+       handle-removing-blocking-build-entries-for-successful-builds
+       '("succeeded")
+       items
+       build-ids)
+
+      (spawn-fiber-for-build-handler
+       handle-populating-blocked-builds-for-scheduled-builds
+       '("scheduled")
+       items
+       build-ids)
+
+      (spawn-fiber-for-build-handler
+       handle-populating-blocked-builds-for-build-failures
+       '("failed" "failed-dependency" "canceled")
+       items
+       build-ids)))
 
   (if (any-invalid-query-parameters? parsed-query-parameters)
       (render-json