Handle busy databases in database-call-with-transaction

1 files changed, 56 insertions, 38 deletions

diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index 5323b6d..1417c24 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -331,26 +331,60 @@ PRAGMA optimize;")))
 
 (define* (database-call-with-transaction database proc
                                          #:key
-                                         readonly?)
+                                         readonly?
+                                         (immediate? (not readonly?)))
   (define (run-proc-within-transaction db)
-    (if (%current-transaction-proc)
-        (proc db)                       ; already in transaction
-        (begin
-          (sqlite-exec db "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
-                  (lambda ()
-                    (parameterize ((%current-transaction-proc proc))
-                      (proc db)))
-                (lambda vals
-                  (sqlite-exec db "COMMIT TRANSACTION;")
-                  (apply values vals))))))))
+    (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
+                (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))
+
+  (define (proc-with-duration-timing db)
+    (let ((start-time (get-internal-real-time)))
+      (call-with-values
+          (lambda ()
+            (proc db))
+        (lambda vals
+          (let ((duration-seconds
+                 (/ (- (get-internal-real-time) start-time)
+                    internal-time-units-per-second)))
+            (when (and (not readonly?)
+                       (> duration-seconds 2))
+              (display
+               (format
+                #f
+                "warning: ~a:\n  took ~4f seconds in transaction\n"
+                proc
+                duration-seconds)
+               (current-error-port)))
+
+            (cons duration-seconds vals))))))
 
   (match (call-with-worker-thread
           ((if readonly?
@@ -358,25 +392,9 @@ PRAGMA optimize;")))
                database-writer-thread-channel)
            database)
           (lambda (db)
-            (let ((start-time (get-internal-real-time)))
-              (call-with-values
-                  (lambda ()
-                    (run-proc-within-transaction db))
-                (lambda vals
-                  (let ((duration-seconds
-                         (/ (- (get-internal-real-time) start-time)
-                            internal-time-units-per-second)))
-                    (when (and (not readonly?)
-                               (> duration-seconds 2))
-                      (display
-                       (format
-                        #f
-                        "warning: ~a:\n  took ~4f seconds in transaction\n"
-                        proc
-                        duration-seconds)
-                       (current-error-port)))
-
-                    (cons duration-seconds vals)))))))
+            (if (%current-transaction-proc)
+                (proc-with-duration-timing db) ; already in transaction
+                (run-proc-within-transaction db))))
     ((duration vals ...)
      (apply values vals))))