[PATCH 0/7] Add deb format for guix pack.

+++ b/guix/scripts/pack.scm

+

+;;;

+;;; Tarball format.

+;;;

+(define* (self-contained-tarball/builder profile

+                                         #:key (profile-name "guix-profile")

+                                         (compressor (first %compressors))

+                                         localstatedir?

+                                         (symlinks '())

+                                         (archiver tar))

+  "Return the G-Expression of the builder used for self-contained-tarball."

+  (with-imported-modules (source-module-closure

+                          `((guix build utils)

+                            (guix build union)

+                            (gnu build install))

+                          #:select? import-module?)

+    #~(begin

+        (use-modules (guix build utils)

+                     ((guix build union) #:select (relative-file-name))

+                     (gnu build install)

+                     (srfi srfi-1)

+                     (srfi srfi-26)

+                     (ice-9 match))

+

+        (define %root "root")

+

+        (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 ownnership 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)))

+                 (,source

+                  -> ,(relative-file-name parent target)))))))

+

+        (define directives

+          ;; 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"))

+

+        ;; Note: there is not much to gain here with deduplication and there

+        ;; is the overhead of the '.links' directory, so turn it off.

+        ;; 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-single-profile-directory %root

+                                           #:profile #$profile

+                                           #:profile-name #$profile-name

+                                           #:closure "profile"

+                                           #:database #+database)

+

+        ;; Create SYMLINKS.

+        (for-each (cut evaluate-populate-directive <> %root)

+                  directives)

+

+        ;; Create the tarball.  Use GNU format so there's no file name

+        ;; length limitation.

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

+(define* (self-contained-tarball name profile

+                                 #:key target

+                                 (profile-name "guix-profile")

+                                 deduplicate?

+                                 entry-point

+                                 (compressor (first %compressors))

+                                 localstatedir?

+                                 (symlinks '())

+                                 (archiver tar))

+  "Return a self-contained tarball containing a store initialized with the

+closure of PROFILE, a derivation.  The tarball contains /gnu/store; if

+LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db

+with a properly initialized store database.

+SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be

+added to the pack."

+  (gexp->derivation

+   (string-append name ".tar"

+                  (compressor-extension compressor))

+   (self-contained-tarball/builder profile

+                                   #:profile-name profile-name

+                                   #:compressor compressor

+                                   #:localstatedir? localstatedir?

+                                   #:symlinks symlinks

+                                   #:archiver archiver)

+   #:target target

+   #:references-graphs `(("profile" ,profile))))

+++ b/guix/build-system/cargo.scm

+                         ,@native-inputs

+                        ,@(if target '() inputs)))

+++ b/guix/build/cargo-build-system.scm

+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>

+  #:use-module ((guix build utils) #:hide (delete))

+            cargo-build

+

+            rust-version

+            rust-library-prefix))

+(define (rust-version rust)

+  "Return the version triplet (major.minor.patch) as a string, given RUST, a

+store file name."

+  (let* ((version     (last (string-split rust #\-)))

+         (components  (string-split version #\.))

+         (major+minor+patch (take components 3)))

+    (string-join major+minor+patch ".")))

+

+(define (rust-library-prefix/relative inputs)

+  "Return the relative versioned Rust library prefix where Rust libraries are

+to be installed."

+  (string-append "lib/rust/" (rust-version (assoc-ref inputs "rustc"))))

+

+(define (rust-library-prefix inputs outputs)

+  "Return the absolute versioned Rust library prefix where Rust libraries are

+to be installed."

+  (string-append (assoc-ref outputs "out") "/"

+                 (rust-library-prefix/relative inputs)))

+

+(define (rlib? file)

+  "Check if FILE has the .rlib extension."

+  (string-suffix? ".rlib" file))

+

+(define (inputs->directories inputs)

+  "Extract the directory part from INPUTS."

+  (match inputs

+    (((names . directories) ...)

+     directories)))

+

+(define* (populate-cargo-cache #:key inputs outputs #:allow-other-keys)

+  "Populate the 'target/release' directory with any pre-built Rust libraries,

+to avoid rebuilding them from sources when possible."

+  (let* ((rust-lib-prefix (rust-library-prefix/relative inputs))

+         (input-dirs (inputs->directories inputs))

+         (rust-lib-dirs (filter (lambda (f)

+                                  (file-exists? (string-append

+                                                 f "/" rust-lib-prefix)))

+                                input-dirs))

+         (rlibs (delete-duplicates (append-map (cut find-files <> "\\.rlib$")

+                                               rust-lib-dirs))))

+    (pk 'rust-lib-dirs rust-lib-dirs)

+    (pk 'rlibs rlibs)

+    (for-each (cut install-file <> "target/release") rlibs)

+    (invoke "find" "target")))

+

+         (sources  (string-append out "/share/cargo/src"))

+         (libdir   (rust-library-prefix inputs outputs))

+         (release-dir "target/release"))

+    (unless skip-build?

+      ;; Install binaries.

+      (when (has-executable-target?)

+        (apply invoke "cargo" "install" "--no-track" "--path" "." "--root" out

+               (if (not (null? features))

+                   (list "--features" (string-join features))

+                   '())))

+      ;; Install static libraries.

+      (for-each (lambda (file)

+                  (install-file (string-append release-dir "/" file) libdir))

+                (scandir release-dir (cut string-suffix? ".rlib" <>))))

+    (add-before 'build 'populate-cargo-cache populate-cargo-cache)

+++ b/Makefile.am

+  guix/build/pack.scm				\

+++ b/guix/build/pack.scm

+;;; 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"))

+++ b/guix/docker.scm

+  #:use-module (guix build pack)

+                   ,@(tar-base-options)

+           `(,@(tar-base-options #:compressor compressor)

+++ b/guix/scripts/pack.scm

+                          `((guix build pack)

+                            (guix build utils)

+        (use-modules (guix build pack)

+                     (guix build utils)

+        (define tar #+(file-append archiver "/bin/tar"))

+        ;; Create the tarball.

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

+++ b/guix/scripts/pack.scm

+               ;; preserve its ownership when extracting the archive (see

+++ b/guix/scripts/pack.scm

+;;; XXX: The following procedure has to *also* be used in the build side

+;;; G-Exp, because PROFILE is passed as a derivation in the tests.

+(define define-manifest->friendly-name

+  '(define (manifest->friendly-name manifest)

+     "Return a friendly name computed from the entries in MANIFEST, a

+<manifest> object."

+     (let loop ((names (map manifest-entry-name

+                            (manifest-entries manifest))))

+       (define str (string-join names "-"))

+       (if (< (string-length str) 40)

+           str

+           (match names

+             ((_) str)

+             ((names ... _) (loop names))))))) ;drop one entry

+

+(eval define-manifest->friendly-name (current-module))

+

+  (define defmod 'define-module)        ;trick Geiser

+            #$define-manifest->friendly-name

+

+                                #:repository (manifest->friendly-name

+                                              (profile-manifest #$profile))

+                                    (locales? (not bootstrap?))))

+                   (name (string-append (manifest->friendly-name manifest)

+                                        "-" (symbol->string pack-format)

+                                        "-pack")))

+++ b/gnu/system/file-systems.scm

+            reduce-directories

+  "Return #t if FILE1 denotes the name of a file that is a parent of FILE2.

+For example:

+  (let loop ((file1 (string-tokenize file1 %not-slash))

+             (file2 (string-tokenize file2 %not-slash)))

+    (match file1

+      (()

+       #t)

+      ((head1 tail1 ...)

+       (match file2

+         ((head2 tail2 ...)

+          (and (string=? head1 head2) (loop tail1 tail2)))

+         (()

+          #f))))))

+

+(define (file-name-depth file-name)

+  (length (string-tokenize file-name %not-slash)))

+

+(define (reduce-directories file-names)

+  "Eliminate entries in FILE-NAMES that are children of other entries in

+FILE-NAMES.  This is for example useful when passing a list of files to GNU

+tar, which would otherwise descend into each directory passed and archive the

+duplicate files as hard links, which can be undesirable."

+  (let* ((file-names/sorted

+          ;; Ascending sort by file hierarchy depth, then by file name length.

+          (stable-sort (delete-duplicates file-names)

+                       (lambda (f1 f2)

+                         (let ((depth1 (file-name-depth f1))

+                               (depth2 (file-name-depth f2)))

+                           (if (= depth1 depth2)

+                               (string< f1 f2)

+                               (< depth1 depth2)))))))

+    (reverse (fold (lambda (file-name results)

+                     (if (find (cut file-prefix? <> file-name) results)

+                         results        ;parent found -- skipping

+                         (cons file-name results)))

+                   '()

+                   file-names/sorted))))

+++ b/guix/scripts/pack.scm

+                            (gnu build install)

+                            (gnu system file-systems))

+                     ((gnu system file-systems) #:select (reduce-directories))

+                   ,@(reduce-directories

+++ b/tests/file-systems.scm

+;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>

+(test-equal "reduce-directories"

+  '("./opt/gnu/" "./opt/gnuism" "a/b/c")

+  (reduce-directories '("./opt/gnu/etc" "./opt/gnu/" "./opt/gnu/bin"

+                        "./opt/gnu/lib/debug" "./opt/gnuism" "a/b/c" "a/b/c")))

+

+++ b/tests/pack.scm

+   ".gz"

+++ b/.dir-locals.el

+   (eval . (put 'gexp->derivation 'scheme-indent-function 1))

+++ b/doc/guix.texi

+@item deb

+This produces a Debian archive (a package with the @samp{.deb} file

+extension) containing all the specified binaries and symlinks, that can

+be installed on top of any dpkg-based GNU/Linux distribution.

+

+++ b/guix/scripts/pack.scm

+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>

+            debian-archive

+

+;;;

+;;; Singularity.

+;;;

+

+;;;

+;;; SquashFS image format.

+;;;

+

+;;;

+;;; Docker image format.

+;;;

+

+;;;

+;;; Debian archive format.

+;;;

+;;; TODO: When relocatable option is selected, install to a unique prefix.

+;;; This would enable installation of multiple deb packs with conflicting

+;;; files at the same time.

+;;; TODO: Allow passing a custom control file from the CLI.

+;;; TODO: Allow providing a postinst script.

+(define* (debian-archive name profile

+                         #:key target

+                         (profile-name "guix-profile")

+                         deduplicate?

+                         entry-point

+                         (compressor (first %compressors))

+                         localstatedir?

+                         (symlinks '())

+                         (archiver tar))

+  "Return a Debian archive (.deb) containing a store initialized with the

+closure of PROFILE, a derivation.  The archive contains /gnu/store; if

+LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db

+with a properly initialized store database.  The supported compressors are

+\"none\", \"gz\" or \"xz\".

+

+SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be

+added to the pack."

+  ;; For simplicity, limit the supported compressors to the superset of

+  ;; compressors able to compress both the control file (gz or xz) and the

+  ;; data tarball (gz, bz2 or xz).

+  (define %valid-compressors '("gzip" "xz" "none"))

+

+  (let ((compressor-name (compressor-name compressor)))

+    (unless (member compressor-name %valid-compressors)

+      (leave (G_ "~a is not a valid Debian archive compressor.  \

+Valid compressors are: ~a~%") compressor-name %valid-compressors)))

+

+  (when entry-point

+    (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

+                    #:profile-name profile-name

+                    #:compressor compressor

+                    #:localstatedir? localstatedir?

+                    #:symlinks symlinks

+                    #:archiver archiver)

+                   #:local-build? #f    ;allow offloading

+                   #:options (list #:references-graphs `(("profile" ,profile))

+                                   #:target target)))

+

+  (define build

+    (with-extensions (list guile-gcrypt)

+      (with-imported-modules `(((guix config) => ,(make-config.scm))

+                               ,@(source-module-closure

+                                  `((guix build pack)

+                                    (guix build utils)

+                                    (guix profiles))

+                                  #:select? not-config?))

+        #~(begin

+            (use-modules (guix build pack)

+                         (guix build utils)

+                         (guix profiles)

+                         (ice-9 match)

+                         (srfi srfi-1))

+

+            (define machine-type

+              ;; Extract the machine type from the specified target, else from the

+              ;; current system.

+              (and=> (or #$target %host-type) (lambda (triplet)

+                                              (first (string-split triplet #\-)))))

+

+            (define (gnu-machine-type->debian-machine-type type)

+              "Translate machine TYPE from the GNU to Debian terminology."

+              ;; Debian has its own jargon, different from the one used in GNU, for

+              ;; machine types (see data/cputable in the sources of dpkg).

+              (match type

+                ("i686" "i386")

+                ("x86_64" "amd64")

+                ("aarch64" "arm64")

+                ("mipsisa32r6" "mipsr6")

+                ("mipsisa32r6el" "mipsr6el")

+                ("mipsisa64r6" "mips64r6")

+                ("mipsisa64r6el" "mips64r6el")

+                ("powerpcle" "powerpcel")

+                ("powerpc64" "ppc64")

+                ("powerpc64le" "ppc64el")

+                (machine machine)))

+

+            (define architecture

+              (gnu-machine-type->debian-machine-type machine-type))

+

+            #$define-manifest->friendly-name

+

+            (define manifest (profile-manifest #$profile))

+

+            (define single-entry        ;manifest entry

+              (match (manifest-entries manifest)

+                ((entry)

+                 entry)

+                (() #f)))

+

+            (define package-name (or (and=> single-entry manifest-entry-name)

+                                     (manifest->friendly-name manifest)))

+

+            (define package-version

+              (or (and=> single-entry manifest-entry-version)

+                  "0.0.0"))

+

+            (define debian-format-version "2.0")

+

+            ;; Generate the debian-binary file.

+            (call-with-output-file "debian-binary"

+              (lambda (port)

+                (format port "~a~%" debian-format-version)))

+

+            (define data-tarball-file-name (strip-store-file-name

+                                            #+data-tarball))

+

+            (copy-file #+data-tarball data-tarball-file-name)

+

+            (define control-tarball-file-name

+              (string-append "control.tar"

+                             #$(compressor-extension compressor)))

+

+            ;; Write the compressed control tarball.  Only the control file is

+            ;; mandatory (see: 'man deb' and 'man deb-control').

+            (call-with-output-file "control"

+              (lambda (port)

+                (format port "\

+Package: ~a

+Version: ~a

+Description: Debian archive generated by GNU Guix.

+Maintainer: GNU Guix

+Architecture: ~a

+~%" package-name package-version architecture)))

+

+            (define tar (string-append #+archiver "/bin/tar"))

+

+            (apply invoke tar

+                   `(,@(tar-base-options

+                        #:tar tar

+                        #:compressor '#+(and=> compressor compressor-command))

+                     "-cvf" ,control-tarball-file-name

+                     "control"))

+

+            ;; Create the .deb archive using GNU ar.

+            (invoke (string-append #+binutils "/bin/ar") "-rv" #$output

+                    "debian-binary"

+                    control-tarball-file-name data-tarball-file-name)))))

+

+  (gexp->derivation (string-append name ".deb")

+    build

+    #:target target

+    #:references-graphs `(("profile" ,profile))))

+

+    (docker  . ,docker-image)

+    (deb . ,debian-archive)))

+  (display (G_ "

+  deb           Debian archive compatible, installable via dpkg/apt"))

+++ b/tests/pack.scm

+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>

+  #:use-module ((gnu packages debian) #:select (dpkg))

+(define %ar-bootstrap %bootstrap-binutils)

+

+      (built-derivations (list check))))

+

+  (unless store (test-skip 1))

+  (test-assertm "deb archive with symlinks" store

+    (mlet* %store-monad

+        ((guile   (set-guile-for-build (default-guile)))

+         (profile (profile-derivation (packages->manifest

+                                       (list %bootstrap-guile))

+                                      #:hooks '()

+                                      #:locales? #f))

+         (deb (debian-archive "deb-pack" profile

+                              #:compressor %gzip-compressor

+                              #:symlinks '(("/opt/gnu/bin" -> "bin"))

+                              #:archiver %tar-bootstrap))

+         (check

+          (gexp->derivation "check-deb-pack"

+            (with-imported-modules '((guix build utils))

+              #~(begin

+                  (use-modules (guix build utils)

+                               (ice-9 match)

+                               (ice-9 popen)

+                               (ice-9 rdelim)

+                               (ice-9 textual-ports)

+                               (rnrs base))

+

+                  (setenv "PATH" (string-join

+                                  (list (string-append #+%tar-bootstrap "/bin")

+                                        (string-append #+dpkg "/bin")

+                                        (string-append #+%ar-bootstrap "/bin"))

+                                  ":"))

+

+                  ;; Validate the output of 'dpkg --info'.

+                  (let* ((port (open-pipe* OPEN_READ "dpkg" "--info" #$deb))

+                         (info (get-string-all port))

+                         (exit-val (status:exit-val (close-pipe port))))

+                    (assert (zero? exit-val))

+

+                    (assert (string-contains

+                             info

+                             (string-append "Package: "

+                                            #+(package-name %bootstrap-guile))))

+

+                    (assert (string-contains

+                             info

+                             (string-append "Version: "

+                                            #+(package-version %bootstrap-guile)))))

+

+                  ;; Sanity check .deb contents.

+                  (invoke "ar" "-xv" #$deb)

+                  (assert (file-exists? "debian-binary"))

+                  (assert (file-exists? "data.tar.gz"))

+                  (assert (file-exists? "control.tar.gz"))

+

+                  ;; Verify there are no hard links in data.tar.gz, as hard

+                  ;; links would cause dpkg to fail unpacking the archive.

+                  (define hard-links

+                    (let ((port (open-pipe* OPEN_READ "tar" "-tvf" "data.tar.gz")))

+                      (let loop ((hard-links '()))

+                        (match (pk 'line (read-line port))

+                          ((? eof-object?)

+                           (assert (zero? (status:exit-val (close-pipe port))))

+                           hard-links)

+                          (line

+                           (if (string-prefix? "u" line)

+                               (loop (cons line hard-links))

+                               (loop hard-links)))))))

+

+                  (unless (null? hard-links)

+                    (error "hard links found in data.tar.gz" hard-links))

+

+                  (mkdir #$output))))))

+++ b/guix/scripts/pack.scm

+

+;;;

+;;; Tarball format.

+;;;

+(define* (self-contained-tarball/builder profile

+                                         #:key (profile-name "guix-profile")

+                                         (compressor (first %compressors))

+                                         localstatedir?

+                                         (symlinks '())

+                                         (archiver tar))

+  "Return the G-Expression of the builder used for self-contained-tarball."

+  (with-imported-modules (source-module-closure

+                          `((guix build utils)

+                            (guix build union)

+                            (gnu build install))

+                          #:select? import-module?)

+    #~(begin

+        (use-modules (guix build utils)

+                     ((guix build union) #:select (relative-file-name))

+                     (gnu build install)

+                     (srfi srfi-1)

+                     (srfi srfi-26)

+                     (ice-9 match))

+

+        (define %root "root")

+

+        (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 ownnership 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)))

+                 (,source

+                  -> ,(relative-file-name parent target)))))))

+

+        (define directives

+          ;; 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"))

+

+        ;; Note: there is not much to gain here with deduplication and there

+        ;; is the overhead of the '.links' directory, so turn it off.

+        ;; 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-single-profile-directory %root

+                                           #:profile #$profile

+                                           #:profile-name #$profile-name

+                                           #:closure "profile"

+                                           #:database #+database)

+

+        ;; Create SYMLINKS.

+        (for-each (cut evaluate-populate-directive <> %root)

+                  directives)

+

+        ;; Create the tarball.  Use GNU format so there's no file name

+        ;; length limitation.

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

+(define* (self-contained-tarball name profile

+                                 #:key target

+                                 (profile-name "guix-profile")

+                                 deduplicate?

+                                 entry-point

+                                 (compressor (first %compressors))

+                                 localstatedir?

+                                 (symlinks '())

+                                 (archiver tar))

+  "Return a self-contained tarball containing a store initialized with the

+closure of PROFILE, a derivation.  The tarball contains /gnu/store; if

+LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db

+with a properly initialized store database.

+SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be

+added to the pack."

+  (gexp->derivation

+   (string-append name ".tar"

+                  (compressor-extension compressor))

+   (self-contained-tarball/builder profile

+                                   #:profile-name profile-name

+                                   #:compressor compressor

+                                   #:localstatedir? localstatedir?

+                                   #:symlinks symlinks

+                                   #:archiver archiver)

+   #:target target

+   #:references-graphs `(("profile" ,profile))))

+++ b/Makefile.am

+  guix/build/pack.scm				\

+++ b/guix/build/pack.scm

+;;; 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"))

+++ b/guix/docker.scm

+  #:use-module (guix build pack)

+                   ,@(tar-base-options)

+           `(,@(tar-base-options #:compressor compressor)

+++ b/guix/scripts/pack.scm

+                          `((guix build pack)

+                            (guix build utils)

+        (use-modules (guix build pack)

+                     (guix build utils)

+        (define tar #+(file-append archiver "/bin/tar"))

+        ;; Create the tarball.

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

+++ b/guix/scripts/pack.scm

+               ;; preserve its ownership when extracting the archive (see

+++ b/guix/scripts/pack.scm

+(define-syntax-rule (define-with-source (variable args ...) body body* ...)

+  "Bind VARIABLE to a procedure accepting ARGS defined as BODY, also setting

+its source property."

+  (begin

+    (define (variable args ...)

+      body)

+    (eval-when (load eval)

+      (set-procedure-property! variable 'source

+                               '(define (variable args ...) body body* ...)))))

+

+(define-with-source (manifest->friendly-name manifest)

+  "Return a friendly name computed from the entries in MANIFEST, a

+<manifest> object."

+  (let loop ((names (map manifest-entry-name

+                         (manifest-entries manifest))))

+    (define str (string-join names "-"))

+    (if (< (string-length str) 40)

+        str

+        (match names

+          ((_) str)

+          ((names ... _) (loop names))))))

+

+  (define defmod 'define-module)        ;trick Geiser

+            #$(procedure-source manifest->friendly-name)

+

+                                #:repository (manifest->friendly-name

+                                              (profile-manifest #$profile))

+                                    (locales? (not bootstrap?))))

+                   (name (string-append (manifest->friendly-name manifest)

+                                        "-" (symbol->string pack-format)

+                                        "-pack")))

+++ b/gnu/system/file-systems.scm

+            reduce-directories

+  "Return #t if FILE1 denotes the name of a file that is a parent of FILE2.

+For example: