Try to improve hook exception handling

This should lead to more concise backtraces at least although it may
reintroduce the problem where backtraces lead to excessive memory usage.

1 files changed, 48 insertions, 49 deletions

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 54380f3..b022c76 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -31,6 +31,7 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 format)
   #:use-module (ice-9 atomic)
+  #:use-module (ice-9 control)
   #:use-module (ice-9 threads)
   #:use-module (ice-9 exceptions)
   #:use-module (web uri)
@@ -1001,55 +1002,53 @@
      #:labels '(event)))
 
   (define (process-event id event arguments handler)
-    (with-exception-handler
-        (lambda (exn)
-          (log-msg
-           (build-coordinator-logger build-coordinator)
-           'ERROR
-           "process-event " event " (" id ") exception: " exn)
-          (metric-increment failure-counter-metric
-                            #:label-values
-                            `((event . ,event)))
-          (core-guile-sleep 10))
-      (lambda ()
-        (log-msg (build-coordinator-logger build-coordinator)
-                 'DEBUG
-                 "processing " event " event: " arguments)
-        (with-throw-handler #t
-          (lambda ()
-            (call-with-duration-metric
-             (build-coordinator-metrics-registry build-coordinator)
-             "hook_duration_seconds"
-             (lambda ()
-               (apply handler build-coordinator arguments))
-             #:labels '(event)
-             #:label-values `((event . ,event))))
-          (lambda args
-            (apply log-msg (build-coordinator-logger build-coordinator)
-                   'ERROR
-                   "error running " event " (" id ") hook: "
-                   args)
-            ;; TODO: This seems to be causing the threads to get stuck and use
-            ;; excessive amounts of memory :(
-            ;; (backtrace)
-            ))
-        (log-msg (build-coordinator-logger build-coordinator)
-                 'DEBUG
-                 event " handler finished")
-        (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))))
-      #:unwind? #t))
+    (let/ec cancel
+      (with-exception-handler
+          (lambda (exn)
+            (log-msg (build-coordinator-logger build-coordinator)
+                     'ERROR
+                     "error running " event " (" id ") hook: "
+                     exn)
+            (let* ((stack (make-stack #t 3))
+                   (backtrace
+                    (call-with-output-string
+                      (lambda (port)
+                        (display-backtrace stack port)
+                        (newline port)))))
+              (display
+               backtrace
+               (current-output-port)))
+            (metric-increment failure-counter-metric
+                              #:label-values
+                              `((event . ,event)))
+            (core-guile-sleep 10)
+            (cancel #f))
+        (lambda ()
+          (call-with-duration-metric
+           (build-coordinator-metrics-registry build-coordinator)
+           "hook_duration_seconds"
+           (lambda ()
+             (start-stack
+              'hook
+              (apply handler build-coordinator arguments)))
+           #:labels '(event)
+           #:label-values `((event . ,event)))))
+      (log-msg (build-coordinator-logger build-coordinator)
+               'DEBUG
+               event " handler finished")
+      (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)))))
 
   (define (single-thread-process-events event-name handler)
     (let ((mtx     (make-mutex))