Use one thread for each type of hook event

This will allow some parallel processing of hook events, at least those of
different types.

3 files changed, 42 insertions, 36 deletions

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 9c8638c..a143661 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -48,7 +48,7 @@
             fetch-builds
             agent-details
             trigger-build-allocation
-            start-hook-processing-thread
+            start-hook-processing-threads
 
             build-output-file-location
             build-log-file-location
@@ -244,7 +244,7 @@
 
   trigger-build-allocation)
 
-(define (start-hook-processing-thread build-coordinator)
+(define (start-hook-processing-threads build-coordinator)
   (define datastore
     (build-coordinator-datastore build-coordinator))
 
@@ -260,39 +260,42 @@
      "guixbuildcoordinator_hook_failure_total"
      #:labels '(event)))
 
-  (parameterize (((@@ (fibers internal) current-fiber) #f))
-    (call-with-new-thread
-     (lambda ()
-       (while #t
-         (match (datastore-list-unprocessed-hook-events datastore 1)
-           (() (sleep 1))
-           (((id event arguments))
-            (catch
-              #t
-              (lambda ()
-                (apply (assq-ref (build-coordinator-hooks build-coordinator)
-                                 event)
-                       build-coordinator arguments)
-                (datastore-delete-unprocessed-hook-event datastore id)
-
-                ;; If this is the hook for a successful build, once the hook
-                ;; completed successfully, delete the nar files for this build.
-                (when (eq? 'build-success event)
-                  (match arguments
-                    ((build-id)
-                     (let ((data-location (build-data-location build-id)))
-                       (when (file-exists? data-location)
-                         (delete-file-recursively data-location))))))
-                (metric-increment success-counter-metric
-                                  #:label-values
-                                  `((event . ,event))))
-              (lambda (key . args)
-                (simple-format #t "error: running ~A hook: ~A ~A\n"
-                               event key args)
-                (metric-increment failure-counter-metric
-                                  #:label-values
-                                  `((event . ,event)))
-                #f))))))))
+  (for-each
+   (match-lambda
+     ((event-name . handler)
+      (parameterize (((@@ (fibers internal) current-fiber) #f))
+        (call-with-new-thread
+         (lambda ()
+           (while #t
+             (match (datastore-list-unprocessed-hook-events datastore event-name 1)
+               (() (sleep 1))
+               (((id event arguments))
+                (catch
+                  #t
+                  (lambda ()
+                    (apply handler build-coordinator arguments)
+                    (datastore-delete-unprocessed-hook-event datastore id)
+
+                    ;; If this is the hook for a successful build, once the hook
+                    ;; completed successfully, delete the nar files for this build.
+                    (when (eq? 'build-success event)
+                      (match arguments
+                        ((build-id)
+                         (let ((data-location (build-data-location build-id)))
+                           (when (file-exists? data-location)
+                             (delete-file-recursively data-location))))))
+                    (metric-increment success-counter-metric
+                                      #:label-values
+                                      `((event . ,event))))
+                  (lambda (key . args)
+                    (simple-format #t "error: running ~A hook: ~A ~A\n"
+                                   event key args)
+                    (metric-increment failure-counter-metric
+                                      #:label-values
+                                      `((event . ,event)))
+                    #f))))))))))
+   (build-coordinator-hooks build-coordinator))
+
   #t)
 
 (define (fetch-builds build-coordinator agent count)
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 8e204f4..1b9e044 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -1087,6 +1087,7 @@ SELECT event, COUNT(*) FROM unprocessed_hook_events GROUP BY event")))
 
 (define-method (datastore-list-unprocessed-hook-events
                 (datastore <sqlite-datastore>)
+                event
                 limit)
   (call-with-worker-thread
    (slot-ref datastore 'worker-reader-thread-channel)
@@ -1097,10 +1098,12 @@ SELECT event, COUNT(*) FROM unprocessed_hook_events GROUP BY event")))
              "
 SELECT id, event, arguments
 FROM unprocessed_hook_events
+WHERE event = :event
 LIMIT :limit")))
 
        (sqlite-bind-arguments
         statement
+        #:event (symbol->string event)
         #:limit limit)
 
        (let ((events (sqlite-map
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 480dda0..a0563e8 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -489,7 +489,7 @@ processed?:      ~A
                     build-coordinator
                     substitutes-channel)))))
 
-         (start-hook-processing-thread build-coordinator)
+         (start-hook-processing-threads build-coordinator)
          (trigger-build-allocation build-coordinator)
 
          (let ((finished? (make-condition)))