From 9ec4c59c2ca094138b9ee639856990b755c428d2 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sat, 23 Dec 2023 22:28:21 +0000
Subject: Rewrite process-event

Just in case this helps to avoid the "conversion to port encoding failed"
issue.
---
 guix-build-coordinator/coordinator.scm | 112 ++++++++++++++++++---------------
 1 file changed, 61 insertions(+), 51 deletions(-)

(limited to 'guix-build-coordinator')

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 2055c19..7ac0853 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -1085,57 +1085,67 @@
      #:labels '(event)))
 
   (define (process-event id event arguments handler)
-    (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 ()
-          (log-msg (build-coordinator-logger build-coordinator)
-                   'DEBUG
-                   "running " event " handler (id: " id
-                   ", arguments: " arguments ")")
-          (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 " (" id ") 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)))))
+    (log-msg (build-coordinator-logger build-coordinator)
+             'DEBUG
+             "running " event " handler (id: " id
+             ", arguments: " arguments ")")
+    (and
+     (with-exception-handler
+         (lambda (exn)
+           (log-msg (build-coordinator-logger build-coordinator)
+                    'ERROR
+                    "error running " event " (" id ") hook: "
+                    exn)
+           (metric-increment failure-counter-metric
+                             #:label-values
+                             `((event . ,event)))
+           (sleep 10)
+           #f)
+       (lambda ()
+         (call-with-duration-metric
+          (build-coordinator-metrics-registry build-coordinator)
+          "hook_duration_seconds"
+          (lambda ()
+            (with-throw-handler #t
+              (lambda ()
+                (start-stack
+                 'hook
+                 (apply handler build-coordinator arguments)))
+              (lambda (key . args)
+                (log-msg (build-coordinator-logger build-coordinator)
+                         'ERROR
+                         "error running " event " (" id ") hook: "
+                         key " " args)
+                (let* ((stack (make-stack #t 3))
+                       (backtrace
+                        (call-with-output-string
+                          (lambda (port)
+                            (display-backtrace stack port)
+                            (newline port)))))
+                  (display
+                   backtrace
+                   (current-output-port))))))
+          #:labels '(event)
+          #:label-values `((event . ,event)))
+         #t)
+       #:unwind? #t)
+     (begin
+       (log-msg (build-coordinator-logger build-coordinator)
+                'DEBUG
+                event " (" id ") 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))
-- 
cgit v1.2.3