database: ensure update-or-insert is run within a transaction

update-or-insert can break if an insert occurs between when it decides whether
to update or insert and when it actually performs that operation.  Putting the
check and the update/insert operation in the same transaction ensures that the
update/insert will only succeed if no other write has occurred in the middle.

* guix/store/database.scm (call-with-savepoint): new procedure.
  (update-or-insert): use call-with-savepoint to ensure the read and the
  insert/update occur within the same transaction.

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

guix/store/database.scm

@@ -120,6 +120,26 @@ (define (call-with-transaction db proc)
           (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 @@ (define* (update-or-insert db #:key path deriver hash nar-size time)
 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
+  ;; It's important that querying the path-id and the insert/update operation
-        (with-statement db update-sql stmt
+  ;; take place in the same transaction, as otherwise some other
-          (sqlite-bind-arguments stmt #:id id
+  ;; process/thread/fiber could register the same path between when we check
-                                 #:deriver deriver
+  ;; whether it's already registered and when we register it, resulting in
-                                 #:hash hash #:size nar-size #:time time)
+  ;; duplicate paths (which, due to a 'unique' constraint, would cause an
-          (sqlite-fold cons '() stmt))
+  ;; exception to be thrown). With the default journaling mode this will
-        (with-statement db insert-sql stmt
+  ;; prevent writes from occurring during that sensitive time, but with WAL
-          (sqlite-bind-arguments stmt
+  ;; mode it will instead arrange to return SQLITE_BUSY when a write occurs
-                                 #:path path #:deriver deriver
+  ;; between the start of a read transaction and its upgrading to a write
-                                 #:hash hash #:size nar-size #:time time)
+  ;; transaction (see https://sqlite.org/rescode.html#busy_snapshot).
-          (sqlite-fold cons '() stmt)))
+  ;; Experimentally, it seems this SQLITE_BUSY will ignore a busy_timeout and
-    (last-insert-row-id db)))
+  ;; 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);")