From af87a556dab110ed7a6ef2fa1584778cc60be682 Mon Sep 17 00:00:00 2001
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
Date: Mon, 1 Jun 2020 22:15:21 -0500
Subject: [PATCH 5/5] database: separate transaction-handling and
retry-handling.
Previously call-with-transaction would both retry when SQLITE_BUSY errors were
thrown and do what its name suggested (start and rollback/commit a
transaction). This changes it to do only what its name implies, which
simplifies its implementation. Retrying is provided by the new
call-with-SQLITE_BUSY-retrying procedure.
* guix/store/database.scm (call-with-transaction): no longer restarts, new
#:restartable? argument controls whether "begin" or "begin immediate" is
used.
(call-with-SQLITE_BUSY-retrying, call-with-retrying-transaction,
call-with-retrying-savepoint): new procedures.
(register-items): use call-with-retrying-transaction to preserve old
behavior.
* .dir-locals.el (call-with-retrying-transaction,
call-with-retrying-savepoint): add indentation information.
---
.dir-locals.el | 2 ++
guix/store/database.scm | 69 +++++++++++++++++++++++++++++------------
2 files changed, 51 insertions(+), 20 deletions(-)
@@ -90,7 +90,9 @@
(eval . (put 'with-database 'scheme-indent-function 2))
(eval . (put 'call-with-transaction 'scheme-indent-function 2))
(eval . (put 'with-statement 'scheme-indent-function 3))
+ (eval . (put 'call-with-retrying-transaction 'scheme-indent-function 2))
(eval . (put 'call-with-savepoint 'scheme-indent-function 1))
+ (eval . (put 'call-with-retrying-savepoint 'scheme-indent-function 1))
(eval . (put 'call-with-container 'scheme-indent-function 1))
(eval . (put 'container-excursion 'scheme-indent-function 1))
@@ -99,27 +99,44 @@ create it and initialize it as a new database."
;; XXX: missing in guile-sqlite3@0.1.0
(define SQLITE_BUSY 5)
-(define (call-with-transaction db proc)
- "Start a transaction with DB (make as many attempts as necessary) and run
-PROC. If PROC exits abnormally, abort the transaction, otherwise commit the
-transaction after it finishes."
+(define (call-with-SQLITE_BUSY-retrying thunk)
+ "Call THUNK, retrying as long as it exits abnormally due to SQLITE_BUSY
+errors."
(catch 'sqlite-error
+ thunk
+ (lambda (key who code errmsg)
+ (if (= code SQLITE_BUSY)
+ (call-with-SQLITE_BUSY-retrying thunk)
+ (throw key who code errmsg)))))
+
+
+
+(define* (call-with-transaction db proc #:key restartable?)
+ "Start a transaction with DB and run PROC. If PROC exits abnormally, abort
+the transaction, otherwise commit the transaction after it finishes.
+RESTARTABLE? may be set to a non-#f value when it is safe to run PROC multiple
+times. This may reduce contention for the database somewhat."
+ (define (exec sql)
+ (with-statement db sql stmt
+ (sqlite-fold cons '() stmt)))
+ ;; We might use begin immediate here so that if we need to retry, we figure
+ ;; that out immediately rather than because some SQLITE_BUSY exception gets
+ ;; thrown partway through PROC - in which case the part already executed
+ ;; (which may contain side-effects!) might have to be executed again for
+ ;; every retry.
+ (exec (if restartable? "begin;" "begin immediate;"))
+ (catch #t
(lambda ()
- ;; We use begin immediate here so that if we need to retry, we
- ;; figure that out immediately rather than because some SQLITE_BUSY
- ;; exception gets thrown partway through PROC - in which case the
- ;; part already executed (which may contain side-effects!) would be
- ;; executed again for every retry.
- (sqlite-exec db "begin immediate;")
- (let ((result (proc)))
- (sqlite-exec db "commit;")
- result))
- (lambda (key who error description)
- (if (= error SQLITE_BUSY)
- (call-with-transaction db proc)
- (begin
- (sqlite-exec db "rollback;")
- (throw 'sqlite-error who error description))))))
+ (let-values ((result (proc)))
+ (exec "commit;")
+ (apply values result)))
+ (lambda args
+ ;; The roll back may or may not have occurred automatically when the
+ ;; error was generated. If it has occurred, this does nothing but signal
+ ;; an error. If it hasn't occurred, this needs to be done.
+ (false-if-exception (exec "rollback;"))
+ (apply throw args))))
+
(define* (call-with-savepoint db proc
#:optional (savepoint-name "SomeSavepoint"))
"Call PROC after creating a savepoint named SAVEPOINT-NAME. If PROC exits
@@ -141,6 +158,18 @@ prior to returning."
(lambda ()
(exec (string-append "RELEASE " savepoint-name ";")))))
+(define* (call-with-retrying-transaction db proc #:key restartable?)
+ (call-with-SQLITE_BUSY-retrying
+ (lambda ()
+ (call-with-transaction db proc #:restartable? restartable?))))
+
+(define* (call-with-retrying-savepoint db proc
+ #:optional (savepoint-name
+ "SomeSavepoint"))
+ (call-with-SQLITE_BUSY-retrying
+ (lambda ()
+ (call-with-savepoint db proc savepoint-name))))
+
(define %default-database-file
;; Default location of the store database.
(string-append %store-database-directory "/db.sqlite"))
@@ -433,7 +462,7 @@ Write a progress report to LOG-PORT."
(mkdir-p db-dir)
(parameterize ((sql-schema schema))
(with-database (string-append db-dir "/db.sqlite") db
- (call-with-transaction db
+ (call-with-retrying-transaction db
(lambda ()
(let* ((prefix (format #f "registering ~a items" (length items)))
(progress (progress-reporter/bar (length items)
--
2.26.2