pack: Move common build code to (guix build pack).

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.

Reviewed-by: Ludovic Courtès <ludo@gnu.org>

2 files changed, 240 insertions, 226 deletions

diff --git a/guix/build/pack.scm b/guix/build/pack.scm
index 3b73d1b227..fcb1da2a6c 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 <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,8 +17,25 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (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))
+
+;;; 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* (tar-base-options #:key tar compressor)
   "Return the base GNU tar options required to produce deterministic archives
@@ -52,3 +69,93 @@ the `-I' option."
     ;; 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 "
+  (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")
+
+  (when localstatedir?
+    (unless store-database
+      (error "missing STORE-DATABASE argument")))
+
+  (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")
+                                       localstatedir?
+                                       store-database
+                                       deduplicate?
+                                       symlinks
+                                       compressor-command)
+  "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."
+  (populate-profile-root profile
+                         #:profile-name profile-name
+                         #:localstatedir? localstatedir?
+                         #:store-database store-database
+                         #:deduplicate? deduplicate?
+                         #:symlinks symlinks)
+
+  (assert-utf8-locale)
+
+  ;; 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 0dc9979194..01995c48b7 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -72,6 +72,14 @@
             %formats
             guix-pack))
 
+;;; 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:
+
 ;; This one is only for use in this module, so don't put it in %compressors.
 (define bootstrap-xz
   (compressor "bootstrap-xz" ".xz"
@@ -197,153 +205,18 @@ target the profile's @file{bin/env} file:
   "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")
@@ -365,16 +238,48 @@ added to the pack."
     (warning (G_ "entry point not supported in the '~a' format~%")
              'tarball))
 
-  (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)))
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
+
+  (gexp->derivation
+   (string-append name ".tar" (compressor-extension compressor))
+   ;; XXX: The conditional around deduplicate? is to allow the test to run
+   ;; without an external store.
+   (with-extensions (if deduplicate? (list guile-gcrypt) '())
+     (with-imported-modules (let ((lst (source-module-closure
+                                        '((guix build pack)
+                                          (guix build utils))
+                                        #:select? not-config?)))
+                              (if deduplicate?
+                                  lst
+                                  (delete '(guix store deduplication) lst)))
+
+       (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)
+
+           (setenv "PATH" #+(file-append archiver "/bin"))
+
+           (build-self-contained-tarball #$profile
+                                         #$output
+                                         #:profile-name #$profile-name
+                                         #:localstatedir? #$localstatedir?
+                                         #:store-database #+database
+                                         #:deduplicate? #$deduplicate?
+                                         #:symlinks '#$symlinks
+                                         #:compressor-command
+                                         #+(and=> compressor
+                                                  compressor-command)))))
+   #:target target
+   #:references-graphs `(("profile" ,profile))))
 
 
 ;;;
@@ -719,20 +624,10 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors)))
     (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)
@@ -750,6 +645,9 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors)))
                          (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.
@@ -803,10 +701,26 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors)))
               (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))
+
+            (setenv "PATH" #+(file-append archiver "/bin"))
+
+            (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)
 
             ;; Generate the control archive.
             (let-keywords '#$extra-options #f
@@ -815,8 +729,7 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors)))
                            (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').
@@ -846,7 +759,7 @@ Section: misc
               (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") '())
@@ -857,7 +770,9 @@ Section: misc
                       "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))))
 
 
 ;;;
@@ -881,66 +796,27 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
   (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)
@@ -952,6 +828,35 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
             ;; 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)
@@ -979,7 +884,7 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
                              #: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)
@@ -989,7 +894,7 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
 
               (let ((header (generate-header name version
                                              payload-digest
-                                             #$root
+                                             %root
                                              #$(compressor-name compressor)
                                              #:target (or #$target %host-type)
                                              #:relocatable? relocatable?
@@ -1001,7 +906,7 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
                 (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))
@@ -1011,7 +916,7 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
                                       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)
@@ -1020,7 +925,9 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
                                                                    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))))
 
   
 ;;;