Browse Source

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.
wip-haskell-updates-2
Caleb Ristvedt 2 years ago
parent
commit
8971f626f2
No known key found for this signature in database GPG Key ID: C166AA495F7F189C
  1. 2
      .dir-locals.el
  2. 69
      guix/store/database.scm

2
.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))

69
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"))
@ -412,7 +441,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)

Loading…
Cancel
Save