pack: Import (guix store database) only when '--localstatedir' is passed.

This is another way to address <https://bugs.gnu.org/32184>, which was
previously addressed in commit 19c924af4f3726688ca155a905ebf1cb9acdfca2.

* gnu/build/install.scm (register-closure): Move to...
* gnu/build/vm.scm (register-closure): ... here.  New procedure.
* guix/scripts/pack.scm (self-contained-tarball)[build]: Remove
now unneeded 'with-extensions' form and custom (guix config) module.
* tests/guix-pack.sh: Revert the strategy from
commit 19c924af4f3726688ca155a905ebf1cb9acdfca2.
* tests/pack.scm ("self-contained-tarball"): Likewise.

5 files changed, 159 insertions, 179 deletions

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 9f9a6aba0f..a31e1945d6 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -18,7 +18,6 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build install)
-  #:use-module (guix store database)
   #:use-module (guix build utils)
   #:use-module (guix build store-copy)
   #:use-module (srfi srfi-26)
@@ -141,23 +140,6 @@ includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
                 (try))
               (apply throw args)))))))
 
-(define* (register-closure prefix closure
-                           #:key
-                           (deduplicate? #t) (reset-timestamps? #t)
-                           (schema (sql-schema)))
-  "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
-target store and CLOSURE is the name of a file containing a reference graph as
-produced by #:references-graphs..  As a side effect, if RESET-TIMESTAMPS? is
-true, reset timestamps on store files and, if DEDUPLICATE? is true,
-deduplicates files common to CLOSURE and the rest of PREFIX."
-  (let ((items (call-with-input-file closure read-reference-graph)))
-    (register-items items
-                    #:prefix prefix
-                    #:deduplicate? deduplicate?
-                    #:reset-timestamps? reset-timestamps?
-                    #:registration-time %epoch
-                    #:schema schema)))
-
 (define* (populate-single-profile-directory directory
                                             #:key profile closure
                                             (profile-name "guix-profile")
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 5579886264..746808515f 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -25,7 +25,7 @@
   #:use-module (guix build utils)
   #:use-module (guix build store-copy)
   #:use-module (guix build syscalls)
-  #:use-module ((guix store database) #:select (reset-timestamps))
+  #:use-module (guix store database)
   #:use-module (gnu build linux-boot)
   #:use-module (gnu build install)
   #:use-module (gnu system uuid)
@@ -191,6 +191,23 @@ the #:references-graphs parameter of 'derivation'."
           (mkdir output)
           (copy-recursively "xchg" output)))))
 
+(define* (register-closure prefix closure
+                           #:key
+                           (deduplicate? #t) (reset-timestamps? #t)
+                           (schema (sql-schema)))
+  "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
+target store and CLOSURE is the name of a file containing a reference graph as
+produced by #:references-graphs..  As a side effect, if RESET-TIMESTAMPS? is
+true, reset timestamps on store files and, if DEDUPLICATE? is true,
+deduplicates files common to CLOSURE and the rest of PREFIX."
+  (let ((items (call-with-input-file closure read-reference-graph)))
+    (register-items items
+                    #:prefix prefix
+                    #:deduplicate? deduplicate?
+                    #:reset-timestamps? reset-timestamps?
+                    #:registration-time %epoch
+                    #:schema schema)))
+
 
 ;;;
 ;;; Partitions.
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index faeea68426..3e6430bcce 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -164,113 +164,110 @@ added to the pack."
                       "/db/db.sqlite")))
 
   (define build
-    (with-imported-modules `(((guix config) => ,(make-config.scm))
-                             ,@(source-module-closure
-                                `((guix build utils)
-                                  (guix build union)
-                                  (guix build store-copy)
-                                  (gnu build install))
-                                #:select? not-config?))
-      (with-extensions gcrypt-sqlite3&co
-        #~(begin
-            (use-modules (guix build utils)
-                         ((guix build union) #:select (relative-file-name))
-                         (gnu build install)
-                         (srfi srfi-1)
-                         (srfi srfi-26)
-                         (ice-9 match))
-
-            (define %root "root")
-
-            (define symlink->directives
-              ;; Return "populate directives" to make the given symlink and its
-              ;; parent directories.
-              (match-lambda
-                ((source '-> target)
-                 (let ((target (string-append #$profile "/" target))
-                       (parent (dirname source)))
-                   ;; Never add a 'directory' directive for "/" so as to
-                   ;; preserve its ownnership when extracting the archive (see
-                   ;; below), and also because this would lead to adding the
-                   ;; same entries twice in the tarball.
-                   `(,@(if (string=? parent "/")
-                           '()
-                           `((directory ,parent)))
-                     (,source
-                      -> ,(relative-file-name parent target)))))))
-
-            (define directives
-              ;; Fully-qualified symlinks.
-              (append-map symlink->directives '#$symlinks))
-
-            ;; The --sort option was added to GNU tar in version 1.28, released
-            ;; 2014-07-28.  For testing, we use the bootstrap tar, which is
-            ;; older and doesn't support it.
-            (define tar-supports-sort?
-              (zero? (system* (string-append #+archiver "/bin/tar")
-                              "cf" "/dev/null" "--files-from=/dev/null"
-                              "--sort=name")))
-
-            ;; Add 'tar' to the search path.
-            (setenv "PATH" #+(file-append archiver "/bin"))
-
-            ;; Note: there is not much to gain here with deduplication and there
-            ;; is the overhead of the '.links' directory, so turn it off.
-            ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
-            ;; with hard links:
-            ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
-            (populate-single-profile-directory %root
-                                               #:profile #$profile
-                                               #:closure "profile"
-                                               #:database #+database)
-
-            ;; Create SYMLINKS.
-            (for-each (cut evaluate-populate-directive <> %root)
-                      directives)
-
-            ;; Create the tarball.  Use GNU format so there's no file name
-            ;; length limitation.
-            (with-directory-excursion %root
-              (exit
-               (zero? (apply system* "tar"
-                             #+@(if (compressor-command compressor)
-                                    #~("-I"
-                                       (string-join
-                                        '#+(compressor-command compressor)))
-                                    #~())
-                             "--format=gnu"
-
-                             ;; Avoid non-determinism in the archive.  Use
-                             ;; mtime = 1, not zero, because that is what the
-                             ;; daemon does for files in the store (see the
-                             ;; 'mtimeStore' constant in local-store.cc.)
-                             (if tar-supports-sort? "--sort=name" "--mtime=@1")
-                             "--mtime=@1"         ;for files in /var/guix
-                             "--owner=root:0"
-                             "--group=root:0"
-
-                             "--check-links"
-                             "-cvf" #$output
-                             ;; Avoid adding / and /var to the tarball, so
-                             ;; that the ownership and permissions of those
-                             ;; directories will not be overwritten when
-                             ;; extracting the archive.  Do not include /root
-                             ;; because the root account might have a
-                             ;; different home directory.
-                             #$@(if localstatedir?
-                                    '("./var/guix")
-                                    '())
-
-                             (string-append "." (%store-directory))
-
-                             (delete-duplicates
-                              (filter-map (match-lambda
-                                            (('directory directory)
-                                             (string-append "." directory))
-                                            ((source '-> _)
-                                             (string-append "." source))
-                                            (_ #f))
-                                          directives))))))))))
+    (with-imported-modules (source-module-closure
+                            `((guix build utils)
+                              (guix build union)
+                              (gnu build install))
+                            #:select? not-config?)
+      #~(begin
+          (use-modules (guix build utils)
+                       ((guix build union) #:select (relative-file-name))
+                       (gnu build install)
+                       (srfi srfi-1)
+                       (srfi srfi-26)
+                       (ice-9 match))
+
+          (define %root "root")
+
+          (define symlink->directives
+            ;; Return "populate directives" to make the given symlink and its
+            ;; parent directories.
+            (match-lambda
+              ((source '-> target)
+               (let ((target (string-append #$profile "/" target))
+                     (parent (dirname source)))
+                 ;; Never add a 'directory' directive for "/" so as to
+                 ;; preserve its ownnership when extracting the archive (see
+                 ;; below), and also because this would lead to adding the
+                 ;; same entries twice in the tarball.
+                 `(,@(if (string=? parent "/")
+                         '()
+                         `((directory ,parent)))
+                   (,source
+                    -> ,(relative-file-name parent target)))))))
+
+          (define directives
+            ;; Fully-qualified symlinks.
+            (append-map symlink->directives '#$symlinks))
+
+          ;; The --sort option was added to GNU tar in version 1.28, released
+          ;; 2014-07-28.  For testing, we use the bootstrap tar, which is
+          ;; older and doesn't support it.
+          (define tar-supports-sort?
+            (zero? (system* (string-append #+archiver "/bin/tar")
+                            "cf" "/dev/null" "--files-from=/dev/null"
+                            "--sort=name")))
+
+          ;; Add 'tar' to the search path.
+          (setenv "PATH" #+(file-append archiver "/bin"))
+
+          ;; Note: there is not much to gain here with deduplication and there
+          ;; is the overhead of the '.links' directory, so turn it off.
+          ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
+          ;; with hard links:
+          ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
+          (populate-single-profile-directory %root
+                                             #:profile #$profile
+                                             #:closure "profile"
+                                             #:database #+database)
+
+          ;; Create SYMLINKS.
+          (for-each (cut evaluate-populate-directive <> %root)
+                    directives)
+
+          ;; Create the tarball.  Use GNU format so there's no file name
+          ;; length limitation.
+          (with-directory-excursion %root
+            (exit
+             (zero? (apply system* "tar"
+                           #+@(if (compressor-command compressor)
+                                  #~("-I"
+                                     (string-join
+                                      '#+(compressor-command compressor)))
+                                  #~())
+                           "--format=gnu"
+
+                           ;; Avoid non-determinism in the archive.  Use
+                           ;; mtime = 1, not zero, because that is what the
+                           ;; daemon does for files in the store (see the
+                           ;; 'mtimeStore' constant in local-store.cc.)
+                           (if tar-supports-sort? "--sort=name" "--mtime=@1")
+                           "--mtime=@1"           ;for files in /var/guix
+                           "--owner=root:0"
+                           "--group=root:0"
+
+                           "--check-links"
+                           "-cvf" #$output
+                           ;; Avoid adding / and /var to the tarball, so
+                           ;; that the ownership and permissions of those
+                           ;; directories will not be overwritten when
+                           ;; extracting the archive.  Do not include /root
+                           ;; because the root account might have a
+                           ;; different home directory.
+                           #$@(if localstatedir?
+                                  '("./var/guix")
+                                  '())
+
+                           (string-append "." (%store-directory))
+
+                           (delete-duplicates
+                            (filter-map (match-lambda
+                                          (('directory directory)
+                                           (string-append "." directory))
+                                          ((source '-> _)
+                                           (string-append "." source))
+                                          (_ #f))
+                                        directives)))))))))
 
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
index cd721a60e9..8c1f556426 100644
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@@ -29,33 +29,21 @@ fi
 
 guix pack --version
 
-# Starting from commit 66e9944e078cbb9e0d618377dd6df6e639640efa, 'guix pack'
-# produces derivations that refer to guile-sqlite3 and libgcrypt.  To make
-# that relatively inexpensive, run the test in the user's global store if
-# possible, on the grounds that binaries may already be there or can be built
-# or downloaded inexpensively.
-
-NIX_STORE_DIR="`guile -c '(use-modules (guix config))(display %storedir)'`"
-localstatedir="`guile -c '(use-modules (guix config))(display %localstatedir)'`"
-GUIX_DAEMON_SOCKET="$localstatedir/guix/daemon-socket/socket"
-export NIX_STORE_DIR GUIX_DAEMON_SOCKET
-
-if ! guile -c '(use-modules (guix)) (exit (false-if-exception (open-connection)))'
-then
-    exit 77
-fi
+# Use --no-substitutes because we need to verify we can do this ourselves.
+GUIX_BUILD_OPTIONS="--no-substitutes"
+export GUIX_BUILD_OPTIONS
 
 # Build a tarball with no compression.
-guix pack --compression=none guile-bootstrap
+guix pack --compression=none --bootstrap guile-bootstrap
 
 # Build a tarball (with compression).  Check that '-e' works as well.
-out1="`guix pack guile-bootstrap`"
-out2="`guix pack -e '(@ (gnu packages bootstrap) %bootstrap-guile)'`"
+out1="`guix pack --bootstrap guile-bootstrap`"
+out2="`guix pack --bootstrap -e '(@ (gnu packages bootstrap) %bootstrap-guile)'`"
 test -n "$out1"
 test "$out1" = "$out2"
 
 # Build a tarball with a symlink.
-the_pack="`guix pack -S /opt/gnu/bin=bin guile-bootstrap`"
+the_pack="`guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap`"
 
 # Try to extract it.  Note: we cannot test whether /opt/gnu/bin/guile itself
 # exists because /opt/gnu/bin may be an absolute symlink to a store item that
diff --git a/tests/pack.scm b/tests/pack.scm
index 4eb5be92ff..6bd18bdee2 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -29,6 +29,9 @@
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-64))
 
+(define %store
+  (open-connection-for-tests))
+
 ;; Globally disable grafts because they can trigger early builds.
 (%graft? #f)
 
@@ -48,40 +51,33 @@
 
 (test-begin "pack")
 
-;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
-;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes.  Thus,
-;; run it on the user's store, if it's available, on the grounds that these
-;; dependencies may be already there, or we can get substitutes or build them
-;; quite inexpensively; see <https://bugs.gnu.org/32184>.
-
-(with-external-store store
-  (unless store (test-skip 1))
-  (test-assertm "self-contained-tarball" store
-    (mlet* %store-monad
-        ((profile (profile-derivation (packages->manifest
-                                       (list %bootstrap-guile))
-                                      #:hooks '()
-                                      #:locales? #f))
-         (tarball (self-contained-tarball "pack" profile
-                                          #:symlinks '(("/bin/Guile"
-                                                        -> "bin/guile"))
-                                          #:compressor %gzip-compressor
-                                          #:archiver %tar-bootstrap))
-         (check   (gexp->derivation
-                   "check-tarball"
-                   #~(let ((bin (string-append "." #$profile "/bin")))
-                       (setenv "PATH"
-                               (string-append #$%tar-bootstrap "/bin"))
-                       (system* "tar" "xvf" #$tarball)
-                       (mkdir #$output)
-                       (exit
-                        (and (file-exists? (string-append bin "/guile"))
-                             (string=? (string-append #$%bootstrap-guile "/bin")
-                                       (readlink bin))
-                             (string=? (string-append ".." #$profile
-                                                      "/bin/guile")
-                                       (readlink "bin/Guile"))))))))
-      (built-derivations (list check)))))
+(unless (network-reachable?) (test-skip 1))
+(test-assertm "self-contained-tarball" %store
+  (mlet* %store-monad
+      ((profile (profile-derivation (packages->manifest
+                                     (list %bootstrap-guile))
+                                    #:hooks '()
+                                    #:locales? #f))
+       (tarball (self-contained-tarball "pack" profile
+                                        #:symlinks '(("/bin/Guile"
+                                                      -> "bin/guile"))
+                                        #:compressor %gzip-compressor
+                                        #:archiver %tar-bootstrap))
+       (check   (gexp->derivation
+                 "check-tarball"
+                 #~(let ((bin (string-append "." #$profile "/bin")))
+                     (setenv "PATH"
+                             (string-append #$%tar-bootstrap "/bin"))
+                     (system* "tar" "xvf" #$tarball)
+                     (mkdir #$output)
+                     (exit
+                      (and (file-exists? (string-append bin "/guile"))
+                           (string=? (string-append #$%bootstrap-guile "/bin")
+                                     (readlink bin))
+                           (string=? (string-append ".." #$profile
+                                                    "/bin/guile")
+                                     (readlink "bin/Guile"))))))))
+    (built-derivations (list check))))
 
 (test-end)