bug#44760: [PATCH 12/15] system: 'init' does not recompute the hash of each store item.

["Ludovic Courtès" <ludo@gnu.org>]

Fixes <https://bugs.gnu.org/44760>.

Previously, the 'register-path' call would re-traverse ITEM to compute
its nar hash, even though that hash is already known in the initial
store.  This patch also avoids repeated opening/closing of the
database.

* guix/store/database.scm (call-with-database): Export.
* guix/scripts/system.scm (copy-item): Add 'db' parameter.  Call
'sqlite-register' instead of 'register-path'.
(copy-closure): Remove redundant call to 'references*'.  Call
'call-with-database' and pass the database to 'copy-item'.
---
 .dir-locals.el          |  1 +
 guix/scripts/system.scm | 59 ++++++++++++++++++++++-------------------
 guix/store/database.scm |  1 +
 3 files changed, 34 insertions(+), 27 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 4eb27d8b1b..8f07a08eb5 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -121,6 +121,7 @@
    (eval . (put 'let-system 'scheme-indent-function 1))
 
    (eval . (put 'with-database 'scheme-indent-function 2))
+   (eval . (put 'call-with-database 'scheme-indent-function 1))
    (eval . (put 'call-with-transaction 'scheme-indent-function 1))
    (eval . (put 'with-statement 'scheme-indent-function 3))
    (eval . (put 'call-with-retrying-transaction 'scheme-indent-function 1))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 0e543d9460..5427f875ec 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -29,7 +29,9 @@
   #:use-module (guix ui)
   #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module (guix store)
-  #:autoload   (guix store database) (register-path)
+  #:autoload   (guix base16) (bytevector->base16-string)
+  #:autoload   (guix store database)
+               (sqlite-register store-database-file call-with-database)
   #:autoload   (guix build store-copy) (copy-store-item)
   #:use-module (guix describe)
   #:use-module (guix grafts)
@@ -130,12 +132,11 @@ BODY..., and restore them."
   (store-lift topologically-sorted))
 
 
-(define* (copy-item item references target
+(define* (copy-item item info target db
                     #:key (log-port (current-error-port)))
-  "Copy ITEM to the store under root directory TARGET and register it with
-REFERENCES as its set of references."
-  (let ((dest  (string-append target item))
-        (state (string-append target "/var/guix")))
+  "Copy ITEM to the store under root directory TARGET and populate DB with the
+given INFO, a <path-info> record."
+  (let ((dest (string-append target item)))
     (format log-port "copying '~a'...~%" item)
 
     ;; Remove DEST if it exists to make sure that (1) we do not fail badly
@@ -151,41 +152,45 @@ REFERENCES as its set of references."
     (copy-store-item item target
                      #:deduplicate? #t)
 
-    ;; Register ITEM; as a side-effect, it resets timestamps, etc.
-    ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
-    ;; reproducing the user's current settings; see
-    ;; <http://bugs.gnu.org/18049>.
-    (unless (register-path item
-                           #:prefix target
-                           #:state-directory state
-                           #:references references)
-      (leave (G_ "failed to register '~a' under '~a'~%")
-             item target))))
+    (sqlite-register db
+                     #:path item
+                     #:references (path-info-references info)
+                     #:deriver (path-info-deriver info)
+                     #:hash (string-append
+                             "sha256:"
+                             (bytevector->base16-string (path-info-hash info)))
+                     #:nar-size (path-info-nar-size info))))
 
 (define* (copy-closure item target
                        #:key (log-port (current-error-port)))
   "Copy ITEM and all its dependencies to the store under root directory
 TARGET, and register them."
   (mlet* %store-monad ((to-copy (topologically-sorted* (list item)))
-                       (refs    (mapm %store-monad references* to-copy))
-                       (info    (mapm %store-monad query-path-info*
-                                      (delete-duplicates
-                                       (append to-copy (concatenate refs)))))
+                       (info    (mapm %store-monad query-path-info* to-copy))
                        (size -> (reduce + 0 (map path-info-nar-size info))))
     (define progress-bar
       (progress-reporter/bar (length to-copy)
                              (format #f (G_ "copying to '~a'...")
                                      target)))
 
+    (define state
+      (string-append target "/var/guix"))
+
     (check-available-space size target)
 
-    (call-with-progress-reporter progress-bar
-      (lambda (report)
-        (let ((void (%make-void-port "w")))
-          (for-each (lambda (item refs)
-                      (copy-item item refs target #:log-port void)
-                      (report))
-                    to-copy refs))))
+    ;; Explicitly use "TARGET/var/guix" as the state directory to avoid
+    ;; reproducing the user's current settings; see
+    ;; <http://bugs.gnu.org/18049>.
+    (call-with-database (store-database-file #:prefix target
+                                             #:state-directory state)
+      (lambda (db)
+        (call-with-progress-reporter progress-bar
+          (lambda (report)
+            (let ((void (%make-void-port "w")))
+              (for-each (lambda (item info)
+                          (copy-item item info target db #:log-port void)
+                          (report))
+                        to-copy info))))))
 
     (return *unspecified*)))
 
diff --git a/guix/store/database.scm b/guix/store/database.scm
index c0010b72b9..9d5bc531bb 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -39,6 +39,7 @@
   #:export (sql-schema
             %default-database-file
             store-database-file
+            call-with-database
             with-database
             path-id
             sqlite-register
-- 
2.29.2