From e7aaf6f468e4a494e7dd9541604313883a15da66 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Mon, 25 May 2020 08:41:22 +0100
Subject: Use one thread for each type of hook event

This will allow some parallel processing of hook events, at least those of
different types.
---
 guix-build-coordinator/coordinator.scm | 73 ++++++++++++++++++----------------
 1 file changed, 38 insertions(+), 35 deletions(-)

(limited to 'guix-build-coordinator/coordinator.scm')

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)
-- 
cgit v1.2.3