[bug#33259] [PATCH 1/8] pack: Move store database creation to a separate derivation.

[Ludovic Courtès]

* guix/scripts/pack.scm (store-database): New procedure.
(self-contained-tarball): Use it when LOCALSTATEDIR? is true.
Remove 'schema' and add 'database'.
[build]: Pass DATABASE to 'populate-single-profile-directory'.
(squashfs-image): Remove #:deduplicate? parameter.
[build]: Remove (gnu build install) and (guix config) from the imported
modules.  Remove 'with-extensions'.
* gnu/build/install.scm (populate-single-profile-directory): Remove
 #:deduplicate?, #:register?, and #:schema; add #:database.  Remove call
to 'register-closure' and simply copy DATABASE instead.
---
 gnu/build/install.scm |  17 ++---
 guix/scripts/pack.scm | 170 +++++++++++++++++++++++++-----------------
 2 files changed, 109 insertions(+), 78 deletions(-)

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 98c547f2e4..9f9a6aba0f 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -161,14 +161,13 @@ deduplicates files common to CLOSURE and the rest of 
PREFIX."
 (define* (populate-single-profile-directory directory
                                             #:key profile closure
                                             (profile-name "guix-profile")
-                                            deduplicate?
-                                            register? schema)
+                                            database)
   "Populate DIRECTORY with a store containing PROFILE, whose closure is given
 in the file called CLOSURE (as generated by #:references-graphs.)  DIRECTORY
 is initialized to contain a single profile under /root pointing to PROFILE.
-When REGISTER? is true, initialize DIRECTORY/var/guix/db to reflect the
-contents of the store; DEDUPLICATE? determines whether to deduplicate files in
-the store.
+
+When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
+DIRECTORY/var/guix/gcroots and friends.
 
 PROFILE-NAME is the name of the profile being created under
 /var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".
@@ -189,11 +188,9 @@ This is used to create the self-contained tarballs with 
'guix pack'."
   ;; Populate the store.
   (populate-store (list closure) directory)
 
-  (when register?
-    (register-closure (canonicalize-path directory) closure
-                      #:deduplicate? deduplicate?
-                      #:schema schema)
-
+  (when database
+    (install-file database (scope "/var/guix/db/"))
+    (chmod (scope "/var/guix/db/db.sqlite") #o644)
     (mkdir-p* "/var/guix/profiles")
     (mkdir-p* "/var/guix/gcroots")
     (symlink* "/var/guix/profiles"
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 83bfa4ce00..faeea68426 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -103,6 +103,47 @@ found."
                       (package-transitive-propagated-inputs package)))
               (list guile-gcrypt guile-sqlite3)))
 
+(define (store-database items)
+  "Return a directory containing a store database where all of ITEMS and their
+dependencies are registered."
+  (define schema
+    (local-file (search-path %load-path
+                             "guix/store/schema.sql")))
+
+
+  (define labels
+    (map (lambda (n)
+           (string-append "closure" (number->string n)))
+         (iota (length items))))
+
+  (define build
+    (with-extensions gcrypt-sqlite3&co
+      ;; XXX: Adding (gnu build install) just to work around
+      ;; <https://bugs.gnu.org/15602>: that way, (guix build store-copy) is
+      ;; copied last and the 'store-info-XXX' macros are correctly expanded.
+      (with-imported-modules (source-module-closure
+                              '((guix build store-copy)
+                                (guix store database)
+                                (gnu build install)))
+        #~(begin
+            (use-modules (guix store database)
+                         (guix build store-copy)
+                         (srfi srfi-1))
+
+            (define (read-closure closure)
+              (call-with-input-file closure read-reference-graph))
+
+            (let ((items (append-map read-closure '#$labels)))
+              (register-items items
+                              #:state-directory #$output
+                              #:deduplicate? #f
+                              #:reset-timestamps? #f
+                              #:registration-time %epoch
+                              #:schema #$schema))))))
+
+  (computed-file "store-database" build
+                 #:options `(#:references-graphs ,(zip labels items))))
+
 (define* (self-contained-tarball name profile
                                  #:key target
                                  deduplicate?
@@ -117,10 +158,10 @@ with a properly initialized store database.
 
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 added to the pack."
-  (define schema
+  (define database
     (and localstatedir?
-         (local-file (search-path %load-path
-                                  "guix/store/schema.sql"))))
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
 
   (define build
     (with-imported-modules `(((guix config) => ,(make-config.scm))
@@ -181,9 +222,7 @@ added to the pack."
             (populate-single-profile-directory %root
                                                #:profile #$profile
                                                #:closure "profile"
-                                               #:deduplicate? #f
-                                               #:register? #$localstatedir?
-                                               #:schema #$schema)
+                                               #:database #+database)
 
             ;; Create SYMLINKS.
             (for-each (cut evaluate-populate-directive <> %root)
@@ -240,7 +279,6 @@ added to the pack."
 
 (define* (squashfs-image name profile
                          #:key target
-                         deduplicate?
                          (compressor (first %compressors))
                          localstatedir?
                          (symlinks '())
@@ -252,74 +290,70 @@ points for virtual file systems (like procfs), and 
optional symlinks.
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 added to the pack."
   (define build
-    (with-imported-modules `(((guix config) => ,(make-config.scm))
-                             ,@(source-module-closure
-                                '((guix build utils)
-                                  (guix build store-copy)
-                                  (gnu build install))
-                                #:select? not-config?))
-      (with-extensions gcrypt-sqlite3&co
-        #~(begin
-            (use-modules (guix build utils)
-                         (gnu build install)
-                         (guix build store-copy)
-                         (srfi srfi-1)
-                         (srfi srfi-26)
-                         (ice-9 match))
+    (with-imported-modules (source-module-closure
+                            '((guix build utils)
+                              (guix build store-copy))
+                            #:select? not-config?)
+      #~(begin
+          (use-modules (guix build utils)
+                       (guix build store-copy)
+                       (srfi srfi-1)
+                       (srfi srfi-26)
+                       (ice-9 match))
 
-            (setenv "PATH" (string-append #$archiver "/bin"))
+          (setenv "PATH" (string-append #$archiver "/bin"))
 
-            ;; We need an empty file in order to have a valid file argument 
when
-            ;; we reparent the root file system.  Read on for why that's
-            ;; necessary.
-            (with-output-to-file ".empty" (lambda () (display "")))
+          ;; We need an empty file in order to have a valid file argument when
+          ;; we reparent the root file system.  Read on for why that's
+          ;; necessary.
+          (with-output-to-file ".empty" (lambda () (display "")))
 
-            ;; Create the squashfs image in several steps.
-            ;; Add all store items.  Unfortunately mksquashfs throws away all
-            ;; ancestor directories and only keeps the basename.  We fix this
-            ;; in the following invocations of mksquashfs.
-            (apply invoke "mksquashfs"
-                   `(,@(map store-info-item
-                            (call-with-input-file "profile"
-                              read-reference-graph))
-                     ,#$output
+          ;; Create the squashfs image in several steps.
+          ;; Add all store items.  Unfortunately mksquashfs throws away all
+          ;; ancestor directories and only keeps the basename.  We fix this
+          ;; in the following invocations of mksquashfs.
+          (apply invoke "mksquashfs"
+                 `(,@(map store-info-item
+                          (call-with-input-file "profile"
+                            read-reference-graph))
+                   ,#$output
 
-                     ;; Do not perform duplicate checking because we
-                     ;; don't have any dupes.
-                     "-no-duplicates"
-                     "-comp"
-                     ,#+(compressor-name compressor)))
+                   ;; Do not perform duplicate checking because we
+                   ;; don't have any dupes.
+                   "-no-duplicates"
+                   "-comp"
+                   ,#+(compressor-name compressor)))
 
-            ;; Here we reparent the store items.  For each sub-directory of
-            ;; the store prefix we need one invocation of "mksquashfs".
-            (for-each (lambda (dir)
-                        (apply invoke "mksquashfs"
-                               `(".empty"
-                                 ,#$output
-                                 "-root-becomes" ,dir)))
-                      (reverse (string-tokenize (%store-directory)
-                                                (char-set-complement (char-set 
#\/)))))
+          ;; Here we reparent the store items.  For each sub-directory of
+          ;; the store prefix we need one invocation of "mksquashfs".
+          (for-each (lambda (dir)
+                      (apply invoke "mksquashfs"
+                             `(".empty"
+                               ,#$output
+                               "-root-becomes" ,dir)))
+                    (reverse (string-tokenize (%store-directory)
+                                              (char-set-complement (char-set 
#\/)))))
 
-            ;; Add symlinks and mount points.
-            (apply invoke "mksquashfs"
-                   `(".empty"
-                     ,#$output
-                     ;; Create SYMLINKS via pseudo file definitions.
-                     ,@(append-map
-                        (match-lambda
-                          ((source '-> target)
-                           (list "-p"
-                                 (string-join
-                                  ;; name s mode uid gid symlink
-                                  (list source
-                                        "s" "777" "0" "0"
-                                        (string-append #$profile "/" 
target))))))
-                        '#$symlinks)
+          ;; Add symlinks and mount points.
+          (apply invoke "mksquashfs"
+                 `(".empty"
+                   ,#$output
+                   ;; Create SYMLINKS via pseudo file definitions.
+                   ,@(append-map
+                      (match-lambda
+                        ((source '-> target)
+                         (list "-p"
+                               (string-join
+                                ;; name s mode uid gid symlink
+                                (list source
+                                      "s" "777" "0" "0"
+                                      (string-append #$profile "/" target))))))
+                      '#$symlinks)
 
-                     ;; Create empty mount points.
-                     "-p" "/proc d 555 0 0"
-                     "-p" "/sys d 555 0 0"
-                     "-p" "/dev d 555 0 0"))))))
+                   ;; Create empty mount points.
+                   "-p" "/proc d 555 0 0"
+                   "-p" "/sys d 555 0 0"
+                   "-p" "/dev d 555 0 0")))))
 
   (gexp->derivation (string-append name
                                    (compressor-extension compressor)
-- 
2.19.1