[bug#49149] [PATCH 2/7] pack: Factorize base tar options.

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

* guix/docker.scm (%tar-determinism-options): Move to a new module and rename
to `tar-base-options'.  Adjust references accordingly.
* guix/build/pack.scm: New file.
* Makefile.am (MODULES): Register it.
* guix/scripts/pack.scm (self-contained-tarball/builder): Use it.
---
 Makefile.am           |  1 +
 guix/build/pack.scm   | 52 +++++++++++++++++++++++++++
 guix/docker.scm       | 20 ++---------
 guix/scripts/pack.scm | 81 +++++++++++++++++--------------------------
 4 files changed, 87 insertions(+), 67 deletions(-)
 create mode 100644 guix/build/pack.scm

diff --git a/Makefile.am b/Makefile.am
index aa21b5383b..9c4b33c77a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -220,6 +220,7 @@ MODULES =					\
   guix/build/linux-module-build-system.scm	\
   guix/build/store-copy.scm			\
   guix/build/json.scm				\
+  guix/build/pack.scm				\
   guix/build/utils.scm				\
   guix/build/union.scm				\
   guix/build/profiles.scm			\
diff --git a/guix/build/pack.scm b/guix/build/pack.scm
new file mode 100644
index 0000000000..05c7a3c594
--- /dev/null
+++ b/guix/build/pack.scm
@@ -0,0 +1,52 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build pack)
+  #:use-module (guix build utils)
+  #:export (tar-base-options))
+
+(define* (tar-base-options #:key tar compressor)
+  "Return the base GNU tar options required to produce deterministic archives
+deterministically.  When TAR, a GNU tar command file name, is provided, the
+`--sort' option is used only if supported.  When COMPRESSOR, a command such as
+'(\"gzip\" \"-9n\"), is provided, the compressor is explicitly specified via
+the `-I' option."
+  (define (tar-supports-sort? tar)
+    (zero? (system* tar "cf" "/dev/null" "--files-from=/dev/null"
+                    "--sort=name")))
+
+  `(,@(if compressor
+          (list "-I" (string-join compressor))
+          '())
+    ;; 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.
+    ,@(if (and=> tar tar-supports-sort?)
+          '("--sort=name")
+          '())
+    ;; Use GNU format so there's no file name length limitation.
+    "--format=gnu"
+    "--mtime=@1"
+    "--owner=root:0"
+    "--group=root:0"
+    ;; The 'nlink' of the store item files leads tar to store hard links
+    ;; instead of actual copies.  However, the 'nlink' count depends on
+    ;; deduplication in the store; it's an "implicit input" to the build
+    ;; process.  Use '--hard-dereference' to eliminate it.
+    "--hard-dereference"
+    "--check-links"))
diff --git a/guix/docker.scm b/guix/docker.scm
index 889aaeacb5..bd952e45ec 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -21,6 +21,7 @@
 (define-module (guix docker)
   #:use-module (gcrypt hash)
   #:use-module (guix base16)
+  #:use-module (guix build pack)
   #:use-module ((guix build utils)
                 #:select (mkdir-p
                           delete-file-recursively
@@ -110,18 +111,6 @@ Return a version of TAG that follows these rules."
     (rootfs . ((type . "layers")
                (diff_ids . #(,(layer-diff-id layer)))))))
 
-(define %tar-determinism-options
-  ;; GNU tar options to produce archives deterministically.
-  '("--sort=name" "--mtime=@1"
-    "--owner=root:0" "--group=root:0"
-
-    ;; When 'build-docker-image' is passed store items, the 'nlink' of the
-    ;; files therein leads tar to store hard links instead of actual copies.
-    ;; However, the 'nlink' count depends on deduplication in the store; it's
-    ;; an "implicit input" to the build process.  '--hard-dereference'
-    ;; eliminates it.
-    "--hard-dereference"))
-
 (define directive-file
   ;; Return the file or directory created by a 'evaluate-populate-directive'
   ;; directive.
@@ -238,7 +227,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
 
           (apply invoke "tar" "-cf" "../layer.tar"
                  `(,@transformation-options
-                   ,@%tar-determinism-options
+                   ,@(tar-base-options)
                    ,@paths
                    ,@(scandir "."
                               (lambda (file)
@@ -273,9 +262,6 @@ SRFI-19 time-utc object, as the creation time in metadata."
           (scm->json (repositories prefix id repository)))))
 
     (apply invoke "tar" "-cf" image "-C" directory
-           `(,@%tar-determinism-options
-             ,@(if compressor
-                   (list "-I" (string-join compressor))
-                   '())
+           `(,@(tar-base-options #:compressor compressor)
              "."))
     (delete-file-recursively directory)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index ac477850e6..d11f498925 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -205,12 +205,14 @@ dependencies are registered."
          (not (equal? '(guix store deduplication) module))))
 
   (with-imported-modules (source-module-closure
-                          `((guix build utils)
+                          `((guix build pack)
+                            (guix build utils)
                             (guix build union)
                             (gnu build install))
                           #:select? import-module?)
     #~(begin
-        (use-modules (guix build utils)
+        (use-modules (guix build pack)
+                     (guix build utils)
                      ((guix build union) #:select (relative-file-name))
                      (gnu build install)
                      (srfi srfi-1)
@@ -240,19 +242,10 @@ dependencies are registered."
           ;; 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")))
-
         ;; Make sure non-ASCII file names are properly handled.
         #+set-utf8-locale
 
-        ;; Add 'tar' to the search path.
-        (setenv "PATH" #+(file-append archiver "/bin"))
+        (define tar #+(file-append archiver "/bin/tar"))
 
         ;; Note: there is not much to gain here with deduplication and there
         ;; is the overhead of the '.links' directory, so turn it off.
@@ -269,45 +262,33 @@ dependencies are registered."
         (for-each (cut evaluate-populate-directive <> %root)
                   directives)
 
-        ;; Create the tarball.  Use GNU format so there's no file name
-        ;; length limitation.
+        ;; Create the tarball.
         (with-directory-excursion %root
-          (apply invoke "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")
-                 "--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)))))))
+          (apply invoke tar
+                 `(,@(tar-base-options
+                      #:tar tar
+                      #:compressor '#+(and=> compressor compressor-command))
+                   "-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))))))))
 
 (define* (self-contained-tarball name profile
                                  #:key target
-- 
2.32.0