From e2650b58fc624c93b1c9e1a558d8c08642c02ff9 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 19 Apr 2024 16:45:31 +0100
Subject: Improve database-call-with-transaction

By copying from the build coordinator.
---
 nar-herder/database.scm | 86 +++++++++++++++++++++++++++++++++----------------
 1 file changed, 59 insertions(+), 27 deletions(-)

diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index 4fa145f..426def6 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -472,36 +472,68 @@ PRAGMA optimize;")))
                                          readonly?
                                          (immediate? (not readonly?)))
   (define (run-proc-within-transaction db)
-    (with-exception-handler
-        (lambda (exn)
-          (match (exception-args exn)
-            (('sqlite-exec 5 msg)
-             (simple-format (current-error-port) "warning: sqlite error: ~A\n" msg)
-             (run-proc-within-transaction db))
-            (_
-             (simple-format (current-error-port)
-                            "exception starting transaction\n")
-             (raise-exception exn))))
-      (lambda ()
-        (sqlite-exec db (if immediate?
-                            "BEGIN IMMEDIATE TRANSACTION;"
-                            "BEGIN TRANSACTION;"))
-        (with-exception-handler
-            (lambda (exn)
-              (simple-format (current-error-port)
-                             "error: sqlite rolling back transaction\n")
-              (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: issue starting transaction (code: 5, proc: ~A): ~A\n"
+                proc msg)
+               #f)
+              (_
+               (simple-format (current-error-port)
+                              "exception starting transaction: ~A\n" exn)
+               (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: attempt commit (code: 5, proc: ~A): ~A\n"
+                proc msg)
+               #f)
+              (_
+               (simple-format (current-error-port)
+                              "exception committing transaction: ~A\n" exn)
+               (raise-exception exn))))
+        (lambda ()
+          (sqlite-exec db "COMMIT TRANSACTION;")
+          #t)
+        #:unwind? #t))
+
+    (if (attempt-begin)
+        (call-with-values
+            (lambda ()
+              (with-exception-handler
+                  (lambda (exn)
+                    (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))
+                #: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)))
 
   (define (proc-with-duration-timing db)
     (let ((start-time (get-internal-real-time)))
-- 
cgit v1.2.3