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

[Caleb Ristvedt <caleb.ristvedt@cune.org>]

[-- Attachment #1: Type: text/plain, Size: 780 bytes --]


Changes made, though I'm not quite sure about this part:

> Could you add a test in tests/store-database.scm for this bit?
>
>> +        (when (derivation-path? real-file-name)
>> +          (register-derivation-outputs))

Should that be a separate test or an extension of "register-path"?
Currently I'm doing the latter. And it looks ugly. The C++ code also
checks the validity of derivation outputs (whether the outputs should
actually have those filenames), which I'd like to eventually add to
register-items, and it would cause an error with the way the test
currently is. But then again, ffffff...fff-fake is probably already not
the right filename to be generated for that file anyway. Should we try
to do things "the proper way" there?

> Could you send updated patches?


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-guix-store-Make-register-items-transactional.patch --]
[-- Type: text/x-patch, Size: 4822 bytes --]

From 5ae8c31826f06f4ad0b52a4d7b0cd6c4abc64a20 Mon Sep 17 00:00:00 2001
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
Date: Wed, 30 Jan 2019 17:03:38 -0600
Subject: [PATCH 1/2] guix: store: Make register-items transactional.

* 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 (otherwise a finalized statement would be used if #:cache? was #f).
  (call-with-transaction): New procedure.
  (register-items): Use call-with-transaction to prevent broken intermediate
  states from being visible.

* .dir-locals.el (call-with-transaction): indent it.
---
 .dir-locals.el          |  1 +
 guix/store/database.scm | 50 ++++++++++++++++++++++++++++++++---------
 2 files changed, 40 insertions(+), 11 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 593c767d2b..550e06ef09 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 4791f49865..af7f82b049 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -96,6 +96,31 @@ create it and initialize it as a new database."
                   (lambda ()
                     (sqlite-close db)))))
 
+;; 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."
+  (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 +197,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)
@@ -305,6 +330,7 @@ Write a progress report to LOG-PORT."
     (define real-file-name
       (string-append store-dir "/" (basename (store-info-item item))))
 
+
     ;; 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'.
@@ -325,12 +351,14 @@ Write a progress report to LOG-PORT."
   (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)))))))))
-- 
2.20.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-guix-store-Register-derivation-outputs.patch --]
[-- Type: text/x-patch, Size: 6761 bytes --]

From adba9061739cd9afff9d404f871f66ce36147dd2 Mon Sep 17 00:00:00 2001
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
Date: Wed, 13 Feb 2019 02:19:42 -0600
Subject: [PATCH 2/2] guix: store: Register derivation outputs.

* guix/store/database.scm (register-output-sql, derivation-outputs-sql): new
  variables.
  (registered-derivation-outputs): new procedure.
  ((guix derivations), (guix store)): used for <derivation> and
  derivation-path?, respectively.
  (register-items): if item is a derivation, also register its outputs.

* tests/store-database.scm (register-path): first register a dummy derivation
  for the test file, and check that its outputs are registered in the
  DerivationOutputs table and are equal to what was specified in the dummy
  derivation.
---
 guix/store/database.scm  | 41 ++++++++++++++++++++++++++++++++++++++++
 tests/store-database.scm | 30 ++++++++++++++++++++++++++++-
 2 files changed, 70 insertions(+), 1 deletion(-)

diff --git a/guix/store/database.scm b/guix/store/database.scm
index af7f82b049..b89d81d770 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -21,6 +21,8 @@
   #:use-module (sqlite3)
   #:use-module (guix config)
   #:use-module (guix serialization)
+  #:use-module (guix derivations)
+  #:use-module (guix store)
   #:use-module (guix store deduplication)
   #:use-module (guix base16)
   #:use-module (guix progress)
@@ -42,6 +44,7 @@
             sqlite-register
             register-path
             register-items
+            registered-derivation-outputs
             %epoch
             reset-timestamps))
 
@@ -282,6 +285,26 @@ be used internally by the daemon's build hook."
   ;; When it all began.
   (make-time time-utc 0 1))
 
+(define derivation-outputs-sql "SELECT id, path FROM DerivationOutputs WHERE
+drv in (SELECT id from ValidPaths where path = :drv)")
+
+(define (registered-derivation-outputs db drv)
+  "Get the list of (id, output-path) pairs registered for DRV."
+  (let ((stmt (sqlite-prepare db derivation-outputs-sql #:cache? #t)))
+    (sqlite-bind-arguments stmt #:drv drv)
+    (let ((result (sqlite-fold (lambda (current prev)
+                                 (match current
+                                   (#(id path)
+                                    (cons (cons id path)
+                                          prev))))
+                               '() stmt)))
+      (sqlite-finalize stmt)
+      result)))
+
+(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)
@@ -330,6 +353,21 @@ Write a progress report to LOG-PORT."
     (define real-file-name
       (string-append store-dir "/" (basename (store-info-item item))))
 
+    (define (register-derivation-outputs drv)
+      "Register all output paths of DRV as being produced by it (note that
+this doesn't mean 'already produced by it', but rather just 'associated with
+it')."
+      (let ((stmt (sqlite-prepare db register-output-sql #:cache? #t)))
+        (for-each (match-lambda
+                    ((outid . ($ <derivation-output> path))
+                     (sqlite-bind-arguments stmt
+                                            #:drvpath (derivation-file-name
+                                                       drv)
+                                            #: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
@@ -345,6 +383,9 @@ 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 (read-derivation-from-file
+                                        real-file-name)))
         (when deduplicate?
           (deduplicate real-file-name hash #:store store-dir)))))
 
diff --git a/tests/store-database.scm b/tests/store-database.scm
index 4d91884250..d5fb916586 100644
--- a/tests/store-database.scm
+++ b/tests/store-database.scm
@@ -20,6 +20,7 @@
   #:use-module (guix tests)
   #:use-module (guix store)
   #:use-module (guix store database)
+  #:use-module (guix derivations)
   #:use-module ((guix utils) #:select (call-with-temporary-output-file))
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64))
@@ -44,14 +45,41 @@
           (drv (string-append file ".drv")))
       (call-with-output-file file
         (cut display "This is a fake store item.\n" <>))
+      (when (valid-path? %store drv)
+        (delete-paths %store (list drv)))
+      (call-with-output-file drv
+        (lambda (port)
+          ;; XXX: we should really go from derivation to output path as is
+          ;; usual, currently any verification done on this derivation will
+          ;; cause an error.
+          (write-derivation ((@@ (guix derivations) make-derivation)
+                             ;; outputs
+                             (list (cons "out"
+                                         ((@@ (guix derivations)
+                                              make-derivation-output)
+                                          file
+                                          #f
+                                          #f
+                                          #f)))
+                             ;; inputs sources system builder args
+                             '() '() "" "" '()
+                             ;; env-vars filename
+                             '() drv)
+                            port)))
+      (register-path drv)
       (register-path file
                      #:references (list ref)
                      #:deriver drv)
 
       (and (valid-path? %store file)
            (equal? (references %store file) (list ref))
-           (null? (valid-derivers %store file))
+           ;; We expect the derivation outputs to be automatically
+           ;; registered.
+           (not (null? (valid-derivers %store file)))
            (null? (referrers %store file))
+           (equal? (with-database %default-database-file db
+                     (registered-derivation-outputs db drv))
+                   `(("out" . ,file)))
            (list (stat:mtime (lstat file))
                  (stat:mtime (lstat ref)))))))
 
-- 
2.20.0


[-- Attachment #4: Type: text/plain, Size: 11 bytes --]



- reepca