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)))