From e30271728dfb23324c981d226c752b17689c9eef Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Mon, 1 Jun 2020 22:15:21 -0500 Subject: [PATCH 4/4] 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(-) diff --git a/.dir-locals.el b/.dir-locals.el index ef25cb100a..e9dccd0511 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -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)) diff --git a/guix/store/database.scm b/guix/store/database.scm index 3955c48b1f..2a78379dac 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -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")) @@ -431,7 +460,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