From 77ffb0a0b42f0f6dc6e4015d2493c9a5d8e83aef Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 19 Jun 2020 10:47:54 +0100
Subject: Try and guard against exceptions in the hook processing threads

---
 guix-build-coordinator/coordinator.scm | 66 +++++++++++++++++++---------------
 1 file changed, 38 insertions(+), 28 deletions(-)

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 7c3201c..b2310e6 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -263,40 +263,50 @@
      "guixbuildcoordinator_hook_failure_total"
      #:labels '(event)))
 
+  (define (process-events event-name handler)
+    (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))))))
+
   (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))))))))))
+           (with-exception-handler
+               (lambda (exn)
+                 (simple-format (current-error-port)
+                                "error: ~A thread: ~A\n"
+                                event-name exn)
+                 (exit 1))
+             (lambda ()
+               (process-events event-name handler))))))))
    (build-coordinator-hooks build-coordinator))
 
   #t)
-- 
cgit v1.2.3