Handle COMMIT erroring with busy in datastore-call-with-transaction

1 files changed, 55 insertions, 35 deletions

diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index ce9b7e5..c19468c 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -422,44 +422,64 @@ PRAGMA optimize;")))))
                                           (immediate? (not readonly?))
                                           duration-metric-name)
   (define (run-proc-within-transaction db)
-    (if (with-exception-handler
-            (lambda (exn)
-              (match (exception-args exn)
-                (('sqlite-exec 5 msg)
-                 (simple-format (current-error-port) "warning: sqlite error: ~A\n" msg)
-                 #f)
-                (_
-                 (simple-format (current-error-port)
-                                "exception starting transaction\n")
-                 (raise-exception exn))))
-          (lambda ()
-            (sqlite-exec db (if immediate?
-                                "BEGIN IMMEDIATE TRANSACTION;"
-                                "BEGIN TRANSACTION;"))
-            #t)
-          #:unwind? #t)
-
-        (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
+    (define (attempt-begin)
+      (with-exception-handler
+          (lambda (exn)
+            (match (exception-args exn)
+              (('sqlite-exec 5 msg)
+               (simple-format (current-error-port) "warning: sqlite error: ~A\n" msg)
+               #f)
+              (_
+               (simple-format (current-error-port)
+                              "exception starting transaction\n")
+               (raise-exception exn))))
+        (lambda ()
+          (sqlite-exec db (if immediate?
+                              "BEGIN IMMEDIATE TRANSACTION;"
+                              "BEGIN TRANSACTION;"))
+          #t)
+        #:unwind? #t))
+
+    (define (attempt-commit)
+      (with-exception-handler
+          (lambda (exn)
+            (match (exception-args exn)
+              (('sqlite-exec 5 msg)
+               (simple-format (current-error-port) "warning: sqlite error: ~A\n" msg)
+               #f)
+              (_
+               (simple-format (current-error-port)
+                              "exception committing transaction\n")
+               (raise-exception exn))))
+        (lambda ()
+          (sqlite-exec db "COMMIT TRANSACTION;")
+          #t)
+        #: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))))
                 (lambda ()
                   (parameterize ((%current-transaction-proc proc))
                     (proc-with-duration-timing db)))
-              (lambda vals
-                (sqlite-exec db "COMMIT TRANSACTION;")
-                (apply values vals))))
-          #:unwind? #t)
+                #:unwind? #t))
+          (lambda vals
+            (let loop ((success? (attempt-commit)))
+              (if success?
+                  (apply values vals)
+                  (loop (attempt-commit))))))
 
         ;; Database is busy, so retry
         (run-proc-within-transaction db)))