aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--nar-herder/database.scm86
1 files 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)))