Don't use with-exception-handler with (backtrace)

With with-exception-handler being called with #:unwind? #f (implicitly). This
breaks Guile internals used by (backtrace) [1], meaning you get a different
exception/backtrace when Guile itself breaks.

This should avoid the "string->number: Wrong type argument in position
1 (expecting string): #f" exception I've been haunted by for the last year.

1: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=46009

5 files changed, 46 insertions, 71 deletions

diff --git a/guix-build-coordinator/agent-messaging/http/server.scm b/guix-build-coordinator/agent-messaging/http/server.scm
index 8a5e990..338bab6 100644
--- a/guix-build-coordinator/agent-messaging/http/server.scm
+++ b/guix-build-coordinator/agent-messaging/http/server.scm
@@ -427,26 +427,21 @@ port. Also, the port used can be changed by passing the --port option.\n"
             (render-json
              `((error . ,(agent-error-details exn)))
              #:code 400)
-            (begin
-              (match method-and-path-components
-                ((method path-components ...)
-                 (simple-format
-                  (current-error-port)
-                  "error: when processing: /~A ~A\n  ~A"
-                  method (string-join path-components "/")
-                  exn)))
-              (render-json
-               `((error . ,(simple-format #f "~A" exn)))
-               #:code 500))))
+            (render-json
+             `((error . ,(simple-format #f "~A" exn)))
+             #:code 500)))
     (lambda ()
-      (with-exception-handler
-          (lambda (exn)
-            (catch #t
-              (lambda ()
-                (backtrace))
-              (lambda (key . args)
-                (simple-format (current-error-port)
-                               "error: guile crashed printing backtrace\n")))
-            (raise-exception exn))
-        controller-thunk))
+      (with-throw-handler #t
+        controller-thunk
+        (lambda (key . args)
+          (unless (and (eq? '%exception key)
+                       (agent-error? (car args)))
+            (match method-and-path-components
+              ((method path-components ...)
+               (simple-format
+                (current-error-port)
+                "error: when processing: /~A ~A\n  ~A ~A"
+                method (string-join path-components "/")
+                key args)))
+            (backtrace)))))
     #:unwind? #t))
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 580773b..4fdfade 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -380,27 +380,21 @@
 
   (with-exception-handler
       (lambda (exn)
-        (match method-and-path-components
-          ((method path-components ...)
-           (simple-format
-            (current-error-port)
-            "error: when processing client request: /~A ~A\n  ~A"
-            method (string-join path-components "/")
-            exn)))
         (render-json
-         `((error . ,(simple-format #f "~A" exn)))
+         `((error . 500))
          #:code 500))
     (lambda ()
-      (with-exception-handler
-          (lambda (exn)
-            (catch #t
-              (lambda ()
-                (backtrace))
-              (lambda (key . args)
-                (simple-format (current-error-port)
-                               "error: guile crashed printing backtrace\n")))
-            (raise-exception exn))
-        controller-thunk))
+      (with-throw-handler #t
+        controller-thunk
+        (lambda (key . args)
+          (match method-and-path-components
+            ((method path-components ...)
+             (simple-format
+              (current-error-port)
+              "error: when processing client request: /~A ~A\n  ~A ~A\n"
+              method (string-join path-components "/")
+              key args)))
+          (backtrace))))
     #:unwind? #t))
 
 (define* (render-json json #:key (extra-headers '())
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index c6a71f5..f874c48 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -467,27 +467,15 @@
                  (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)
-                           (raise-exception exn))
-                       (lambda ()
-                         (backtrace)
-                         (simple-format #t "\nfinished printing backtrace\n")
-                         (force-output))
-                       #:unwind? #t)
-                     (raise-exception exn))
+               (with-throw-handler #t
                  (lambda ()
                    (with-timeout (* 1000 60 10) ; 10 minutes
                      (raise-exception
                       (make-exception-with-message "timeout allocating builds"))
                      (allocate-builds build-coordinator))
-                   (metric-increment success-counter-metric))))
+                   (metric-increment success-counter-metric))
+                 (lambda (key . args)
+                   (backtrace))))
              #:unwind? #t))
          #:buckets ((@@ (prometheus) exponential-histogram-buckets) ; TODO
                     #:start 1
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index fdcefb6..4d98575 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -646,15 +646,14 @@ References: ~a~%"
                ;; Add the job back to the queue so that it's tried again
                (apply process-job job-args))
            (lambda ()
-             (with-exception-handler
-                 (lambda (exn)
-                   (simple-format (current-error-port)
-                                  "exception when handling job: ~A\n"
-                                  exn)
-                   (backtrace)
-                   (raise-exception exn))
+             (with-throw-handler #t
                (lambda ()
-                 (apply proc job-args))))
+                 (apply proc job-args))
+               (lambda (key . args)
+                 (simple-format (current-error-port)
+                                "exception when handling job: ~A ~A\n"
+                                key args)
+                 (backtrace))))
            #:unwind? #t)
          (with-mutex queue-mutex
            (hash-set! running-job-args
diff --git a/guix-build-coordinator/utils/fibers.scm b/guix-build-coordinator/utils/fibers.scm
index 2dfb087..f6dba70 100644
--- a/guix-build-coordinator/utils/fibers.scm
+++ b/guix-build-coordinator/utils/fibers.scm
@@ -41,18 +41,17 @@ arguments of the worker thread procedure."
                             (lambda (exn)
                               (cons 'worker-thread-error exn))
                           (lambda ()
-                            (with-exception-handler
-                                (lambda (exn)
-                                  (simple-format
-                                   (current-error-port)
-                                   "worker-thread: exception: ~A\n" exn)
-                                  (backtrace)
-                                  (raise-exception exn))
+                            (with-throw-handler #t
                               (lambda ()
                                 (call-with-values
                                     (lambda ()
                                       (apply proc args))
-                                  (lambda vals vals)))))
+                                  (lambda vals vals)))
+                              (lambda (key . args)
+                                (simple-format
+                                 (current-error-port)
+                                 "worker-thread: exception: ~A ~A\n" key args)
+                                (backtrace))))
                           #:unwind? #t)))))
                   (loop)))))))
        (iota parallelism))