aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el1
-rw-r--r--guix/store/database.scm68
2 files changed, 56 insertions, 13 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index 77c12f9411..d9c81b2a48 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -90,6 +90,7 @@
(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-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 e74c4ba991..3193dcf23c 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -120,6 +120,26 @@ transaction after it finishes."
(begin
(sqlite-exec db "rollback;")
(throw 'sqlite-error who error description))))))
+(define* (call-with-savepoint db proc
+ #:optional (savepoint-name "SomeSavepoint"))
+ "Call PROC after creating a savepoint named SAVEPOINT-NAME. If PROC exits
+abnormally, rollback to that savepoint. In all cases, remove the savepoint
+prior to returning."
+ (define (exec sql)
+ (with-statement db sql stmt
+ (sqlite-fold cons '() stmt)))
+
+ (dynamic-wind
+ (lambda ()
+ (exec (string-append "SAVEPOINT " savepoint-name ";")))
+ (lambda ()
+ (catch #t
+ proc
+ (lambda args
+ (exec (string-append "ROLLBACK TO " savepoint-name ";"))
+ (apply throw args))))
+ (lambda ()
+ (exec (string-append "RELEASE " savepoint-name ";")))))
(define %default-database-file
;; Default location of the store database.
@@ -189,19 +209,41 @@ VALUES (:path, :hash, :time, :deriver, :size)")
doesn't exactly have... they've got something close, but it involves deleting
and re-inserting instead of updating, which causes problems with foreign keys,
of course. Returns the row id of the row that was modified or inserted."
- (let ((id (path-id db path)))
- (if id
- (with-statement db update-sql stmt
- (sqlite-bind-arguments stmt #:id id
- #:deriver deriver
- #:hash hash #:size nar-size #:time time)
- (sqlite-fold cons '() stmt))
- (with-statement db insert-sql stmt
- (sqlite-bind-arguments stmt
- #:path path #:deriver deriver
- #:hash hash #:size nar-size #:time time)
- (sqlite-fold cons '() stmt)))
- (last-insert-row-id db)))
+
+ ;; It's important that querying the path-id and the insert/update operation
+ ;; take place in the same transaction, as otherwise some other
+ ;; process/thread/fiber could register the same path between when we check
+ ;; whether it's already registered and when we register it, resulting in
+ ;; duplicate paths (which, due to a 'unique' constraint, would cause an
+ ;; exception to be thrown). With the default journaling mode this will
+ ;; prevent writes from occurring during that sensitive time, but with WAL
+ ;; mode it will instead arrange to return SQLITE_BUSY when a write occurs
+ ;; between the start of a read transaction and its upgrading to a write
+ ;; transaction (see https://sqlite.org/rescode.html#busy_snapshot).
+ ;; Experimentally, it seems this SQLITE_BUSY will ignore a busy_timeout and
+ ;; immediately return (makes sense, since waiting won't change anything).
+
+ ;; Note that when that kind of SQLITE_BUSY error is returned, it will keep
+ ;; being returned every time we try to upgrade the same outermost
+ ;; transaction to a write transaction. So when retrying, we have to restart
+ ;; the *outermost* write transaction. We can't inherently tell whether
+ ;; we're the outermost write transaction, so we leave the retry-handling to
+ ;; the caller.
+ (call-with-savepoint db
+ (lambda ()
+ (let ((id (path-id db path)))
+ (if id
+ (with-statement db update-sql stmt
+ (sqlite-bind-arguments stmt #:id id
+ #:deriver deriver
+ #:hash hash #:size nar-size #:time time)
+ (sqlite-fold cons '() stmt))
+ (with-statement db insert-sql stmt
+ (sqlite-bind-arguments stmt
+ #:path path #:deriver deriver
+ #:hash hash #:size nar-size #:time time)
+ (sqlite-fold cons '() stmt)))
+ (last-insert-row-id db)))))
(define add-reference-sql
"INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);")