guix-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

02/09: guix: store: Make register-items transactional, register drv outp


From: guix-commits
Subject: 02/09: guix: store: Make register-items transactional, register drv outputs
Date: Mon, 4 Feb 2019 14:22:43 -0500 (EST)

reepca pushed a commit to branch guile-daemon
in repository guix.

commit 91cbfa8da90d8d1723da753c171a378dae13cb40
Author: Caleb Ristvedt <address@hidden>
Date:   Wed Jan 30 17:03:38 2019 -0600

    guix: store: Make register-items transactional, register drv outputs
    
    * guix/store/database.scm (SQLITE_BUSY, register-output-sql): new variables
      (add-references): don't try finalizing after each use, only after all the
      uses.
      (call-with-transaction): New procedure.
      (register-items): Use call-with-transaction to prevent broken intermediate
      states from being visible. Also if item is a derivation register its
      outputs (the C++ registering does this).
      ((guix derivations)): use it for read-derivation-from-file and
      derivation-path?
    
    * .dir-locals.el (call-with-transaction): indent it.
---
 .dir-locals.el          |  1 +
 guix/store/database.scm | 73 +++++++++++++++++++++++++++++++++++++++++--------
 2 files changed, 63 insertions(+), 11 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 593c767..550e06e 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -79,6 +79,7 @@
    (eval . (put 'with-extensions 'scheme-indent-function 1))
 
    (eval . (put 'with-database 'scheme-indent-function 2))
+   (eval . (put 'call-with-transaction 'scheme-indent-function 2))
 
    (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 4791f49..767d82f 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -22,6 +22,8 @@
   #:use-module (guix config)
   #:use-module (guix serialization)
   #:use-module (guix store deduplication)
+  #:use-module (guix derivations)
+  #:use-module (guix store)
   #:use-module (guix base16)
   #:use-module (guix progress)
   #:use-module (guix build syscalls)
@@ -96,6 +98,30 @@ create it and initialize it as a new database."
                   (lambda ()
                     (sqlite-close db)))))
 
+(define SQLITE_BUSY 5)
+
+(define (call-with-transaction db proc)
+  "Starts a transaction with DB (makes as many attempts as necessary) and runs
+PROC. If PROC exits abnormally, aborts the transaction, otherwise commits the
+transaction after it finishes."
+  (catch 'sqlite-error
+    (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))))))
+
 (define %default-database-file
   ;; Default location of the store database.
   (string-append %store-database-directory "/db.sqlite"))
@@ -172,9 +198,9 @@ ids of items referred to."
                 (sqlite-bind-arguments stmt #:referrer referrer
                                        #:reference reference)
                 (sqlite-fold cons '() stmt)       ;execute it
-                (sqlite-finalize stmt)
                 (last-insert-row-id db))
-              references)))
+              references)
+    (sqlite-finalize stmt)))
 
 (define* (sqlite-register db #:key path (references '())
                           deriver hash nar-size time)
@@ -257,6 +283,11 @@ be used internally by the daemon's build hook."
   ;; When it all began.
   (make-time time-utc 0 1))
 
+(define register-output-sql
+  "INSERT OR REPLACE INTO DerivationOutputs (drv, id, path) SELECT id, :outid,
+:outpath FROM ValidPaths WHERE path = :drvpath")
+
+
 (define* (register-items items
                          #:key prefix state-directory
                          (deduplicate? #t)
@@ -305,6 +336,22 @@ Write a progress report to LOG-PORT."
     (define real-file-name
       (string-append store-dir "/" (basename (store-info-item item))))
 
+    (define (register-derivation-outputs)
+      "Register all output paths of REAL-FILE-NAME as being produced by
+it (note this doesn't mean 'already produced by it', but rather just
+'associated with it'). This assumes REAL-FILE-NAME is a derivation!"
+      (let ((drv (read-derivation-from-file real-file-name))
+            (stmt (sqlite-prepare db register-output-sql #:cache? #t)))
+        (for-each (match-lambda
+                    ((outid . ($ <derivation-output> path))
+                     (sqlite-bind-arguments stmt
+                                            #:drvpath to-register
+                                            #:outid outid
+                                            #:outpath path)
+                     (sqlite-fold noop #f stmt)))
+                  (derivation-outputs drv))
+        (sqlite-finalize stmt)))
+
     ;; When TO-REGISTER is already registered, skip it.  This makes a
     ;; significant differences when 'register-closures' is called
     ;; consecutively for overlapping closures such as 'system' and 'bootcfg'.
@@ -319,18 +366,22 @@ Write a progress report to LOG-PORT."
                                                (bytevector->base16-string 
hash))
                          #:nar-size nar-size
                          #:time registration-time)
+        (when (derivation-path? real-file-name)
+          (register-derivation-outputs))
         (when deduplicate?
           (deduplicate real-file-name hash #:store store-dir)))))
 
   (mkdir-p db-dir)
   (parameterize ((sql-schema schema))
     (with-database (string-append db-dir "/db.sqlite") db
-      (let* ((prefix   (format #f "registering ~a items" (length items)))
-             (progress (progress-reporter/bar (length items)
-                                              prefix log-port)))
-        (call-with-progress-reporter progress
-          (lambda (report)
-            (for-each (lambda (item)
-                        (register db item)
-                        (report))
-                      items)))))))
+      (call-with-transaction db
+          (lambda ()
+            (let* ((prefix   (format #f "registering ~a items" (length items)))
+                   (progress (progress-reporter/bar (length items)
+                                                    prefix log-port)))
+              (call-with-progress-reporter progress
+                (lambda (report)
+                  (for-each (lambda (item)
+                              (register db item)
+                              (report))
+                            items)))))))))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]