From fdc2f9f617656c3f3828250c52c4aae08fafc756 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 19 Jun 2020 10:59:03 +0100
Subject: Guard against exceptions in the allocator thread

---
 guix-build-coordinator/coordinator.scm | 88 +++++++++++++++++++---------------
 1 file changed, 49 insertions(+), 39 deletions(-)

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index b2310e6..83f1e68 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -202,48 +202,58 @@
      (build-coordinator-metrics-registry build-coordinator)
      "guixbuildcoordinator_allocator_failures_total"))
 
+  (define (allocate-builds-loop)
+    (while #t
+      (with-mutex mtx
+        (let ((previous-allocation-needed-value
+               (atomic-box-swap! allocation-needed #f)))
+          (when (eq? #f previous-allocation-needed-value)
+            (wait-condition-variable v mtx)
+            (atomic-box-set! allocation-needed #f)))
+        (call-with-duration-metric
+         (build-coordinator-metrics-registry build-coordinator)
+         "guixbuildcoordinator_allocate_builds_duration_seconds"
+         (lambda ()
+           (with-exception-handler
+               (lambda (exn)
+                 (simple-format
+                  (current-error-port)
+                  "build-allocator-thread: exception: ~A\n"
+                  exn)
+                 (metric-increment failure-counter-metric)
+                 (atomic-box-set! allocation-needed #t))
+             (lambda ()
+               (with-exception-handler
+                   (lambda (exn)
+                     (with-exception-handler
+                         (lambda (exn)
+                           (simple-format
+                            (current-error-port)
+                            "exception when printing backtrace: ~A\n"
+                            exn)
+                           (backtrace)
+                           (raise-exception exn))
+                       (lambda ()
+                         (backtrace)
+                         (simple-format #t "\nfinished printing backtrace\n")
+                         (force-output)))
+                     (raise-exception exn))
+                 (lambda ()
+                   (allocate-builds build-coordinator)
+                   (metric-increment success-counter-metric))))
+             #:unwind? #t))))))
+
   (parameterize (((@@ (fibers internal) current-fiber) #f))
     (call-with-new-thread
      (lambda ()
-       (while #t
-         (with-mutex mtx
-           (let ((previous-allocation-needed-value
-                  (atomic-box-swap! allocation-needed #f)))
-             (when (eq? #f previous-allocation-needed-value)
-               (wait-condition-variable v mtx)
-               (atomic-box-set! allocation-needed #f)))
-           (call-with-duration-metric
-            (build-coordinator-metrics-registry build-coordinator)
-            "guixbuildcoordinator_allocate_builds_duration_seconds"
-            (lambda ()
-              (with-exception-handler
-                  (lambda (exn)
-                    (simple-format
-                     (current-error-port)
-                     "build-allocator-thread: exception: ~A\n"
-                     exn)
-                    (metric-increment failure-counter-metric)
-                    (atomic-box-set! allocation-needed #t))
-                (lambda ()
-                  (with-exception-handler
-                      (lambda (exn)
-                        (with-exception-handler
-                            (lambda (exn)
-                              (simple-format
-                               (current-error-port)
-                               "exception when printing backtrace: ~A\n"
-                               exn)
-                              (backtrace)
-                              (raise-exception exn))
-                          (lambda ()
-                            (backtrace)
-                            (simple-format #t "\nfinished printing backtrace\n")
-                            (force-output)))
-                        (raise-exception exn))
-                    (lambda ()
-                      (allocate-builds build-coordinator)
-                      (metric-increment success-counter-metric))))
-                #:unwind? #t))))))))
+       (with-exception-handler
+           (lambda (exn)
+             (simple-format (current-error-port)
+                            "error: allocator thread: ~A\n"
+                            exn)
+             (exit 1))
+         (lambda ()
+           (allocate-builds-loop))))))
 
   trigger-build-allocation)
 
-- 
cgit v1.2.3