Subject: [PATCH] pack: Move common build code to (guix build pack).
From: Maxim Cournoyer <[email-masked]>
To: [email-masked]
Cc: Maxim Cournoyer <[email-masked]>
Date: Fri, 3 Mar 2023 22:15:23 -0500
List-Id: <debbugs-submit.debbugs.gnu.org>

The rationale is to reduce the number of derivations built per pack to ideally
one, to minimize storage requirements.  The number of derivations had gone up
with 68380db4 ("pack: Extract populate-profile-root from
self-contained-tarball/builder.") as a side effect to improving code reuse.

* guix/scripts/pack.scm (guix): Add commentary comment.
(populate-profile-root, self-contained-tarball/builder): Extract to...
* guix/build/pack.scm (populate-profile-root!): ... this, and...
(build-self-contained-tarball): ... that, adjusting for use on the build side.
(assert-utf8-locale): New procedure.
(self-contained-tarball, debian-archive, rpm-archive): Adjust accordingly.
---
 guix/build/pack.scm   | 115 +++++++++++++-
 guix/scripts/pack.scm | 341 +++++++++++++++---------------------------
 tests/pack.scm        | 104 ++++++-------
 3 files changed, 284 insertions(+), 276 deletions(-)

diff --git a/guix/build/pack.scm b/guix/build/pack.scm
index 3b73d1b227..fa9a5f5905 100644
--- a/guix/build/pack.scm
+++ b/guix/build/pack.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Maxim Cournoyer <[email-masked]>
+;;; Copyright © 2021, 2023 Maxim Cournoyer <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -16,9 +16,26 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
+;;; Commentary:
+
+;;; This module contains build-side common procedures used by the host-side
+;;; (guix scripts pack) module, mostly to allow for code reuse.  Due to making
+;;; use of the (guix build store-copy) module, it transitively requires the
+;;; sqlite and gcrypt extensions to be available.
+
+;;; Code:
+
 (define-module (guix build pack)
+  #:use-module (gnu build install)
   #:use-module (guix build utils)
-  #:export (tar-base-options))
+  #:use-module (guix build store-copy)
+  #:use-module ((guix build union) #:select (relative-file-name))
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (tar-base-options
+            populate-profile-root!
+            build-self-contained-tarball))
 
 (define* (tar-base-options #:key tar compressor)
   "Return the base GNU tar options required to produce deterministic archives
@@ -52,3 +69,97 @@ (define (tar-supports-sort? tar)
     ;; process.  Use '--hard-dereference' to eliminate it.
     "--hard-dereference"
     "--check-links"))
+
+(define (assert-utf8-locale)
+  "Verify the current process is using the en_US.utf8 locale."
+  (unless (string=? "unset for tests" (getenv "GUIX_LOCPATH"))
+    (unless (false-if-exception (setlocale LC_ALL "en_US.utf8"))
+      (error "environment not configured for en_US.utf8 locale"))))
+
+(define* (populate-profile-root! profile
+                                 #:key (profile-name "guix-profile")
+                                 localstatedir?
+                                 store-database
+                                 deduplicate?
+                                 (symlinks '()))
+  "Populate the root profile directory with SYMLINKS and a Guix database, when
+LOCALSTATEDIR? is set, and a pre-computed STORE-DATABASE is provided.  The
+directory is created as \"root\" in the current working directory.  When
+DEDUPLICATE? is true, deduplicate the store items, which relies on hard
+links.  It needs to run in an environment where "
+  (when localstatedir?
+    (unless store-database
+      (error "missing STORE-DATABASE argument")))
+
+  (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 ownership 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)))
+           ;; Use a relative file name for compatibility with
+           ;; relocatable packs.
+           (,source -> ,(relative-file-name parent target)))))))
+
+  (define directives
+    ;; Fully-qualified symlinks.
+    (append-map symlink->directives symlinks))
+
+  (define %root "root")
+
+  (assert-utf8-locale)
+
+  ;; Note: there is not much to gain here with deduplication and there
+  ;; is the overhead of the '.links' directory, so turn it off by
+  ;; default.  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-store (list "profile") %root #:deduplicate? deduplicate?)
+
+  (when localstatedir?
+    (install-database-and-gc-roots %root store-database
+                                   profile #:profile-name profile-name))
+
+  ;; Create SYMLINKS.
+  (for-each (cut evaluate-populate-directive <> %root) directives))
+
+(define* (build-self-contained-tarball profile
+                                       tarball-file-name
+                                       #:key (profile-name "guix-profile")
+                                       target
+                                       localstatedir?
+                                       store-database
+                                       deduplicate?
+                                       symlinks
+                                       compressor-command
+                                       archiver)
+  "Create a self-contained tarball TARBALL-FILE-NAME from PROFILE, optionally
+compressing it with COMPRESSOR-COMMAND, the complete command-line string to
+use for the compressor."
+  (assert-utf8-locale)
+
+  (populate-profile-root! profile
+                          #:profile-name profile-name
+                          #:localstatedir? localstatedir?
+                          #:store-database store-database
+                          #:deduplicate? deduplicate?
+                          #:symlinks symlinks)
+
+  (define tar (string-append archiver "/bin/tar"))
+
+  ;; GNU Tar recurses directories by default.  Simply add the whole root
+  ;; directory, which contains all the files to be archived.  This avoids
+  ;; creating duplicate files in the archives that would be stored as hard
+  ;; links by GNU Tar.
+  (apply invoke tar "-cvf" tarball-file-name "-C" "root" "."
+         (tar-base-options
+          #:tar tar
+          #:compressor compressor-command)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index eb41eb5563..984622bd16 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -24,6 +24,14 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
+;;; Commentary:
+
+;;; This module implements the 'guix pack' command and the various supported
+;;; formats.  Where feasible, the builders of the packs should be implemented
+;;; as single derivations to minimize storage requirements.
+
+;;; Code:
+
 (define-module (guix scripts pack)
   #:use-module (guix scripts)
   #:use-module (guix ui)
@@ -199,153 +207,18 @@ (define (set-utf8-locale profile)
   "Configure the environment to use the \"en_US.utf8\" locale provided by the
 GLIBC-UT8-LOCALES package."
   ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'.
-  (and (or (not (profile? profile))
-           (profile-locales? profile))
-       #~(begin
-           (setenv "GUIX_LOCPATH"
-                   #+(file-append glibc-utf8-locales "/lib/locale"))
-           (setlocale LC_ALL "en_US.utf8"))))
-
-(define* (populate-profile-root profile
-                                #:key (profile-name "guix-profile")
-                                target
-                                localstatedir?
-                                deduplicate?
-                                (symlinks '()))
-  "Populate the root profile directory with SYMLINKS and a Guix database, when
-LOCALSTATEDIR? is set.  When DEDUPLICATE? is true, deduplicate the store
-items, which relies on hard links."
-  (define database
-    (and localstatedir?
-         (file-append (store-database (list profile))
-                      "/db/db.sqlite")))
-
-  (define bootstrap?
-    ;; Whether a '--bootstrap' environment is needed, for testing purposes.
-    ;; XXX: Infer that from available info.
-    (and (not database) (not (profile-locales? profile))))
-
-  (define (import-module? module)
-    ;; Since we don't use deduplication support in 'populate-store', don't
-    ;; import (guix store deduplication) and its dependencies, which includes
-    ;; Guile-Gcrypt, unless DEDUPLICATE? is #t.  This makes it possible to run
-    ;; tests with '--bootstrap'.
-    (and (not-config? module)
-         (or deduplicate? (not (equal? '(guix store deduplication) module)))))
-
-  (computed-file "profile-directory"
-    (with-imported-modules (source-module-closure
-                            `((guix build pack)
-                              (guix build store-copy)
-                              (guix build utils)
-                              (guix build union)
-                              (gnu build install))
-                            #:select? import-module?)
+  (if (or (not (profile? profile))
+          (profile-locales? profile))
       #~(begin
-          (use-modules (guix build pack)
-                       (guix build store-copy)
-                       (guix build utils)
-                       ((guix build union) #:select (relative-file-name))
-                       (gnu build install)
-                       (srfi srfi-1)
-                       (srfi srfi-26)
-                       (ice-9 match))
-
-          (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 ownership 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)))
-                   ;; Use a relative file name for compatibility with
-                   ;; relocatable packs.
-                   (,source -> ,(relative-file-name parent target)))))))
-
-          (define directives
-            ;; Fully-qualified symlinks.
-            (append-map symlink->directives '#$symlinks))
-
-          ;; Make sure non-ASCII file names are properly handled.
-          #+(set-utf8-locale profile)
-
-          ;; Note: there is not much to gain here with deduplication and there
-          ;; is the overhead of the '.links' directory, so turn it off by
-          ;; default.  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-store (list "profile") #$output
-                          #:deduplicate? #$deduplicate?)
-
-          (when #+localstatedir?
-            (install-database-and-gc-roots #$output #+database #$profile
-                                           #:profile-name #$profile-name))
-
-          ;; Create SYMLINKS.
-          (for-each (cut evaluate-populate-directive <> #$output)
-                    directives)))
-    #:local-build? #f
-    #:guile (if bootstrap? %bootstrap-guile (default-guile))
-    #:options (list #:references-graphs `(("profile" ,profile))
-                    #:target target)))
+          (setenv "GUIX_LOCPATH"
+                  #+(file-append glibc-utf8-locales "/lib/locale"))
+          (setlocale LC_ALL "en_US.utf8"))
+      #~(setenv "GUIX_LOCPATH" "unset for tests")))
 
 
 ;;;
 ;;; Tarball format.
 ;;;
-(define* (self-contained-tarball/builder profile
-                                         #:key (profile-name "guix-profile")
-                                         target
-                                         localstatedir?
-                                         deduplicate?
-                                         symlinks
-                                         compressor
-                                         archiver)
-  "Return a GEXP that can build a self-contained tarball."
-
-  (define root (populate-profile-root profile
-                                      #:profile-name profile-name
-                                      #:target target
-                                      #:localstatedir? localstatedir?
-                                      #:deduplicate? deduplicate?
-                                      #:symlinks symlinks))
-
-  (with-imported-modules (source-module-closure '((guix build pack)
-                                                  (guix build utils)))
-    #~(begin
-        (use-modules (guix build pack)
-                     (guix build utils))
-
-        ;; Make sure non-ASCII file names are properly handled.
-        #+(set-utf8-locale profile)
-
-        (define tar #+(file-append archiver "/bin/tar"))
-
-        (define %root (if #$localstatedir? "." #$root))
-
-        (when #$localstatedir?
-          ;; Fix the permission of the Guix database file, which was made
-          ;; read-only when copied to the store in populate-profile-root.
-          (copy-recursively #$root %root)
-          (chmod (string-append %root "/var/guix/db/db.sqlite") #o644))
-
-        (with-directory-excursion %root
-          ;; GNU Tar recurses directories by default.  Simply add the whole
-          ;; current directory, which contains all the files to be archived.
-          ;; This avoids creating duplicate files in the archives that would
-          ;; be stored as hard links by GNU Tar.
-          (apply invoke tar "-cvf" #$output "."
-                 (tar-base-options
-                  #:tar tar
-                  #:compressor #+(and=> compressor compressor-command)))))))
-
 (define* (self-contained-tarball name profile
                                  #:key target
                                  (profile-name "guix-profile")
@@ -367,16 +240,39 @@ (define* (self-contained-tarball name profile
     (warning (G_ "entry point not supported in the '~a' format~%")
              'tarball))
 
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
+
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
-    (self-contained-tarball/builder profile
-                                    #:profile-name profile-name
-                                    #:target target
-                                    #:localstatedir? localstatedir?
-                                    #:deduplicate? deduplicate?
-                                    #:symlinks symlinks
-                                    #:compressor compressor
-                                    #:archiver archiver)))
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules `(((guix config) => ,(make-config.scm))
+                               ,@(source-module-closure
+                                  `((guix build pack)
+                                    (guix build utils))
+                                  #:select? not-config?))
+        #~(begin
+            (use-modules (guix build pack)
+                         (guix build utils))
+
+            ;; Make sure non-ASCII file names are properly handled.
+            #+(set-utf8-locale profile)
+
+            (build-self-contained-tarball #$profile
+                                          #$output
+                                          #:profile-name #$profile-name
+                                          #:target #$target
+                                          #:localstatedir? #$localstatedir?
+                                          #:store-database #+database
+                                          #:deduplicate? #$deduplicate?
+                                          #:symlinks '#$symlinks
+                                          #:compressor-command
+                                          #+(and=> compressor compressor-command)
+                                          #:archiver #+archiver))))
+    #:target target
+    #:references-graphs `(("profile" ,profile))))
 
 
 ;;;
@@ -721,20 +617,10 @@ (define %valid-compressors '("gzip" "xz" "none"))
     (warning (G_ "entry point not supported in the '~a' format~%")
              'deb))
 
-  (define data-tarball
-    (computed-file (string-append "data.tar" (compressor-extension
-                                              compressor))
-      (self-contained-tarball/builder profile
-                                      #:target target
-                                      #:profile-name profile-name
-                                      #:localstatedir? localstatedir?
-                                      #:deduplicate? deduplicate?
-                                      #:symlinks symlinks
-                                      #:compressor compressor
-                                      #:archiver archiver)
-      #:local-build? #f                 ;allow offloading
-      #:options (list #:references-graphs `(("profile" ,profile))
-                      #:target target)))
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
 
   (define build
     (with-extensions (list guile-gcrypt)
@@ -752,6 +638,9 @@ (define build
                          (ice-9 optargs)
                          (srfi srfi-1))
 
+            ;; Make sure non-ASCII file names are properly handled.
+            #+(set-utf8-locale profile)
+
             (define machine-type
               ;; Extract the machine type from the specified target, else from the
               ;; current system.
@@ -805,10 +694,25 @@ (define debian-format-version "2.0")
               (lambda (port)
                 (format port "~a~%" debian-format-version)))
 
-            (define data-tarball-file-name (strip-store-file-name
-                                            #+data-tarball))
+            (define compressor-command
+              #+(and=> compressor compressor-command))
 
-            (copy-file #+data-tarball data-tarball-file-name)
+            (define compressor-extension
+              #+(compressor-extension compressor))
+
+            (define data-tarball-file-name
+              (string-append "data.tar" compressor-extension))
+
+            (build-self-contained-tarball #$profile
+                                          data-tarball-file-name
+                                          #:profile-name #$profile-name
+                                          #:localstatedir? #$localstatedir?
+                                          #:store-database #+database
+                                          #:deduplicate? #$deduplicate?
+                                          #:symlinks '#$symlinks
+                                          #:compressor-command
+                                          compressor-command
+                                          #:archiver #+archiver)
 
             ;; Generate the control archive.
             (let-keywords '#$extra-options #f
@@ -817,8 +721,7 @@ (define data-tarball-file-name (strip-store-file-name
                            (triggers-file #f))
 
               (define control-tarball-file-name
-                (string-append "control.tar"
-                               #$(compressor-extension compressor)))
+                (string-append "control.tar" compressor-extension))
 
               ;; Write the compressed control tarball.  Only the control file is
               ;; mandatory (see: 'man deb' and 'man deb-control').
@@ -848,7 +751,7 @@ (define tar (string-append #+archiver "/bin/tar"))
               (apply invoke tar
                      `(,@(tar-base-options
                           #:tar tar
-                          #:compressor #+(and=> compressor compressor-command))
+                          #:compressor compressor-command)
                        "-cvf" ,control-tarball-file-name
                        "control"
                        ,@(if postinst-file '("postinst") '())
@@ -859,7 +762,9 @@ (define tar (string-append #+archiver "/bin/tar"))
                       "debian-binary"
                       control-tarball-file-name data-tarball-file-name))))))
 
-  (gexp->derivation (string-append name ".deb") build))
+  (gexp->derivation (string-append name ".deb") build
+                    #:target target
+                    #:references-graphs `(("profile" ,profile))))
 
 
 ;;;
@@ -883,66 +788,27 @@ (define* (rpm-archive name profile
   (when entry-point
     (warning (G_ "entry point not supported in the '~a' format~%") 'rpm))
 
-  (define root (populate-profile-root profile
-                                      #:profile-name profile-name
-                                      #:target target
-                                      #:localstatedir? localstatedir?
-                                      #:deduplicate? deduplicate?
-                                      #:symlinks symlinks))
-
-  (define payload
-    (let* ((raw-cpio-file-name "payload.cpio")
-           (compressed-cpio-file-name (string-append raw-cpio-file-name
-                                                     (compressor-extension
-                                                      compressor))))
-      (computed-file compressed-cpio-file-name
-        (with-imported-modules (source-module-closure
-                                '((guix build utils)
-                                  (guix cpio)
-                                  (guix rpm)))
-          #~(begin
-              (use-modules (guix build utils)
-                           (guix cpio)
-                           (guix rpm)
-                           (srfi srfi-1))
-
-              ;; Make sure non-ASCII file names are properly handled.
-              #+(set-utf8-locale profile)
-
-              (define %root (if #$localstatedir? "." #$root))
-
-              (when #$localstatedir?
-                ;; Fix the permission of the Guix database file, which was made
-                ;; read-only when copied to the store in populate-profile-root.
-                (copy-recursively #$root %root)
-                (chmod (string-append %root "/var/guix/db/db.sqlite") #o644))
-
-              (call-with-output-file #$raw-cpio-file-name
-                (lambda (port)
-                  (with-directory-excursion %root
-                    ;; The first "." entry is discarded.
-                    (write-cpio-archive
-                     (remove fhs-directory?
-                             (cdr (find-files "." #:directories? #t)))
-                     port))))
-              (when #+(compressor-command compressor)
-                (apply invoke (append #+(compressor-command compressor)
-                                      (list #$raw-cpio-file-name))))
-              (copy-file #$compressed-cpio-file-name #$output)))
-        #:local-build? #f)))            ;allow offloading
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
 
   (define build
     (with-extensions (list guile-gcrypt)
       (with-imported-modules `(((guix config) => ,(make-config.scm))
                                ,@(source-module-closure
                                   `((gcrypt hash)
+                                    (guix build pack)
                                     (guix build utils)
+                                    (guix cpio)
                                     (guix profiles)
                                     (guix rpm))
                                   #:select? not-config?))
         #~(begin
             (use-modules (gcrypt hash)
+                         (guix build pack)
                          (guix build utils)
+                         (guix cpio)
                          (guix profiles)
                          (guix rpm)
                          (ice-9 binary-ports)
@@ -954,6 +820,35 @@ (define build
             ;; Make sure non-ASCII file names are properly handled.
             #+(set-utf8-locale profile)
 
+            (define %root "root")
+
+            (populate-profile-root! #$profile
+                                    #:profile-name #$profile-name
+                                    #:localstatedir? #$localstatedir?
+                                    #:store-database #+database
+                                    #:deduplicate? #$deduplicate?
+                                    #:symlinks '#$symlinks)
+
+            (define raw-cpio-file-name "payload.cpio")
+
+            ;; Generate CPIO payload.
+            (call-with-output-file raw-cpio-file-name
+              (lambda (port)
+                (with-directory-excursion %root
+                  ;; The first "." entry is discarded.
+                  (write-cpio-archive
+                   (remove fhs-directory?
+                           (cdr (find-files "." #:directories? #t)))
+                   port))))
+
+            (when #+(compressor-command compressor)
+              (apply invoke (append #+(compressor-command compressor)
+                                    (list raw-cpio-file-name))))
+
+            (define cpio-file-name
+              (string-append "payload.cpio"
+                             #$(compressor-extension compressor)))
+
             (define machine-type
               (and=> (or #$target %host-type)
                      (lambda (triplet)
@@ -981,7 +876,7 @@ (define lead
                              #:target (or #$target %host-type)))
 
             (define payload-digest
-              (bytevector->hex-string (file-sha256 #$payload)))
+              (bytevector->hex-string (file-sha256 cpio-file-name)))
 
             (let-keywords '#$extra-options #f ((relocatable? #f)
                                                (prein-file #f)
@@ -991,7 +886,7 @@ (define payload-digest
 
               (let ((header (generate-header name version
                                              payload-digest
-                                             #$root
+                                             %root
                                              #$(compressor-name compressor)
                                              #:target (or #$target %host-type)
                                              #:relocatable? relocatable?
@@ -1003,7 +898,7 @@ (define payload-digest
                 (define header-sha256
                   (bytevector->hex-string (sha256 (u8-list->bytevector header))))
 
-                (define payload-size (stat:size (stat #$payload)))
+                (define payload-size (stat:size (stat cpio-file-name)))
 
                 (define header+compressed-payload-size
                   (+ (length header) payload-size))
@@ -1013,7 +908,7 @@ (define signature
                                       header+compressed-payload-size))
 
                 ;; Serialize the archive components to a file.
-                (call-with-input-file #$payload
+                (call-with-input-file cpio-file-name
                   (lambda (in)
                     (call-with-output-file #$output
                       (lambda (out)
@@ -1022,7 +917,9 @@ (define signature
                                                                    header))
                         (sendfile out in payload-size)))))))))))
 
-  (gexp->derivation (string-append name ".rpm") build))
+  (gexp->derivation (string-append name ".rpm") build
+                    #:target target
+                    #:references-graphs `(("profile" ,profile))))
 
   
 ;;;
diff --git a/tests/pack.scm b/tests/pack.scm
index 87187bb62c..397fb37b12 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -76,64 +76,64 @@ (define rpm-for-tests
 
 (test-begin "pack")
 
-(unless (network-reachable?) (test-skip 1))
-(test-assertm "self-contained-tarball" %store
-  (mlet* %store-monad
-      ((profile -> (profile
-                    (content (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"
-                  (with-imported-modules '((guix build utils))
-                    #~(begin
-                        (use-modules (guix build utils)
-                                     (srfi srfi-1))
-
-                        (define store
-                          ;; The unpacked store.
-                          (string-append "." (%store-directory) "/"))
-
-                        (define (canonical? file)
-                          ;; Return #t if FILE is read-only and its mtime is 1.
-                          (let ((st (lstat file)))
-                            (or (not (string-prefix? store file))
-                                (eq? 'symlink (stat:type st))
-                                (and (= 1 (stat:mtime st))
-                                     (zero? (logand #o222
-                                                    (stat:mode st)))))))
-
-                        (define 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"))
-                              (file-exists? store)
-                              (every canonical?
-                                     (find-files "." (const #t)
-                                                 #:directories? #t))
-                              (string=? (string-append #$%bootstrap-guile "/bin")
-                                        (readlink bin))
-                              (string=? (string-append ".." #$profile
-                                                       "/bin/guile")
-                                        (readlink "bin/Guile")))))))))
-    (built-derivations (list check))))
-
 ;; 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
+        ((guile   (set-guile-for-build (default-guile)))
+         (profile -> (profile
+                      (content (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"
+                    (with-imported-modules '((guix build utils))
+                      #~(begin
+                          (use-modules (guix build utils)
+                                       (srfi srfi-1))
+
+                          (define store
+                            ;; The unpacked store.
+                            (string-append "." (%store-directory) "/"))
+
+                          (define (canonical? file)
+                            ;; Return #t if FILE is read-only and its mtime is 1.
+                            (let ((st (lstat file)))
+                              (or (not (string-prefix? store file))
+                                  (eq? 'symlink (stat:type st))
+                                  (and (= 1 (stat:mtime st))
+                                       (zero? (logand #o222
+                                                      (stat:mode st)))))))
+
+                          (define 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"))
+                                (file-exists? store)
+                                (every canonical?
+                                       (find-files "." (const #t)
+                                                   #:directories? #t))
+                                (string=? (string-append #$%bootstrap-guile "/bin")
+                                          (readlink bin))
+                                (string=? (string-append ".." #$profile
+                                                         "/bin/guile")
+                                          (readlink "bin/Guile")))))))))
+      (built-derivations (list check))))
+
   (unless store (test-skip 1))
   (test-assertm "self-contained-tarball + localstatedir" store
     (mlet* %store-monad

base-commit: 89e5f3f3847b3bfd507ea9f0874a73f99a53cbf9
-- 
2.39.1