Use knots for printing exception and backtraces

7 files changed, 102 insertions, 106 deletions

diff --git a/guix-qa-frontpage/branch.scm b/guix-qa-frontpage/branch.scm
index 6276476..581c98b 100644
--- a/guix-qa-frontpage/branch.scm
+++ b/guix-qa-frontpage/branch.scm
@@ -32,6 +32,7 @@
   #:use-module ((guix build syscalls)
                 #:select (set-thread-name))
   #:use-module (fibers)
+  #:use-module (knots)
   #:use-module (knots non-blocking)
   #:use-module (guix-qa-frontpage utils)
   #:use-module (guix-qa-frontpage mumi)
@@ -83,10 +84,13 @@
 
   (with-exception-handler
       (lambda (exn)
-        (simple-format #t "exception listing non master branches: ~A\n" exn)
         `((exception . ,(simple-format #f "~A" exn))))
     (lambda ()
-      (with-throw-handler #t
+      (with-exception-handler
+          (lambda (exn)
+            (simple-format #t "exception listing non master branches\n")
+            (print-backtrace-and-exception/knots exn)
+            (raise-exception exn))
         (lambda ()
           (let* ((merge-issues
                   (merge-issues-by-branch))
@@ -186,10 +190,7 @@
                                 b-blocked-by)))
                           (if (null? ordering-indexes)
                               b-initial-ordering-index
-                              (apply max ordering-indexes)))))))))))
-        (lambda args
-          (display (backtrace) (current-error-port))
-          (newline (current-error-port)))))
+                              (apply max ordering-indexes)))))))))))))
     #:unwind? #t))
 
 (define (branch-derivation-changes-data revisions system)
@@ -428,15 +429,16 @@
 
            (with-exception-handler
                (lambda (exn)
-                 (simple-format
-                  (current-error-port)
-                  "failed fetching derivation changes for branch ~A: ~A\n"
-                  branch-name
-                  exn)
-
                  #f)
              (lambda ()
-               (with-throw-handler #t
+               (with-exception-handler
+                   (lambda (exn)
+                     (simple-format
+                      (current-error-port)
+                      "failed fetching derivation changes for branch ~A\n"
+                      branch-name)
+                     (print-backtrace-and-exception/knots exn)
+                     (raise-exception exn))
                  (lambda ()
                    (let ((revisions
                           derivation-change-counts
@@ -456,9 +458,7 @@
                                  (assq-ref substitute-availability 'exception))
                        (update-branch-substitute-availability-metrics
                         branch-name
-                        substitute-availability))))
-                 (lambda _
-                   (backtrace))))
+                        substitute-availability))))))
              #:unwind? #t))
          #t)
        branches))
@@ -481,18 +481,17 @@
      (while #t
        (let ((start-time (current-time)))
          (with-exception-handler
-             (lambda (exn)
-               (simple-format
-                (current-error-port)
-                "exception in branch data refresh thread: ~A\n"
-                exn))
+             (lambda _ #f)
            (lambda ()
              (with-time-logging "refreshing branch data"
-               (with-throw-handler #t
-                 refresh-data
-                 (lambda args
-                   (display (backtrace) (current-error-port))
-                   (newline (current-error-port))))))
+               (with-exception-handler
+                   (lambda (exn)
+                     (simple-format
+                      (current-error-port)
+                      "exception in branch data refresh thread\n")
+                     (print-backtrace-and-exception/knots exn)
+                     (raise-exception exn))
+                 refresh-data)))
            #:unwind? #t)
 
          (let ((time-taken
diff --git a/guix-qa-frontpage/database.scm b/guix-qa-frontpage/database.scm
index 06ce3bd..34c0ce6 100644
--- a/guix-qa-frontpage/database.scm
+++ b/guix-qa-frontpage/database.scm
@@ -28,6 +28,7 @@
   #:use-module (sqlite3)
   #:use-module (fibers)
   #:use-module (prometheus)
+  #:use-module (knots)
   #:use-module (knots queue)
   #:use-module (knots thread-pool)
   #:use-module (guix narinfo)
@@ -475,14 +476,14 @@ SELECT data, timestamp FROM cache WHERE key = :key"
               (call-with-thread
                (database-reader-thread-set database)
                (lambda (db)
-                 (with-throw-handler #t
+                 (with-exception-handler
+                     (lambda (exn)
+                       (print-backtrace-and-exception/knots exn)
+                       (raise-exception exn))
                    (lambda ()
                      (call-with-delay-logging
                       proc
-                      #:args args))
-                   (lambda args
-                     (display (backtrace) (current-error-port))
-                     (newline (current-error-port)))))))
+                      #:args args))))))
           (lambda vals
             (when (if (procedure? store-computed-value?)
                       (apply store-computed-value? vals)
diff --git a/guix-qa-frontpage/issue.scm b/guix-qa-frontpage/issue.scm
index beed41f..6a031e1 100644
--- a/guix-qa-frontpage/issue.scm
+++ b/guix-qa-frontpage/issue.scm
@@ -27,6 +27,7 @@
   #:use-module ((guix build syscalls)
                 #:select (set-thread-name))
   #:use-module (fibers)
+  #:use-module (knots)
   #:use-module (knots non-blocking)
   #:use-module (knots parallelism)
   #:use-module (guix-qa-frontpage utils)
@@ -411,23 +412,22 @@
      (while #t
        (let ((start-time (current-time)))
          (with-exception-handler
-             (lambda (exn)
-               (simple-format
-                (current-error-port)
-                "exception in data refresh thread: ~A\n"
-                exn))
+             (lambda _ #f)
            (lambda ()
              (with-time-logging "refreshing data"
-               (with-throw-handler #t
+               (with-exception-handler
+                   (lambda (exn)
+                     (simple-format
+                      (current-error-port)
+                      "exception in data refresh thread\n")
+                     (print-backtrace-and-exception/knots exn)
+                     (raise-exception exn))
                  (lambda ()
                    (call-with-duration-metric
                     metrics-registry
                     "refresh_patch_branches_data_duration_seconds"
                     refresh-data
-                    #:buckets (list 30 60 120 240 480 960 1920 3840 (inf))))
-                 (lambda args
-                   (display (backtrace) (current-error-port))
-                   (newline (current-error-port))))))
+                    #:buckets (list 30 60 120 240 480 960 1920 3840 (inf)))))))
            #:unwind? #t)
 
          (let ((time-taken
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
index f461292..3546fcf 100644
--- a/guix-qa-frontpage/manage-builds.scm
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -7,6 +7,7 @@
   #:use-module (ice-9 threads)
   #:use-module (ice-9 exceptions)
   #:use-module (fibers)
+  #:use-module (knots)
   #:use-module (knots parallelism)
   #:use-module (knots non-blocking)
   #:use-module (knots timeout)
@@ -218,13 +219,15 @@
    (lambda ()
      (while #t
        (with-exception-handler
-           (lambda (exn)
-             (simple-format
-              (current-error-port)
-              "exception in submit patch builds fiber: ~A\n"
-              exn))
+           (lambda _ #f)
          (lambda ()
-           (with-throw-handler #t
+           (with-exception-handler
+               (lambda (exn)
+                 (simple-format
+                  (current-error-port)
+                  "exception in submit patch builds fiber\n")
+                 (print-backtrace-and-exception/knots exn)
+                 (raise-exception exn))
              (lambda ()
                (let* ((substitute-availability
                        systems-with-low-substitute-availability
@@ -242,10 +245,7 @@
                       "submit_patch_builds_duration_seconds"
                       submit-builds
                       #:buckets (list 30 60 120 240 480 960 1920 3840 (inf)))
-                     (sleep 900))))
-             (lambda args
-               (display (backtrace) (current-error-port))
-               (newline (current-error-port)))))
+                     (sleep 900))))))
          #:unwind? #t)
        (simple-format #t "finished submitting patch builds\n")
 
@@ -478,22 +478,21 @@
    (lambda ()
      (while #t
        (with-exception-handler
-           (lambda (exn)
-             (simple-format
-              (current-error-port)
-              "exception in submit branch builds fiber: ~A\n"
-              exn))
+           (lambda _ #f)
          (lambda ()
-           (with-throw-handler #t
+           (with-exception-handler
+               (lambda (exn)
+                 (simple-format
+                  (current-error-port)
+                  "exception in submit branch builds fiber\n")
+                 (print-backtrace-and-exception/knots exn)
+                 (raise-exception exn))
              (lambda ()
                (call-with-duration-metric
                 metrics-registry
                 "submit_branch_builds_duration_seconds"
                 submit-branch-builds
-                #:buckets (list 30 60 120 240 480 960 1920 3840 (inf))))
-             (lambda args
-               (display (backtrace) (current-error-port))
-               (newline (current-error-port)))))
+                #:buckets (list 30 60 120 240 480 960 1920 3840 (inf))))))
          #:unwind? #t)
 
        (sleep 3600)))))
@@ -914,22 +913,21 @@
 
      (while #t
        (with-exception-handler
-           (lambda (exn)
-             (simple-format
-              (current-error-port)
-              "exception in submit system test builds thread: ~A\n"
-              exn))
+           (lambda _ #f)
          (lambda ()
-           (with-throw-handler #t
+           (with-exception-handler
+               (lambda (exn)
+                 (simple-format
+                  (current-error-port)
+                  "exception in submit system test builds thread\n")
+                 (print-backtrace-and-exception/knots exn)
+                 (raise-exception exn))
              (lambda ()
                (call-with-duration-metric
                 metrics-registry
                 "submit_master_branch_system_tests_duration_seconds"
                 submit-builds
-                #:buckets (list 30 60 120 240 480 960 1920 3840 (inf))))
-             (lambda args
-               (display (backtrace) (current-error-port))
-               (newline (current-error-port)))))
+                #:buckets (list 30 60 120 240 480 960 1920 3840 (inf))))))
          #:unwind? #t)
 
        (sleep 3600)))))
diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm
index 7cb9cee..3aec254 100644
--- a/guix-qa-frontpage/manage-patch-branches.scm
+++ b/guix-qa-frontpage/manage-patch-branches.scm
@@ -19,6 +19,7 @@
   #:use-module (guix build utils)
   #:use-module ((guix build download) #:select (http-fetch))
   #:use-module ((guix build utils) #:select (with-directory-excursion))
+  #:use-module (knots)
   #:use-module (knots thread-pool)
   #:use-module (guix-qa-frontpage mumi)
   #:use-module (guix-qa-frontpage database)
@@ -274,12 +275,6 @@
                (lambda (exn)
                  (simple-format
                   (current-error-port)
-                  "exception when creating branch for ~A: ~A\n"
-                  issue-number
-                  exn)
-
-                 (simple-format
-                  (current-error-port)
                   "deleting tag and branch for issue\n")
                  (system* "git" "push" "--delete" "patches"
                           (simple-format #f "base-for-issue-~A" issue-number))
@@ -288,11 +283,15 @@
 
                  (raise-exception exn))
              (lambda ()
-               (with-throw-handler #t
-                 apply-patches
-                 (lambda args
-                   (display (backtrace) (current-error-port))
-                   (newline (current-error-port)))))
+               (with-exception-handler
+                   (lambda (exn)
+                     (simple-format
+                      (current-error-port)
+                      "exception when creating branch for ~A\n"
+                      issue-number)
+                     (print-backtrace-and-exception/knots exn)
+                     (raise-exception exn))
+                 apply-patches))
              #:unwind? #t))
          #:remove-after? #t))))
 
@@ -515,22 +514,21 @@
      (while #t
        (with-exception-handler
            (lambda (exn)
-             (simple-format
-              (current-error-port)
-              "exception in manage patch branches thread: ~A\n"
-              exn)
              (unless (thread-pool-timeout-error? exn)
                (sleep 240)))
          (lambda ()
-           (with-throw-handler #t
+           (with-exception-handler
+               (lambda (exn)
+                 (simple-format
+                  (current-error-port)
+                  "exception in manage patch branches thread\n")
+                 (print-backtrace-and-exception/knots exn)
+                 (raise-exception exn))
              (lambda ()
                (call-with-duration-metric
                 metrics-registry
                 "manage_patch_branches_duration_seconds"
                 perform-pass
-                #:buckets (list 30 60 120 240 480 960 1920 3840 (inf))))
-             (lambda args
-               (display (backtrace) (current-error-port))
-               (newline (current-error-port))))
+                #:buckets (list 30 60 120 240 480 960 1920 3840 (inf)))))
            (sleep 3600))
          #:unwind? #t)))))
diff --git a/guix-qa-frontpage/reproducible-builds.scm b/guix-qa-frontpage/reproducible-builds.scm
index 4211627..20ace13 100644
--- a/guix-qa-frontpage/reproducible-builds.scm
+++ b/guix-qa-frontpage/reproducible-builds.scm
@@ -3,6 +3,7 @@
   #:use-module (ice-9 threads)
   #:use-module (zlib)
   #:use-module (json)
+  #:use-module (knots)
   #:use-module (guix-qa-frontpage guix-data-service)
   #:export (start-generate-reproducible.json-thread))
 
@@ -64,17 +65,16 @@
    (lambda ()
      (while #t
        (with-exception-handler
-           (lambda (exn)
-             (simple-format
-              (current-error-port)
-              "exception in generate reproducible.json fiber: ~A\n"
-              exn))
+           (lambda _ #f)
          (lambda ()
-           (with-throw-handler #t
-             generate
-             (lambda args
-               (display (backtrace) (current-error-port))
-               (newline (current-error-port)))))
+           (with-exception-handler
+               (lambda (exn)
+                 (simple-format
+                  (current-error-port)
+                  "exception in generate reproducible.json fiber\n")
+                 (print-backtrace-and-exception/knots exn)
+                 (raise-exception exn))
+             generate))
          #:unwind? #t)
        (simple-format #t "finished generating reproducible.json.gz\n")
 
diff --git a/guix-qa-frontpage/utils.scm b/guix-qa-frontpage/utils.scm
index 63b741c..71b0131 100644
--- a/guix-qa-frontpage/utils.scm
+++ b/guix-qa-frontpage/utils.scm
@@ -38,14 +38,14 @@
               (lambda (exn)
                 (put-message channel `(exception ,exn)))
             (lambda ()
-              (with-throw-handler #t
+              (with-exception-handler
+                  (lambda (exn)
+                    (print-backtrace-and-exception/knots exn)
+                    (raise-exception exn))
                 (lambda ()
                   (call-with-values thunk
                     (lambda values
-                      (put-message channel `(values ,@values)))))
-                (lambda args
-                  (display (backtrace) (current-error-port))
-                  (newline (current-error-port)))))
+                      (put-message channel `(values ,@values)))))))
             #:unwind? #t)))))
     (match (get-message channel)
       (('values . results)