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>

1 files changed, 109 insertions, 2 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)))