Use with-exception-handler in place of with-throw-handler

7 files changed, 109 insertions, 98 deletions

diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm
index 1f4e13a..cb9402e 100644
--- a/guix-data-service/database.scm
+++ b/guix-data-service/database.scm
@@ -180,8 +180,11 @@
 
 (define* (with-postgresql-connection name f #:key (statement-timeout #f))
   (let ((conn (open-postgresql-connection name statement-timeout)))
-    (with-throw-handler
-        #t
+    (with-exception-handler
+        (lambda (exn)
+          (pg-conn-finish conn)
+          (decrement-connection-gauge name)
+          (raise-exception exn))
       (lambda ()
         (call-with-values
             (lambda ()
@@ -191,10 +194,7 @@
 
             (decrement-connection-gauge name)
 
-            (apply values vals))))
-      (lambda (key . args)
-        (pg-conn-finish conn)
-        (decrement-connection-gauge name)))))
+            (apply values vals)))))))
 
 (define %postgresql-connection-parameters
   (make-parameter #f))
@@ -209,15 +209,20 @@
                                       #:key always-rollback?)
   (exec-query conn "BEGIN;")
 
-  (with-throw-handler #t
+  (with-exception-handler
+      (lambda (exn)
+        (with-exception-handler
+            (const #f)
+          (lambda ()
+            (exec-query conn "ROLLBACK;"))
+          #:unwind? #t)
+        (raise-exception exn))
     (lambda ()
       (let ((result (f conn)))
         (exec-query conn (if always-rollback?
                              "ROLLBACK;"
                              "COMMIT;"))
-        result))
-    (lambda (key . args)
-      (exec-query conn "ROLLBACK;"))))
+        result))))
 
 (define (check-test-database! conn)
   (match (exec-query conn "SELECT current_database()")
@@ -247,17 +252,22 @@
     (exec-query conn
                 "SELECT pg_advisory_lock($1)"
                 (list lock-number))
-    (with-throw-handler #t
+    (with-exception-handler
+        (lambda (exn)
+          (with-exception-handler
+              (const #f)
+            (lambda ()
+              (exec-query conn
+                          "SELECT pg_advisory_unlock($1)"
+                          (list lock-number)))
+            #:unwind? #t)
+          (raise-exception exn))
       (lambda ()
         (let ((result (f)))
           (exec-query conn
                       "SELECT pg_advisory_unlock($1)"
                       (list lock-number))
-          result))
-      (lambda (key . args)
-        (exec-query conn
-                    "SELECT pg_advisory_unlock($1)"
-                    (list lock-number))))))
+          result)))))
 
 (define (with-advisory-session-lock/log-time conn lock f)
   (simple-format #t "debug: Acquiring advisory session lock: ~A\n" lock)
diff --git a/guix-data-service/poll-git-repository.scm b/guix-data-service/poll-git-repository.scm
index bff0de0..d242139 100644
--- a/guix-data-service/poll-git-repository.scm
+++ b/guix-data-service/poll-git-repository.scm
@@ -22,6 +22,7 @@
   #:use-module (srfi srfi-71)
   #:use-module (ice-9 threads)
   #:use-module (squee)
+  #:use-module (knots)
   #:use-module (git)
   #:use-module (guix git)
   #:use-module (guix channels)
@@ -57,11 +58,12 @@
                 (simple-format #t "exception when polling git repository (~A): ~A\n"
                                git-repository-id exn))
             (lambda ()
-              (with-throw-handler #t
+              (with-exception-handler
+                  (lambda (exn)
+                    (print-backtrace-and-exception/knots exn)
+                    (raise-exception exn))
                 (lambda ()
-                  (poll-git-repository conn git-repository-id))
-                (lambda _
-                  (backtrace))))
+                  (poll-git-repository conn git-repository-id))))
             #:unwind? #t)
 
           (and=>
diff --git a/guix-data-service/substitutes.scm b/guix-data-service/substitutes.scm
index 3603521..ec9f346 100644
--- a/guix-data-service/substitutes.scm
+++ b/guix-data-service/substitutes.scm
@@ -27,6 +27,7 @@
   #:use-module (guix narinfo)
   #:use-module ((guix build syscalls)
                 #:select (set-thread-name))
+  #:use-module (knots)
   #:use-module (guix-data-service utils)
   #:use-module (guix-data-service database)
   #:use-module (guix-data-service model build)
@@ -56,17 +57,18 @@
                     (member id build-server-ids))
             (when lookup-all-derivations?
               (simple-format #t "\nQuerying ~A\n" url)
-              (with-throw-handler #t
+              (with-exception-handler
+                  (lambda (exn)
+                    (simple-format
+                     (current-error-port)
+                     "exception in query-build-server ~A ~A\n"
+                     id url)
+                    (print-backtrace-and-exception/knots exn)
+                    (raise-exception exn))
                 (lambda ()
                   (fetch-narinfo-files conn id url revision-commits
                                        #:specific-outputs
-                                       outputs))
-                (lambda (key . args)
-                  (simple-format
-                   (current-error-port)
-                   "exception in query-build-server: ~A ~A\n"
-                   key args)
-                  (backtrace)))))))
+                                       outputs)))))))
        build-servers))))
 
 (define %narinfo-max-size
@@ -169,12 +171,15 @@
      (while #t
        (with-exception-handler
            (lambda (exn)
-             (simple-format
-              (current-error-port)
-              "exception in request substitute query thread: ~A\n"
-              exn))
+             #f)
          (lambda ()
-           (with-throw-handler #t
+           (with-exception-handler
+               (lambda (exn)
+                 (simple-format
+                  (current-error-port)
+                  "exception in request substitute query thread:\n")
+                 (print-backtrace-and-exception/knots exn)
+                 (raise-exception exn))
              (lambda ()
                (with-postgresql-connection
                 "request-substitute-query-thread"
@@ -200,9 +205,7 @@
                           conn
                           (list build-server-id)
                           #f
-                          outputs))))))))
-             (lambda _
-               (backtrace))))
+                          outputs))))))))))
          #:unwind? #t))))
 
   (call-with-new-thread
diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm
index b0e38fe..94c7e52 100644
--- a/guix-data-service/web/build-server/controller.scm
+++ b/guix-data-service/web/build-server/controller.scm
@@ -22,6 +22,7 @@
   #:use-module (json)
   #:use-module (squee)
   #:use-module (fibers)
+  #:use-module (knots)
   #:use-module (knots resource-pool)
   #:use-module (prometheus)
   #:use-module (guix-data-service utils)
@@ -134,12 +135,12 @@
                   "exception in build event handler: ~A\n"
                   exn))
              (lambda ()
-               (with-throw-handler #t
+               (with-exception-handler
+                   (lambda (exn)
+                     (print-backtrace-and-exception/knots exn)
+                     (raise-exception exn))
                  (lambda ()
-                   (handler conn))
-                 (lambda _
-                   (display (backtrace) (current-error-port))
-                   (display "\n" (current-error-port)))))
+                   (handler conn))))
              #:unwind? #t))
          #:timeout #f))))
 
diff --git a/scripts/guix-data-service-process-branch-updated-email.in b/scripts/guix-data-service-process-branch-updated-email.in
index d8f6196..a0e97ae 100644
--- a/scripts/guix-data-service-process-branch-updated-email.in
+++ b/scripts/guix-data-service-process-branch-updated-email.in
@@ -27,6 +27,7 @@
              (rnrs bytevectors)
              (squee)
              (email email)
+             (knots)
              (guix-data-service database)
              (guix-data-service branch-updated-emails))
 
@@ -35,20 +36,17 @@
  (lambda (conn)
    (let* ((email-bytevector
            (get-bytevector-all (current-input-port))))
-     (catch
-       #t
+     (with-exception-handler
+         (lambda _ #f)
        (lambda ()
-         (with-throw-handler #t
+         (with-exception-handler
+             (lambda (exn)
+               (display "\nerror: while parsing email\n"
+                        (current-error-port))
+               (print-backtrace-and-exception/knots exn)
+               (raise-exception exn))
            (lambda ()
              (enqueue-job-for-email
               conn
-              (parse-email email-bytevector)))
-           (lambda (key . args)
-             (display "\nerror: while parsing email\n"
-                      (current-error-port))
-             (simple-format (current-error-port)
-                            "~A: ~A\n\n"
-                            key
-                            args)
-             (display-backtrace (make-stack #t) (current-error-port)))))
-       (lambda (key . args) #f)))))
+              (parse-email email-bytevector)))))
+       #:unwind? #t))))
diff --git a/scripts/guix-data-service-process-branch-updated-mbox.in b/scripts/guix-data-service-process-branch-updated-mbox.in
index 0a79f40..7205b7a 100644
--- a/scripts/guix-data-service-process-branch-updated-mbox.in
+++ b/scripts/guix-data-service-process-branch-updated-mbox.in
@@ -27,6 +27,7 @@
              (rnrs bytevectors)
              (squee)
              (email email)
+             (knots)
              (guix-data-service database)
              (guix-data-service model git-repository)
              (guix-data-service branch-updated-emails))
@@ -52,23 +53,21 @@ a x_git_repo_header value\n"
       (for-each
        (lambda (email-bytevector)
          (display "." (current-error-port))
-         (catch
-           #t
+         (with-exception-handler
+             (lambda (exn)
+               #f)
            (lambda ()
-             (with-throw-handler #t
+             (with-exception-handler
+                 (lambda (exn)
+                   (display "\nerror: while parsing email\n"
+                            (current-error-port))
+                   (print-backtrace-and-exception/knots exn)
+                   (raise-exception exn))
                (lambda ()
                  (enqueue-job-for-email
                   conn
-                  (parse-email email-bytevector)))
-               (lambda (key . args)
-                 (display "\nerror: while parsing email\n"
-                          (current-error-port))
-                 (simple-format (current-error-port)
-                                "~A: ~A\n\n"
-                                key
-                                args)
-                 (display-backtrace (make-stack #t) (current-error-port)))))
-           (lambda (key . args) #f)))
+                  (parse-email email-bytevector)))))
+           #:unwind? #t))
        (call-with-input-file file
          mbox->emails))
 
diff --git a/scripts/guix-data-service-process-jobs.in b/scripts/guix-data-service-process-jobs.in
index dc666be..ede8581 100644
--- a/scripts/guix-data-service-process-jobs.in
+++ b/scripts/guix-data-service-process-jobs.in
@@ -25,6 +25,7 @@
 (use-modules (srfi srfi-1)
              (srfi srfi-37)
              (ice-9 match)
+             (knots)
              (guix-data-service database)
              (guix-data-service jobs))
 
@@ -110,37 +111,34 @@
      (simple-format #t "Ready to process jobs...\n")
      (with-exception-handler
          (lambda (exn)
-           (simple-format
-            (current-error-port)
-            "exception: ~A\n"
-            exn)
            (exit 1))
        (lambda ()
-         (with-throw-handler #t
-             (lambda ()
-               (process-jobs
-                conn
-                #:max-processes (assq-ref opts 'max-processes)
-                #:latest-branch-revision-max-processes
-                (or (assq-ref opts 'latest-branch-revision-max-processes)
-                    (* 2 (assq-ref opts 'max-processes)))
-                #:skip-system-tests?
-                (assq-ref opts 'skip-system-tests)
-                #:extra-inferior-environment-variables
-                (filter-map
-                 (match-lambda
-                   (('inferior-environment-variable key val)
-                    (cons key val))
-                   (_ #f))
-                 opts)
-                #:per-job-parallelism
-                (assq-ref opts 'per-job-parallelism)
-                #:ignore-systems (assq-ref opts 'ignore-systems)
-                #:ignore-targets (assq-ref opts 'ignore-targets)
-                #:free-space-requirement
-                (assq-ref opts 'free-space-requirement)
-                #:timeout
-                (assq-ref opts 'timeout)))
-             (lambda _
-               (backtrace))))
+         (with-exception-handler
+             (lambda (exn)
+               (print-backtrace-and-exception/knots exn)
+               (raise-exception exn))
+           (lambda ()
+             (process-jobs
+              conn
+              #:max-processes (assq-ref opts 'max-processes)
+              #:latest-branch-revision-max-processes
+              (or (assq-ref opts 'latest-branch-revision-max-processes)
+                  (* 2 (assq-ref opts 'max-processes)))
+              #:skip-system-tests?
+              (assq-ref opts 'skip-system-tests)
+              #:extra-inferior-environment-variables
+              (filter-map
+               (match-lambda
+                 (('inferior-environment-variable key val)
+                  (cons key val))
+                 (_ #f))
+               opts)
+              #:per-job-parallelism
+              (assq-ref opts 'per-job-parallelism)
+              #:ignore-systems (assq-ref opts 'ignore-systems)
+              #:ignore-targets (assq-ref opts 'ignore-targets)
+              #:free-space-requirement
+              (assq-ref opts 'free-space-requirement)
+              #:timeout
+              (assq-ref opts 'timeout)))))
        #:unwind? #t))))