Fix transaction rollback handling

And print backtraces.

1 files changed, 29 insertions, 22 deletions

diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index d89ac90..74dde88 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -579,29 +579,36 @@ PRAGMA optimize;")
         #:unwind? #t))
 
     (if (attempt-begin)
-        (call-with-values
-            (lambda ()
-              (with-exception-handler
-                  (lambda (exn)
-                    (if (transaction-rollback-exception? exn)
-                        (begin
-                          (sqlite-exec db "ROLLBACK TRANSACTION;")
-                          (transaction-rollback-exception-return-value exn))
-                        (begin
-                          (simple-format (current-error-port)
-                                         "error: sqlite rolling back transaction (~A)\n"
-                                         exn)
-                          (sqlite-exec db "ROLLBACK TRANSACTION;")
-                          (raise-exception exn))))
+        (with-exception-handler
+            (lambda (exn)
+              (if (transaction-rollback-exception? exn)
+                  (begin
+                    (sqlite-exec db "ROLLBACK TRANSACTION;")
+                    (transaction-rollback-exception-return-value exn))
+                  (begin
+                    (simple-format (current-error-port)
+                                   "error: sqlite rolling back transaction (~A)\n"
+                                   exn)
+                    (sqlite-exec db "ROLLBACK TRANSACTION;")
+                    (raise-exception exn))))
+          (lambda ()
+            (call-with-values
                 (lambda ()
-                  (parameterize ((%current-transaction-proc proc))
-                    (call-with-delay-logging proc #:args (list db))))
-                #:unwind? #t))
-          (lambda vals
-            (let loop ((success? (attempt-commit)))
-              (if success?
-                  (apply values vals)
-                  (loop (attempt-commit))))))
+                  (with-throw-handler #t
+                    (lambda ()
+                      (parameterize ((%current-transaction-proc proc))
+                        (call-with-delay-logging proc #:args (list db))))
+                    (lambda (key . args)
+                      (unless (and (eq? key '%exception)
+                                   (transaction-rollback-exception?
+                                    (car args)))
+                        (backtrace)))))
+              (lambda vals
+                (let loop ((success? (attempt-commit)))
+                  (if success?
+                      (apply values vals)
+                      (loop (attempt-commit)))))))
+          #:unwind? #t)
 
         ;; Database is busy, so retry
         (run-proc-within-transaction db)))