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

DoneSubmitted by Maxim Cournoyer.
Details
5 participants
  • jgart
  • Ludovic Courtès
  • Maxim Cournoyer
  • Maxime Devos
  • zimoun
Owner
unassigned
Severity
normal
M
M
Maxim Cournoyer wrote on 21 Jun 2021 08:10
(address . guix-patches@gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210621061039.31557-1-maxim.cournoyer@gmail.com
Hello Guix!

This patch set adds support to produce Debian archives (.deb packages) via
guix pack. It's rudimentary but functional. You can try a simple example
like so:

$ ./pre-inst-env guix pack -f deb -C xz hello -S /usr/bin/hello=bin/hello

Copy the generated .deb to your dpkg-based distribution of choice, then:

$ sudo apt install ./91ypmi1j5py9qk034kki5wrgy0n52yz9-hello-deb-pack.deb

$ realpath $(which hello)
/gnu/store/lk9cmjjhgxpkxxi7m54y0jlv3rqvpb2n-hello-2.10/bin/hello
$ hello
Hello, world!

Fun, no? We can now distribute software built with Guix transparently to any
Debian-based distribution.

Maxim Cournoyer (7):
pack: Extract builder code from self-contained-tarball.
pack: Factorize base tar options.
pack: Fix typo.
pack: Improve naming of the packs store file names.
pack: Prevent duplicate files in tar archives.
tests: pack: Fix compressor extension.
pack: Add support for the deb format.

.dir-locals.el | 1 +
Makefile.am | 1 +
doc/guix.texi | 5 +
gnu/system/file-systems.scm | 56 +++--
guix/build/pack.scm | 52 ++++
guix/docker.scm | 20 +-
guix/scripts/pack.scm | 471 +++++++++++++++++++++++++-----------
tests/file-systems.scm | 7 +-
tests/pack.scm | 77 +++++-
9 files changed, 506 insertions(+), 184 deletions(-)
create mode 100644 guix/build/pack.scm

--
2.32.0
M
M
Maxim Cournoyer wrote on 21 Jun 2021 08:11
[PATCH 1/7] pack: Extract builder code from self-contained-tarball.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210621061205.31878-1-maxim.cournoyer@gmail.com
This is made to allow reusing it for the debian-archive pack format, added in
a subsequent commit.

* guix/scripts/pack.scm (self-contained-tarball/builder): New procedure,
containing the build code extracted from self-contained-tarball.
(self-contained-tarball): Use the above procedure.
---
guix/scripts/pack.scm | 270 ++++++++++++++++++++++--------------------
1 file changed, 141 insertions(+), 129 deletions(-)

Toggle diff (296 lines)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 8cb4e6d2cc..ac477850e6 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -172,22 +172,17 @@ dependencies are registered."
   (computed-file "store-database" build
                  #:options `(#:references-graphs ,(zip labels items))))
 
-(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."
+
+;;;
+;;; 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."
   (define database
     (and localstatedir?
          (file-append (store-database (list profile))
@@ -209,125 +204,142 @@ added to the pack."
     (and (not-config? module)
          (not (equal? '(guix store deduplication) module))))
 
-  (define build
-    (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))
+  (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 %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
-            (exit
-             (zero? (apply system* "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")
-                           "--mtime=@1"           ;for files in /var/guix
-                           "--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."
   (when entry-point
     (warning (G_ "entry point not supported in the '~a' format~%")
              'tarball))
 
-  (gexp->derivation (string-append name ".tar"
-                                   (compressor-extension compressor))
-                    build
-                    #:target target
-                    #:references-graphs `(("profile" ,profile))))
+  (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))))
 
 (define (singularity-environment-file profile)
   "Return a shell script that defines the environment variables corresponding
-- 
2.32.0
M
M
Maxim Cournoyer wrote on 21 Jun 2021 08:11
[PATCH] tentatively reuse rlib for cargo-build-system
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210621061205.31878-2-maxim.cournoyer@gmail.com
---
guix/build-system/cargo.scm | 3 +-
guix/build/cargo-build-system.scm | 78 ++++++++++++++++++++++++++-----
2 files changed, 68 insertions(+), 13 deletions(-)

Toggle diff (168 lines)
diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm
index e53d2a7523..9ef9f6b149 100644
--- a/guix/build-system/cargo.scm
+++ b/guix/build-system/cargo.scm
@@ -271,7 +271,8 @@ any dependent crates. This can be a benefits:
          (build-inputs `(("cargo" ,rust "cargo")
                          ("rustc" ,rust)
                          ,@(expand-crate-sources cargo-inputs cargo-development-inputs)
-                         ,@native-inputs))
+                         ,@native-inputs
+                        ,@(if target '() inputs)))
          (outputs outputs)
          (build cargo-build)
          (arguments (strip-keyword-arguments private-keywords arguments)))))
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index 0a95672b00..e68f20e463 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2019, 2020, 2021 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;; Copyright © 2020 Marius Bakke <marius@gnu.org>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,7 +25,7 @@
 (define-module (guix build cargo-build-system)
   #:use-module ((guix build gnu-build-system) #:prefix gnu:)
   #:use-module (guix build json)
-  #:use-module (guix build utils)
+  #:use-module ((guix build utils) #:hide (delete))
   #:use-module (guix build cargo-utils)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
@@ -34,7 +35,10 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (%standard-phases
-            cargo-build))
+            cargo-build
+
+            rust-version
+            rust-library-prefix))
 
 ;; Commentary:
 ;;
@@ -42,6 +46,25 @@
 ;;
 ;; Code:
 
+(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 (manifest-targets)
   "Extract all targets from the Cargo.toml manifest"
   (let* ((port (open-input-pipe "cargo read-manifest"))
@@ -73,6 +96,16 @@ Cargo.toml file present at its root."
                                             " | cut -d/ -f2"
                                             " | grep -q '^Cargo.toml$'")))))
 
+(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* (unpack-rust-crates #:key inputs vendor-dir #:allow-other-keys)
   (define (inputs->rust-inputs inputs)
     "Filter using the label part from INPUTS."
@@ -80,11 +113,6 @@ Cargo.toml file present at its root."
               (match input
                 ((name . _) (rust-package? name))))
             inputs))
-  (define (inputs->directories inputs)
-    "Extract the directory part from INPUTS."
-    (match inputs
-      (((names . directories) ...)
-       directories)))
 
   (let ((rust-inputs (inputs->directories (inputs->rust-inputs inputs))))
     (unless (null? rust-inputs)
@@ -185,6 +213,22 @@ directory = '" port)
   (generate-all-checksums vendor-dir)
   #t)
 
+(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")))
+
 (define* (build #:key
                 skip-build?
                 (features '())
@@ -228,7 +272,9 @@ directory = '" port)
   "Install a given Cargo package."
   (let* ((out      (assoc-ref outputs "out"))
          (registry (string-append out "/share/cargo/registry"))
-         (sources  (string-append out "/share/cargo/src")))
+         (sources  (string-append out "/share/cargo/src"))
+         (libdir   (rust-library-prefix inputs outputs))
+         (release-dir "target/release"))
     (mkdir-p out)
 
     ;; Make cargo reuse all the artifacts we just built instead
@@ -237,10 +283,17 @@ directory = '" port)
 
     ;; Only install crates which include binary targets,
     ;; otherwise cargo will raise an error.
-    (or skip-build?
-        (not (has-executable-target?))
-        (invoke "cargo" "install" "--no-track" "--path" "." "--root" out
-                "--features" (string-join features)))
+    (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" <>))))
 
     (when install-source?
       ;; Install crate tarballs and unpacked sources for later use.
@@ -260,6 +313,7 @@ directory = '" port)
   (modify-phases gnu:%standard-phases
     (delete 'bootstrap)
     (replace 'configure configure)
+    (add-before 'build 'populate-cargo-cache populate-cargo-cache)
     (replace 'build build)
     (replace 'check check)
     (replace 'install install)
-- 
2.31.1
M
M
Maxim Cournoyer wrote on 21 Jun 2021 08:12
[PATCH 2/7] pack: Factorize base tar options.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210621061205.31878-3-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

Toggle diff (237 lines)
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
M
M
Maxim Cournoyer wrote on 21 Jun 2021 08:12
[PATCH 3/7] pack: Fix typo.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210621061205.31878-4-maxim.cournoyer@gmail.com
* guix/scripts/pack.scm (self-contained-tarball/builder): Fix typo.
---
guix/scripts/pack.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)

Toggle diff (15 lines)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index d11f498925..7ea97a4b7a 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -229,7 +229,7 @@ dependencies are registered."
              (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
+               ;; 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 "/")
-- 
2.32.0
M
M
Maxim Cournoyer wrote on 21 Jun 2021 08:12
[PATCH 4/7] pack: Improve naming of the packs store file names.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210621061205.31878-5-maxim.cournoyer@gmail.com
Instead of just naming them by their pack type, add information from the
package(s) they contain to make it easier to differentiate them.

* guix/scripts/pack.scm (manifest->friendly-name): Extract procedure from ...
(docker-image): ... here. Adjust REPOSITORY argument value accordingly.
(guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME.
---
guix/scripts/pack.scm | 44 +++++++++++++++++++++++++------------------
1 file changed, 26 insertions(+), 18 deletions(-)

Toggle diff (99 lines)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 7ea97a4b7a..9d4bb9f497 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -172,6 +172,23 @@ dependencies are registered."
   (computed-file "store-database" build
                  #:options `(#:references-graphs ,(zip labels items))))
 
+;;; 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))
+
 
 ;;;
 ;;; Tarball format.
@@ -540,7 +557,7 @@ the image."
          (file-append (store-database (list profile))
                       "/db/db.sqlite")))
 
-  (define defmod 'define-module)                  ;trick Geiser
+  (define defmod 'define-module)        ;trick Geiser
 
   (define build
     ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
@@ -558,6 +575,8 @@ the image."
                          (srfi srfi-1) (srfi srfi-19)
                          (ice-9 match))
 
+            #$define-manifest->friendly-name
+
             (define environment
               (map (match-lambda
                      ((spec . value)
@@ -581,19 +600,6 @@ the image."
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
-            (define tag
-              ;; Compute a meaningful "repository" name, which will show up in
-              ;; the output of "docker images".
-              (let ((manifest (profile-manifest #$profile)))
-                (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
-
             (setenv "PATH" #+(file-append archiver "/bin"))
 
             (build-docker-image #$output
@@ -601,7 +607,8 @@ the image."
                                      (call-with-input-file "profile"
                                        read-reference-graph))
                                 #$profile
-                                #:repository tag
+                                #:repository (manifest->friendly-name
+                                              (profile-manifest #$profile))
                                 #:database #+database
                                 #:system (or #$target %host-type)
                                 #:environment environment
@@ -1209,8 +1216,6 @@ Create a bundle of PACKAGE.\n"))
                                        manifest)
                                       manifest)))
                    (pack-format (assoc-ref opts 'format))
-                   (name        (string-append (symbol->string pack-format)
-                                               "-pack"))
                    (target      (assoc-ref opts 'target))
                    (bootstrap?  (assoc-ref opts 'bootstrap?))
                    (compressor  (if bootstrap?
@@ -1244,7 +1249,10 @@ Create a bundle of PACKAGE.\n"))
                                     (hooks (if bootstrap?
                                                '()
                                                %default-profile-hooks))
-                                    (locales? (not bootstrap?)))))
+                                    (locales? (not bootstrap?))))
+                   (name (string-append (manifest->friendly-name manifest)
+                                        "-" (symbol->string pack-format)
+                                        "-pack")))
               (define (lookup-package package)
                 (manifest-lookup manifest (manifest-pattern (name package))))
 
-- 
2.32.0
M
M
Maxim Cournoyer wrote on 21 Jun 2021 08:12
[PATCH 5/7] pack: Prevent duplicate files in tar archives.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210621061205.31878-6-maxim.cournoyer@gmail.com
Tar translate duplicate files in the archive into hard links. These can cause
problems, as not every tool support them; for example dpkg doesn't.

* gnu/system/file-systems.scm (reduce-directories): New procedure.
(file-prefix?): Lift the restriction on file prefix. The procedure can be
useful for comparing relative file names. Adjust doc.
(file-name-depth): New procedure, extracted from ...
(btrfs-store-subvolume-file-name): ... here.
* guix/scripts/pack.scm (self-contained-tarball/builder): Use
reduce-directories.
* tests/file-systems.scm ("reduce-directories"): New test.
---
gnu/system/file-systems.scm | 56 +++++++++++++++++++++++++------------
guix/scripts/pack.scm | 6 ++--
tests/file-systems.scm | 7 ++++-
3 files changed, 48 insertions(+), 21 deletions(-)

Toggle diff (144 lines)
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 464e87cb18..fb87bfc85b 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -55,6 +55,7 @@
             file-system-dependencies
             file-system-location
 
+            reduce-directories
             file-system-type-predicate
             btrfs-subvolume?
             btrfs-store-subvolume-file-name
@@ -231,8 +232,8 @@
   (char-set-complement (char-set #\/)))
 
 (define (file-prefix? file1 file2)
-  "Return #t if FILE1 denotes the name of a file that is a parent of FILE2,
-where both FILE1 and FILE2 are absolute file name.  For example:
+  "Return #t if FILE1 denotes the name of a file that is a parent of FILE2.
+For example:
 
   (file-prefix? \"/gnu\" \"/gnu/store\")
   => #t
@@ -240,19 +241,41 @@ where both FILE1 and FILE2 are absolute file name.  For example:
   (file-prefix? \"/gn\" \"/gnu/store\")
   => #f
 "
-  (and (string-prefix? "/" file1)
-       (string-prefix? "/" file2)
-       (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)))))))
+  (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))))
 
 (define* (file-system-device->string device #:key uuid-type)
   "Return the string representations of the DEVICE field of a <file-system>
@@ -624,9 +647,6 @@ store is located, else #f."
         s
         (string-append "/" s)))
 
-  (define (file-name-depth file-name)
-    (length (string-tokenize file-name %not-slash)))
-
   (and-let* ((btrfs-subvolume-fs (filter btrfs-subvolume? file-systems))
              (btrfs-subvolume-fs*
               (sort btrfs-subvolume-fs
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 9d4bb9f497..8a108b7a1a 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -225,13 +225,15 @@ dependencies are registered."
                           `((guix build pack)
                             (guix build utils)
                             (guix build union)
-                            (gnu build install))
+                            (gnu build install)
+                            (gnu system file-systems))
                           #:select? import-module?)
     #~(begin
         (use-modules (guix build pack)
                      (guix build utils)
                      ((guix build union) #:select (relative-file-name))
                      (gnu build install)
+                     ((gnu system file-systems) #:select (reduce-directories))
                      (srfi srfi-1)
                      (srfi srfi-26)
                      (ice-9 match))
@@ -298,7 +300,7 @@ dependencies are registered."
 
                    ,(string-append "." (%store-directory))
 
-                   ,@(delete-duplicates
+                   ,@(reduce-directories
                       (filter-map (match-lambda
                                     (('directory directory)
                                      (string-append "." directory))
diff --git a/tests/file-systems.scm b/tests/file-systems.scm
index 7f7c373884..80acb6d5b9 100644
--- a/tests/file-systems.scm
+++ b/tests/file-systems.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -50,6 +50,11 @@
                    (device "/foo")
                    (flags '(bind-mount read-only)))))))))
 
+(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")))
+
 (test-assert "does not pull (guix config)"
   ;; This module is meant both for the host side and "build side", so make
   ;; sure it doesn't pull in (guix config), which depends on the user's
-- 
2.32.0
M
M
Maxim Cournoyer wrote on 21 Jun 2021 08:12
[PATCH 6/7] tests: pack: Fix compressor extension.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210621061205.31878-7-maxim.cournoyer@gmail.com
* tests/pack.scm (%gzip-compressor): Add the missing leading period to the
gzip compressor file extension.
---
tests/pack.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)

Toggle diff (15 lines)
diff --git a/tests/pack.scm b/tests/pack.scm
index e8455b4f37..ae6247a1d5 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -51,7 +51,7 @@
 (define %gzip-compressor
   ;; Compressor that uses the bootstrap 'gzip'.
   ((@ (guix scripts pack) compressor) "gzip"
-   "gz"
+   ".gz"
    #~(#+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n")))
 
 (define %tar-bootstrap %bootstrap-coreutils&co)
-- 
2.32.0
M
M
Maxim Cournoyer wrote on 21 Jun 2021 08:12
[PATCH 7/7] pack: Add support for the deb format.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210621061205.31878-8-maxim.cournoyer@gmail.com
* .dir-locals.el (scheme-mode)[gexp->derivation]: Define indentation rule.
* guix/scripts/pack.scm (debian-archive): New procedure.
(%formats): Register the new deb format.
(show-formats): Add it to the usage string.
* tests/pack.scm (%ar-bootstrap): New variable.
(deb archive with symlinks): New test.
* doc/guix.texi (Invoking guix pack): Document it.
---
.dir-locals.el | 1 +
doc/guix.texi | 5 ++
guix/scripts/pack.scm | 178 +++++++++++++++++++++++++++++++++++++++++-
tests/pack.scm | 75 ++++++++++++++++++
4 files changed, 258 insertions(+), 1 deletion(-)

Toggle diff (375 lines)
diff --git a/.dir-locals.el b/.dir-locals.el
index 8f07a08eb5..a4fcbfe7ca 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -75,6 +75,7 @@
    (eval . (put 'origin 'scheme-indent-function 0))
    (eval . (put 'build-system 'scheme-indent-function 0))
    (eval . (put 'bag 'scheme-indent-function 0))
+   (eval . (put 'gexp->derivation 'scheme-indent-function 1))
    (eval . (put 'graft 'scheme-indent-function 0))
    (eval . (put 'operating-system 'scheme-indent-function 0))
    (eval . (put 'file-system 'scheme-indent-function 0))
diff --git a/doc/guix.texi b/doc/guix.texi
index 0930a514c7..7fb8d8e9d2 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6016,6 +6016,11 @@ This produces a SquashFS image containing all the specified binaries and
 symlinks, as well as empty mount points for virtual file systems like
 procfs.
 
+@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.
+
 @quotation Note
 Singularity @emph{requires} you to provide @file{/bin/sh} in the image.
 For that reason, @command{guix pack -f squashfs} always implies @code{-S
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 8a108b7a1a..18f003dec0 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -65,6 +66,7 @@
             %compressors
             lookup-compressor
             self-contained-tarball
+            debian-archive
             docker-image
             squashfs-image
 
@@ -341,6 +343,10 @@ added to the pack."
    #:target target
    #:references-graphs `(("profile" ,profile))))
 
+
+;;;
+;;; Singularity.
+;;;
 (define (singularity-environment-file profile)
   "Return a shell script that defines the environment variables corresponding
 to the search paths of PROFILE."
@@ -367,6 +373,10 @@ to the search paths of PROFILE."
 
   (computed-file "singularity-environment.sh" build))
 
+
+;;;
+;;; SquashFS image format.
+;;;
 (define* (squashfs-image name profile
                          #:key target
                          (profile-name "guix-profile")
@@ -541,6 +551,10 @@ added to the pack."
                     #:target target
                     #:references-graphs `(("profile" ,profile))))
 
+
+;;;
+;;; Docker image format.
+;;;
 (define* (docker-image name profile
                        #:key target
                        (profile-name "guix-profile")
@@ -628,6 +642,165 @@ the image."
                     #:target target
                     #:references-graphs `(("profile" ,profile))))
 
+
+;;;
+;;; 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))))
+
 
 ;;;
 ;;; Compiling C programs.
@@ -960,7 +1133,8 @@ last resort for relocation."
   ;; Supported pack formats.
   `((tarball . ,self-contained-tarball)
     (squashfs . ,squashfs-image)
-    (docker  . ,docker-image)))
+    (docker  . ,docker-image)
+    (deb . ,debian-archive)))
 
 (define (show-formats)
   ;; Print the supported pack formats.
@@ -972,6 +1146,8 @@ last resort for relocation."
   squashfs      Squashfs image suitable for Singularity"))
   (display (G_ "
   docker        Tarball ready for 'docker load'"))
+  (display (G_ "
+  deb           Debian archive compatible, installable via dpkg/apt"))
   (newline))
 
 (define %options
diff --git a/tests/pack.scm b/tests/pack.scm
index ae6247a1d5..ed461c6887 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,6 +33,7 @@
   #:use-module ((gnu packages base) #:select (glibc-utf8-locales))
   #:use-module (gnu packages bootstrap)
   #:use-module ((gnu packages compression) #:select (squashfs-tools))
+  #:use-module ((gnu packages debian) #:select (dpkg))
   #:use-module ((gnu packages guile) #:select (guile-sqlite3))
   #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
   #:use-module (srfi srfi-64))
@@ -56,6 +58,8 @@
 
 (define %tar-bootstrap %bootstrap-coreutils&co)
 
+(define %ar-bootstrap %bootstrap-binutils)
+
 
 (test-begin "pack")
 
@@ -270,6 +274,77 @@
                                                  1)
                                                 (pk 'guilelink (readlink "bin"))))
                              (mkdir #$output))))))))
+      (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))))))
       (built-derivations (list check)))))
 
 (test-end)
-- 
2.32.0
J
Re: Add deb format for guix pack.
(address . 49149@debbugs.gnu.org)
e728e0e80c559ba22531136994fb7c8c@dismail.de
This is awesome!

Are you working on adding a-packs support for alpine linux also?
M
M
Maxime Devos wrote on 21 Jun 2021 20:11
Re: [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names.
66838991d056aed2ab4c198e27df0a7fa4357a74.camel@telenet.be
Maxim Cournoyer schreef op ma 21-06-2021 om 02:12 [-0400]:
Toggle quote (25 lines)
> Instead of just naming them by their pack type, add information from the
> package(s) they contain to make it easier to differentiate them.
>
> * guix/scripts/pack.scm (manifest->friendly-name): Extract procedure from ...
> (docker-image): ... here. Adjust REPOSITORY argument value accordingly.
> (guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME.
> ---
> guix/scripts/pack.scm | 44 +++++++++++++++++++++++++------------------
> 1 file changed, 26 insertions(+), 18 deletions(-)
>
> diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
> index 7ea97a4b7a..9d4bb9f497 100644
> --- a/guix/scripts/pack.scm
> +++ b/guix/scripts/pack.scm
> @@ -172,6 +172,23 @@ dependencies are registered."
> (computed-file "store-database" build
> #:options `(#:references-graphs ,(zip labels items))))
>
> +;;; 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) [...]))
>
> +(eval define-manifest->friendly-name (current-module))

You can avoid 'eval' here by defining 'manifest->friendly-name
in a separate guix/build/pack-utils.scm module.
Alternatively, some macroology (untested, may need some tweaks):

(define-syntax define-gexp-and-expand
((_ variable code code* ...)
(begin (define variable #~(code code* ...))
code code* ...)))

(define-gexp-and-expand define-manifest->friendly-name
(define (manifest->friendly-name manifest)
[... docstring]
[... all the code]))

Greetings,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYNDWahccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7sKxAQDOdX1PX0MmtaFSPl8V6yx9Sv5L
kGup4xyOdCTbBlwpowEAm5Lca5nSDDBNkZOxPp0rTHfYlq/fWDzyA2aEJ3iyIAs=
=0UGz
-----END PGP SIGNATURE-----


M
M
Maxim Cournoyer wrote on 21 Jun 2021 22:28
Re: [PATCH] tentatively reuse rlib for cargo-build-system
(address . 49149@debbugs.gnu.org)
87k0mnynbf.fsf@gmail.com
Hello,

This one can be safely ignored; it was a stray .patch file in my tree
that I sent erroneously with this series.

Thanks,

Maxim
M
M
Maxim Cournoyer wrote on 22 Jun 2021 16:03
Re: [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names.
(name . Maxime Devos)(address . maximedevos@telenet.be)(address . 49149@debbugs.gnu.org)
87k0mm2dzu.fsf@gmail.com
Hello Maxime,

Maxime Devos <maximedevos@telenet.be> writes:

Toggle quote (30 lines)
> Maxim Cournoyer schreef op ma 21-06-2021 om 02:12 [-0400]:
>> Instead of just naming them by their pack type, add information from the
>> package(s) they contain to make it easier to differentiate them.
>>
>> * guix/scripts/pack.scm (manifest->friendly-name): Extract procedure from ...
>> (docker-image): ... here. Adjust REPOSITORY argument value accordingly.
>> (guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME.
>> ---
>> guix/scripts/pack.scm | 44 +++++++++++++++++++++++++------------------
>> 1 file changed, 26 insertions(+), 18 deletions(-)
>>
>> diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
>> index 7ea97a4b7a..9d4bb9f497 100644
>> --- a/guix/scripts/pack.scm
>> +++ b/guix/scripts/pack.scm
>> @@ -172,6 +172,23 @@ dependencies are registered."
>> (computed-file "store-database" build
>> #:options `(#:references-graphs ,(zip labels items))))
>>
>> +;;; 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) [...]))
>>
>> +(eval define-manifest->friendly-name (current-module))
>
> You can avoid 'eval' here by defining 'manifest->friendly-name
> in a separate guix/build/pack-utils.scm module.
> Alternatively, some macroology (untested, may need some tweaks):

Thanks for the feedback! I tried moving 'manifest->friendly-name' to
(guix build pack), which was already added in an earlier commit, but
that didn't work because (guix profiles) needs to be pulled in for
'manifest-entries' and 'manifest-entry-name', and sadly (guix profiles)
pulls (guix config), which is not possible/desirable on the build side.

Toggle quote (10 lines)
> (define-syntax define-gexp-and-expand
> ((_ variable code code* ...)
> (begin (define variable #~(code code* ...))
> code code* ...)))
>
> (define-gexp-and-expand define-manifest->friendly-name
> (define (manifest->friendly-name manifest)
> [... docstring]
> [... all the code]))

I'm not sure how the expansion would be usable in the module it is
defined? It seems I could manage to get 'manifest->friendly-name' to be
a procedure returning a gexp, but that gexp wouldn't be readily usable
in that module (it could only be used when gexp-unquote from inside
another G-Exp), and the expansion in the macro above doesn't bind any
identifier, unless I'm missing something?

So for now, I'm stuck with the eval, which doesn't seem to bad
considering it's only evaluating a safe, static expression.

Thank you,

Maxim
M
M
Maxime Devos wrote on 23 Jun 2021 12:22
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)(address . 49149@debbugs.gnu.org)
a3a2895d9404098862d34813015bd0e8f3c30be3.camel@telenet.be
Toggle quote (7 lines)
> I'm not sure how the expansion would be usable in the module it is
> defined? It seems I could manage to get 'manifest->friendly-name' to be
> a procedure returning a gexp, but that gexp wouldn't be readily usable
> in that module (it could only be used when gexp-unquote from inside
> another G-Exp), and the expansion in the macro above doesn't bind any
> identifier, unless I'm missing something?

The macro does two things: define a procedure manifest->friendly-name
that returns a string.

(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

and also define a G-exp define-manifest->friendly-name

(define define-manifest->friendly-nam
#~(define (manifest->friendly-name manifes)
"Return a friendly name [...]"
[...])

Testing from a REPL:

$ guix repl
(use-modules (guix gexp) (ice-9 match) (guix profiles))

(define-syntax define-gexp-and-expand
(syntax-rules ()
((_ variable code) ; code* ... turned out to be unnecessary
(begin (define variable #~code)
code))))

(define-gexp-and-expand 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
$ define-manifest->friendly-name
$3 = #<gexp (define (manifest->friendly-name manifest) "Return a friendly name computed from the entries in MANIFEST, a\n <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)))))) 7f4b3c5ee5a0>
$ (manifest->friendly-name (specifications->manifest '("guile")))
$8 = "guile"

Seems to work.

Greetings,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYNMLVhccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7t+vAP9V6t+VgIHZi2Q79PbvjrE7cZH+
HuBJMOsVL76Fv4agIAD/SUeCv2g3AabvZHLKdYs1ukN17fvvjXLh19w9EnP9YQA=
=/wKG
-----END PGP SIGNATURE-----


L
L
Ludovic Courtès wrote on 23 Jun 2021 23:16
Re: bug#49149: [PATCH 0/7] Add deb format for guix pack.
(name . Maxime Devos)(address . maximedevos@telenet.be)
87tulouvqx.fsf_-_@gnu.org
Hi,

Maxime Devos <maximedevos@telenet.be> skribis:

Toggle quote (2 lines)
> Maxim Cournoyer schreef op ma 21-06-2021 om 02:12 [-0400]:

[...]

Toggle quote (10 lines)
>> +;;; 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) [...]))
>>
>> +(eval define-manifest->friendly-name (current-module))
>
> You can avoid 'eval' here by defining 'manifest->friendly-name
> in a separate guix/build/pack-utils.scm module.

Seconded!

Toggle quote (2 lines)
> Alternatively, some macroology (untested, may need some tweaks):

See also ‘define-os-with-source’ in (gnu tests).

HTH,
Ludo’.
L
L
Ludovic Courtès wrote on 23 Jun 2021 23:28
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)(address . 49149@debbugs.gnu.org)
87eecsuv85.fsf@gnu.org
Hello!

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

Toggle quote (18 lines)
> This patch set adds support to produce Debian archives (.deb packages) via
> guix pack. It's rudimentary but functional. You can try a simple example
> like so:
>
> $ ./pre-inst-env guix pack -f deb -C xz hello -S /usr/bin/hello=bin/hello
>
> Copy the generated .deb to your dpkg-based distribution of choice, then:
>
> $ sudo apt install ./91ypmi1j5py9qk034kki5wrgy0n52yz9-hello-deb-pack.deb
>
> $ realpath $(which hello)
> /gnu/store/lk9cmjjhgxpkxxi7m54y0jlv3rqvpb2n-hello-2.10/bin/hello
> $ hello
> Hello, world!
>
> Fun, no? We can now distribute software built with Guix transparently to any
> Debian-based distribution.

Definitely fun. :-)

As briefly discussed on IRC, I wonder what happens when installing
multiple such .deb files, and removing them selectively. There’s of
course going to be overlapping store items.

Apparently, dpkg will happily overwrite them when you install (and
that’s fine, if they have the same name, they’re identical), but what
happens when you remove one of them? Does it, for instance, remove
/gnu/store/…-glibc just because it “belongs” to that package, without
noticing that it also belongs to other installed packages?

If dpkg cannot deal with that, it’s equivalent to a tarball pack for all
practical purposes, except you’d run “sudo apt” instead of “sudo tar”.

WDYT? Is our official Debian ambassador around? :-)

A complementary approach would be to transparently build Guix packages
in a Debian VM, with an FHS layout, and with dependencies on Debian
packages. I remember there were tools for that in Nixpkgs back in the
day, using Checkinstall to generate the actual .deb file.

Thanks for the neat hack!

Ludo’.
M
M
Maxim Cournoyer wrote on 24 Jun 2021 06:40
[PATCH v2 1/7] pack: Extract builder code from self-contained-tarball.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210624044049.17906-1-maxim.cournoyer@gmail.com
This is made to allow reusing it for the debian-archive pack format, added in
a subsequent commit.

* guix/scripts/pack.scm (self-contained-tarball/builder): New procedure,
containing the build code extracted from self-contained-tarball.
(self-contained-tarball): Use the above procedure.
---
guix/scripts/pack.scm | 270 ++++++++++++++++++++++--------------------
1 file changed, 141 insertions(+), 129 deletions(-)

Toggle diff (296 lines)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 8cb4e6d2cc..ac477850e6 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -172,22 +172,17 @@ dependencies are registered."
   (computed-file "store-database" build
                  #:options `(#:references-graphs ,(zip labels items))))
 
-(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."
+
+;;;
+;;; 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."
   (define database
     (and localstatedir?
          (file-append (store-database (list profile))
@@ -209,125 +204,142 @@ added to the pack."
     (and (not-config? module)
          (not (equal? '(guix store deduplication) module))))
 
-  (define build
-    (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))
+  (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 %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
-            (exit
-             (zero? (apply system* "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")
-                           "--mtime=@1"           ;for files in /var/guix
-                           "--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."
   (when entry-point
     (warning (G_ "entry point not supported in the '~a' format~%")
              'tarball))
 
-  (gexp->derivation (string-append name ".tar"
-                                   (compressor-extension compressor))
-                    build
-                    #:target target
-                    #:references-graphs `(("profile" ,profile))))
+  (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))))
 
 (define (singularity-environment-file profile)
   "Return a shell script that defines the environment variables corresponding
-- 
2.32.0
M
M
Maxim Cournoyer wrote on 24 Jun 2021 06:40
[PATCH v2 2/7] pack: Factorize base tar options.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210624044049.17906-2-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

Toggle diff (237 lines)
diff --git a/Makefile.am b/Makefile.am
index 7bb5de007e..15ac03ebd9 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
M
M
Maxim Cournoyer wrote on 24 Jun 2021 06:40
[PATCH v2 3/7] pack: Fix typo.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210624044049.17906-3-maxim.cournoyer@gmail.com
* guix/scripts/pack.scm (self-contained-tarball/builder): Fix typo.
---
guix/scripts/pack.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)

Toggle diff (15 lines)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index d11f498925..7ea97a4b7a 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -229,7 +229,7 @@ dependencies are registered."
              (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
+               ;; 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 "/")
-- 
2.32.0
M
M
Maxim Cournoyer wrote on 24 Jun 2021 06:40
[PATCH v2 4/7] pack: Improve naming of the packs store file names.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210624044049.17906-4-maxim.cournoyer@gmail.com
Instead of just naming them by their pack type, add information from the
package(s) they contain to make it easier to differentiate them.

* guix/scripts/pack.scm (define-with-source): New macro.
(manifest->friendly-name): Extract procedure from ...
(docker-image): ... here, now defined via the above macro. Adjust REPOSITORY
argument value accordingly.
(guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME.
---
guix/scripts/pack.scm | 49 +++++++++++++++++++++++++++----------------
1 file changed, 31 insertions(+), 18 deletions(-)

Toggle diff (104 lines)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 7ea97a4b7a..ad432f2b63 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -172,6 +172,28 @@ dependencies are registered."
   (computed-file "store-database" build
                  #:options `(#:references-graphs ,(zip labels items))))
 
+(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))))))
+
 
 ;;;
 ;;; Tarball format.
@@ -540,7 +562,7 @@ the image."
          (file-append (store-database (list profile))
                       "/db/db.sqlite")))
 
-  (define defmod 'define-module)                  ;trick Geiser
+  (define defmod 'define-module)        ;trick Geiser
 
   (define build
     ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
@@ -558,6 +580,8 @@ the image."
                          (srfi srfi-1) (srfi srfi-19)
                          (ice-9 match))
 
+            #$(procedure-source manifest->friendly-name)
+
             (define environment
               (map (match-lambda
                      ((spec . value)
@@ -581,19 +605,6 @@ the image."
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
-            (define tag
-              ;; Compute a meaningful "repository" name, which will show up in
-              ;; the output of "docker images".
-              (let ((manifest (profile-manifest #$profile)))
-                (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
-
             (setenv "PATH" #+(file-append archiver "/bin"))
 
             (build-docker-image #$output
@@ -601,7 +612,8 @@ the image."
                                      (call-with-input-file "profile"
                                        read-reference-graph))
                                 #$profile
-                                #:repository tag
+                                #:repository (manifest->friendly-name
+                                              (profile-manifest #$profile))
                                 #:database #+database
                                 #:system (or #$target %host-type)
                                 #:environment environment
@@ -1209,8 +1221,6 @@ Create a bundle of PACKAGE.\n"))
                                        manifest)
                                       manifest)))
                    (pack-format (assoc-ref opts 'format))
-                   (name        (string-append (symbol->string pack-format)
-                                               "-pack"))
                    (target      (assoc-ref opts 'target))
                    (bootstrap?  (assoc-ref opts 'bootstrap?))
                    (compressor  (if bootstrap?
@@ -1244,7 +1254,10 @@ Create a bundle of PACKAGE.\n"))
                                     (hooks (if bootstrap?
                                                '()
                                                %default-profile-hooks))
-                                    (locales? (not bootstrap?)))))
+                                    (locales? (not bootstrap?))))
+                   (name (string-append (manifest->friendly-name manifest)
+                                        "-" (symbol->string pack-format)
+                                        "-pack")))
               (define (lookup-package package)
                 (manifest-lookup manifest (manifest-pattern (name package))))
 
-- 
2.32.0
M
M
Maxim Cournoyer wrote on 24 Jun 2021 06:40
[PATCH v2 5/7] pack: Prevent duplicate files in tar archives.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210624044049.17906-5-maxim.cournoyer@gmail.com
Tar translate duplicate files in the archive into hard links. These can cause
problems, as not every tool support them; for example dpkg doesn't.

* gnu/system/file-systems.scm (reduce-directories): New procedure.
(file-prefix?): Lift the restriction on file prefix. The procedure can be
useful for comparing relative file names. Adjust doc.
(file-name-depth): New procedure, extracted from ...
(btrfs-store-subvolume-file-name): ... here.
* guix/scripts/pack.scm (self-contained-tarball/builder): Use
reduce-directories.
* tests/file-systems.scm ("reduce-directories"): New test.
---
gnu/system/file-systems.scm | 56 +++++++++++++++++++++++++------------
guix/scripts/pack.scm | 6 ++--
tests/file-systems.scm | 7 ++++-
3 files changed, 48 insertions(+), 21 deletions(-)

Toggle diff (144 lines)
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 464e87cb18..fb87bfc85b 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -55,6 +55,7 @@
             file-system-dependencies
             file-system-location
 
+            reduce-directories
             file-system-type-predicate
             btrfs-subvolume?
             btrfs-store-subvolume-file-name
@@ -231,8 +232,8 @@
   (char-set-complement (char-set #\/)))
 
 (define (file-prefix? file1 file2)
-  "Return #t if FILE1 denotes the name of a file that is a parent of FILE2,
-where both FILE1 and FILE2 are absolute file name.  For example:
+  "Return #t if FILE1 denotes the name of a file that is a parent of FILE2.
+For example:
 
   (file-prefix? \"/gnu\" \"/gnu/store\")
   => #t
@@ -240,19 +241,41 @@ where both FILE1 and FILE2 are absolute file name.  For example:
   (file-prefix? \"/gn\" \"/gnu/store\")
   => #f
 "
-  (and (string-prefix? "/" file1)
-       (string-prefix? "/" file2)
-       (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)))))))
+  (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))))
 
 (define* (file-system-device->string device #:key uuid-type)
   "Return the string representations of the DEVICE field of a <file-system>
@@ -624,9 +647,6 @@ store is located, else #f."
         s
         (string-append "/" s)))
 
-  (define (file-name-depth file-name)
-    (length (string-tokenize file-name %not-slash)))
-
   (and-let* ((btrfs-subvolume-fs (filter btrfs-subvolume? file-systems))
              (btrfs-subvolume-fs*
               (sort btrfs-subvolume-fs
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index ad432f2b63..84f2f14343 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -230,13 +230,15 @@ its source property."
                           `((guix build pack)
                             (guix build utils)
                             (guix build union)
-                            (gnu build install))
+                            (gnu build install)
+                            (gnu system file-systems))
                           #:select? import-module?)
     #~(begin
         (use-modules (guix build pack)
                      (guix build utils)
                      ((guix build union) #:select (relative-file-name))
                      (gnu build install)
+                     ((gnu system file-systems) #:select (reduce-directories))
                      (srfi srfi-1)
                      (srfi srfi-26)
                      (ice-9 match))
@@ -303,7 +305,7 @@ its source property."
 
                    ,(string-append "." (%store-directory))
 
-                   ,@(delete-duplicates
+                   ,@(reduce-directories
                       (filter-map (match-lambda
                                     (('directory directory)
                                      (string-append "." directory))
diff --git a/tests/file-systems.scm b/tests/file-systems.scm
index 7f7c373884..80acb6d5b9 100644
--- a/tests/file-systems.scm
+++ b/tests/file-systems.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -50,6 +50,11 @@
                    (device "/foo")
                    (flags '(bind-mount read-only)))))))))
 
+(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")))
+
 (test-assert "does not pull (guix config)"
   ;; This module is meant both for the host side and "build side", so make
   ;; sure it doesn't pull in (guix config), which depends on the user's
-- 
2.32.0
M
M
Maxim Cournoyer wrote on 24 Jun 2021 06:40
[PATCH v2 6/7] tests: pack: Fix compressor extension.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210624044049.17906-6-maxim.cournoyer@gmail.com
* tests/pack.scm (%gzip-compressor): Add the missing leading period to the
gzip compressor file extension.
---
tests/pack.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)

Toggle diff (15 lines)
diff --git a/tests/pack.scm b/tests/pack.scm
index e8455b4f37..ae6247a1d5 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -51,7 +51,7 @@
 (define %gzip-compressor
   ;; Compressor that uses the bootstrap 'gzip'.
   ((@ (guix scripts pack) compressor) "gzip"
-   "gz"
+   ".gz"
    #~(#+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n")))
 
 (define %tar-bootstrap %bootstrap-coreutils&co)
-- 
2.32.0
M
M
Maxim Cournoyer wrote on 24 Jun 2021 06:40
[PATCH v2 7/7] pack: Add support for the deb format.
(address . 49149@debbugs.gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20210624044049.17906-7-maxim.cournoyer@gmail.com
* .dir-locals.el (scheme-mode)[gexp->derivation]: Define indentation rule.
* guix/scripts/pack.scm (debian-archive): New procedure.
(%formats): Register the new deb format.
(show-formats): Add it to the usage string.
* tests/pack.scm (%ar-bootstrap): New variable.
(deb archive with symlinks): New test.
* doc/guix.texi (Invoking guix pack): Document it.
---
.dir-locals.el | 1 +
doc/guix.texi | 5 ++
guix/scripts/pack.scm | 178 +++++++++++++++++++++++++++++++++++++++++-
tests/pack.scm | 75 ++++++++++++++++++
4 files changed, 258 insertions(+), 1 deletion(-)

Toggle diff (375 lines)
diff --git a/.dir-locals.el b/.dir-locals.el
index 8f07a08eb5..a4fcbfe7ca 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -75,6 +75,7 @@
    (eval . (put 'origin 'scheme-indent-function 0))
    (eval . (put 'build-system 'scheme-indent-function 0))
    (eval . (put 'bag 'scheme-indent-function 0))
+   (eval . (put 'gexp->derivation 'scheme-indent-function 1))
    (eval . (put 'graft 'scheme-indent-function 0))
    (eval . (put 'operating-system 'scheme-indent-function 0))
    (eval . (put 'file-system 'scheme-indent-function 0))
diff --git a/doc/guix.texi b/doc/guix.texi
index 15e8999447..70de6b16ae 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6025,6 +6025,11 @@ This produces a SquashFS image containing all the specified binaries and
 symlinks, as well as empty mount points for virtual file systems like
 procfs.
 
+@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.
+
 @quotation Note
 Singularity @emph{requires} you to provide @file{/bin/sh} in the image.
 For that reason, @command{guix pack -f squashfs} always implies @code{-S
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 84f2f14343..7de061d7ae 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -65,6 +66,7 @@
             %compressors
             lookup-compressor
             self-contained-tarball
+            debian-archive
             docker-image
             squashfs-image
 
@@ -346,6 +348,10 @@ added to the pack."
    #:target target
    #:references-graphs `(("profile" ,profile))))
 
+
+;;;
+;;; Singularity.
+;;;
 (define (singularity-environment-file profile)
   "Return a shell script that defines the environment variables corresponding
 to the search paths of PROFILE."
@@ -372,6 +378,10 @@ to the search paths of PROFILE."
 
   (computed-file "singularity-environment.sh" build))
 
+
+;;;
+;;; SquashFS image format.
+;;;
 (define* (squashfs-image name profile
                          #:key target
                          (profile-name "guix-profile")
@@ -546,6 +556,10 @@ added to the pack."
                     #:target target
                     #:references-graphs `(("profile" ,profile))))
 
+
+;;;
+;;; Docker image format.
+;;;
 (define* (docker-image name profile
                        #:key target
                        (profile-name "guix-profile")
@@ -633,6 +647,165 @@ the image."
                     #:target target
                     #:references-graphs `(("profile" ,profile))))
 
+
+;;;
+;;; 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))
+
+            #$(procedure-source 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))))
+
 
 ;;;
 ;;; Compiling C programs.
@@ -965,7 +1138,8 @@ last resort for relocation."
   ;; Supported pack formats.
   `((tarball . ,self-contained-tarball)
     (squashfs . ,squashfs-image)
-    (docker  . ,docker-image)))
+    (docker  . ,docker-image)
+    (deb . ,debian-archive)))
 
 (define (show-formats)
   ;; Print the supported pack formats.
@@ -977,6 +1151,8 @@ last resort for relocation."
   squashfs      Squashfs image suitable for Singularity"))
   (display (G_ "
   docker        Tarball ready for 'docker load'"))
+  (display (G_ "
+  deb           Debian archive installable via dpkg/apt"))
   (newline))
 
 (define %options
diff --git a/tests/pack.scm b/tests/pack.scm
index ae6247a1d5..9473d4f384 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,6 +33,7 @@
   #:use-module ((gnu packages base) #:select (glibc-utf8-locales))
   #:use-module (gnu packages bootstrap)
   #:use-module ((gnu packages compression) #:select (squashfs-tools))
+  #:use-module ((gnu packages debian) #:select (dpkg))
   #:use-module ((gnu packages guile) #:select (guile-sqlite3))
   #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
   #:use-module (srfi srfi-64))
@@ -56,6 +58,8 @@
 
 (define %tar-bootstrap %bootstrap-coreutils&co)
 
+(define %ar-bootstrap %bootstrap-binutils)
+
 
 (test-begin "pack")
 
@@ -270,6 +274,77 @@
                                                  1)
                                                 (pk 'guilelink (readlink "bin"))))
                              (mkdir #$output))))))))
+      (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 (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))))))
       (built-derivations (list check)))))
 
 (test-end)
-- 
2.32.0
M
M
Maxim Cournoyer wrote on 24 Jun 2021 06:44
Re: [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names.
(name . Maxime Devos)(address . maximedevos@telenet.be)(address . 49149@debbugs.gnu.org)
87y2az27oi.fsf@gmail.com
Hello Maxime & Ludovic,

Maxime Devos <maximedevos@telenet.be> writes:

Toggle quote (29 lines)
>> I'm not sure how the expansion would be usable in the module it is
>> defined? It seems I could manage to get 'manifest->friendly-name' to be
>> a procedure returning a gexp, but that gexp wouldn't be readily usable
>> in that module (it could only be used when gexp-unquote from inside
>> another G-Exp), and the expansion in the macro above doesn't bind any
>> identifier, unless I'm missing something?
>
> The macro does two things: define a procedure manifest->friendly-name
> that returns a string.
>
> (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
>
> and also define a G-exp define-manifest->friendly-name
>
> (define define-manifest->friendly-nam
> #~(define (manifest->friendly-name manifes)
> "Return a friendly name [...]"
> [...])

Thanks a lot for persevering in your explanations, that made it clear
and with some ideas from the fine folks in #guile was able to come up
with this:

Toggle snippet (23 lines)
(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))))))

And then use it inside the build G-Exp via:

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

The pack tests are still passing.

Maxim
M
M
Maxim Cournoyer wrote on 26 Jun 2021 07:03
Re: bug#49149: [PATCH 0/7] Add deb format for guix pack.
(address . 49149@debbugs.gnu.org)
87wnqhw731.fsf_-_@gmail.com
Hi,

Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:

[...]

Toggle quote (7 lines)
> +(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)

Some typo slipped here. It should have been body body* ..., as in the template.

Toggle quote (5 lines)
> + (eval-when (load eval)
> + (set-procedure-property! variable 'source
> + '(define (variable args ...) body body* ...)))))
> +

Thanks,

Maxim
M
M
Maxime Devos wrote on 26 Jun 2021 18:58
Re: [bug#49149] [PATCH v2 7/7] pack: Add support for the deb format.
55cd0daaf579eff0d00e99213ca8205575b6752a.camel@telenet.be
Maxim Cournoyer schreef op do 24-06-2021 om 00:40 [-0400]:
Toggle quote (8 lines)
> + (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")

I'd add i586->i386 here as well, to allow the "i586-gnu" target (for the Hurd).
(Debian has a Hurd port: https://www.debian.org/ports/hurd/).
Maybe more is needed for proper Hurd support though.

For completeness, I'd also add i486->i386,
to allow "guix pack hello --target=i486-linux-gnu --format=tarball"
as well. Ok, i486-linux-gnu isn't a ‘supported’ cross-target, but why not?

Greetings,
Maxime.
-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYNdctBccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7lHuAQClGAlrD6VcLntpYtK78uJpCVHS
0ZNcoV2j2G6MSrMbdwEA4Dq0xNj7+xo3kZcZkE0xNWPTJf65++oHUVgBQFEYHQo=
=yaSx
-----END PGP SIGNATURE-----


M
M
Maxim Cournoyer wrote on 29 Jun 2021 19:49
Re: bug#49149: [PATCH 0/7] Add deb format for guix pack.
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 49149@debbugs.gnu.org)
87k0mcv9wh.fsf_-_@gmail.com
Hello! Seems this one had fallen into the cracks of my hundred
something long mailbox. Sorry!

Ludovic Courtès <ludo@gnu.org> writes:

Toggle quote (34 lines)
> Hello!
>
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> This patch set adds support to produce Debian archives (.deb packages) via
>> guix pack. It's rudimentary but functional. You can try a simple example
>> like so:
>>
>> $ ./pre-inst-env guix pack -f deb -C xz hello -S /usr/bin/hello=bin/hello
>>
>> Copy the generated .deb to your dpkg-based distribution of choice, then:
>>
>> $ sudo apt install ./91ypmi1j5py9qk034kki5wrgy0n52yz9-hello-deb-pack.deb
>>
>> $ realpath $(which hello)
>> /gnu/store/lk9cmjjhgxpkxxi7m54y0jlv3rqvpb2n-hello-2.10/bin/hello
>> $ hello
>> Hello, world!
>>
>> Fun, no? We can now distribute software built with Guix transparently to any
>> Debian-based distribution.
>
> Definitely fun. :-)
>
> As briefly discussed on IRC, I wonder what happens when installing
> multiple such .deb files, and removing them selectively. There’s of
> course going to be overlapping store items.

> Apparently, dpkg will happily overwrite them when you install (and
> that’s fine, if they have the same name, they’re identical), but what
> happens when you remove one of them? Does it, for instance, remove
> /gnu/store/…-glibc just because it “belongs” to that package, without
> noticing that it also belongs to other installed packages?

Actually, dpkg will error with a conflict message if two distinct
packages try to install the same file. Only a package with the same
name can overwrite itself.

Toggle quote (3 lines)
> If dpkg cannot deal with that, it’s equivalent to a tarball pack for all
> practical purposes, except you’d run “sudo apt” instead of “sudo tar”.

Given you can't install two conflicting packages, the issue of removing
the files of another package cannot arise. In practice that means that
the current implementation of 'guix pack -f deb' would only allow
installing *one* such .deb package on a system at a time (most
applications will carry the glibc and thus conflict for example).

For a multi deb-pack scenario, we could have each .deb install their own
files under for example /opt/guix/deb-packs/$name/gnu/store... via the
relocatable option.

Toggle quote (7 lines)
> WDYT? Is our official Debian ambassador around? :-)
>
> A complementary approach would be to transparently build Guix packages
> in a Debian VM, with an FHS layout, and with dependencies on Debian
> packages. I remember there were tools for that in Nixpkgs back in the
> day, using Checkinstall to generate the actual .deb file.

It could be fun! Although my next 'guix pack' hack will have to be
--format=rpm, to complement this one ;-).

Thanks!

Maxim
M
M
Maxim Cournoyer wrote on 29 Jun 2021 21:20
(name . Maxime Devos)(address . maximedevos@telenet.be)(address . 49149-done@debbugs.gnu.org)
87czs4v5oq.fsf_-_@gmail.com
Hello!

Maxime Devos <maximedevos@telenet.be> writes:

Toggle quote (17 lines)
> Maxim Cournoyer schreef op do 24-06-2021 om 00:40 [-0400]:
>> + (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")
>
> I'd add i586->i386 here as well, to allow the "i586-gnu" target (for the Hurd).
> (Debian has a Hurd port: https://www.debian.org/ports/hurd/).
> Maybe more is needed for proper Hurd support though.
>
> For completeness, I'd also add i486->i386,
> to allow "guix pack hello --target=i486-linux-gnu --format=tarball"
> as well. Ok, i486-linux-gnu isn't a ‘supported’ cross-target, but why not?

Done.

Series pushed in commit 6396f0c235231d4d41d11fffa021251ea6aa90a7.
Thanks for the review!

Maxim
Closed
L
L
Ludovic Courtès wrote on 30 Jun 2021 11:15
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)(address . 49149@debbugs.gnu.org)
87bl7npvbg.fsf@gnu.org
Howdy!

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

Toggle quote (2 lines)
> Ludovic Courtès <ludo@gnu.org> writes:

[...]

Toggle quote (10 lines)
>> Apparently, dpkg will happily overwrite them when you install (and
>> that’s fine, if they have the same name, they’re identical), but what
>> happens when you remove one of them? Does it, for instance, remove
>> /gnu/store/…-glibc just because it “belongs” to that package, without
>> noticing that it also belongs to other installed packages?
>
> Actually, dpkg will error with a conflict message if two distinct
> packages try to install the same file. Only a package with the same
> name can overwrite itself.

Ah OK.

Also, what happens if you do:

sudo apt install guix
guix install stuff …
sudo apt install ./guix-pack-generated.deb

?

Will that overwrite things in /gnu/store?

Admittedly it makes little sense to do something like this, but that’s
something one could do.

Toggle quote (9 lines)
>> If dpkg cannot deal with that, it’s equivalent to a tarball pack for all
>> practical purposes, except you’d run “sudo apt” instead of “sudo tar”.
>
> Given you can't install two conflicting packages, the issue of removing
> the files of another package cannot arise. In practice that means that
> the current implementation of 'guix pack -f deb' would only allow
> installing *one* such .deb package on a system at a time (most
> applications will carry the glibc and thus conflict for example).

I see. So the main value over “sudo tar xf” is that dpkg knows which
files were installed, right?

Toggle quote (4 lines)
> For a multi deb-pack scenario, we could have each .deb install their own
> files under for example /opt/guix/deb-packs/$name/gnu/store... via the
> relocatable option.

Hmm yeah, though it doesn’t sound pretty.

Thanks,
Ludo’.
L
L
Ludovic Courtès wrote on 30 Jun 2021 12:06
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)(address . 49149@debbugs.gnu.org)
87wnqboedx.fsf_-_@gnu.org
Hi,

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

Toggle quote (12 lines)
> Tar translate duplicate files in the archive into hard links. These can cause
> problems, as not every tool support them; for example dpkg doesn't.
>
> * gnu/system/file-systems.scm (reduce-directories): New procedure.
> (file-prefix?): Lift the restriction on file prefix. The procedure can be
> useful for comparing relative file names. Adjust doc.
> (file-name-depth): New procedure, extracted from ...
> (btrfs-store-subvolume-file-name): ... here.
> * guix/scripts/pack.scm (self-contained-tarball/builder): Use
> reduce-directories.
> * tests/file-systems.scm ("reduce-directories"): New test.

[...]

Toggle quote (15 lines)
> (define (file-prefix? file1 file2)
> - "Return #t if FILE1 denotes the name of a file that is a parent of FILE2,
> -where both FILE1 and FILE2 are absolute file name. For example:
> + "Return #t if FILE1 denotes the name of a file that is a parent of FILE2.
> +For example:
>
> (file-prefix? \"/gnu\" \"/gnu/store\")
> => #t
> @@ -240,19 +241,41 @@ where both FILE1 and FILE2 are absolute file name. For example:
> (file-prefix? \"/gn\" \"/gnu/store\")
> => #f
> "
> - (and (string-prefix? "/" file1)
> - (string-prefix? "/" file2)

Doesn’t it have the effect that now:

(file-prefix? "gnu" "/gnu/store") => #t

?

I’d rather insist on absolute file names and preserve the initial
semantics, to avoid bad surprises.


Toggle quote (21 lines)
> +(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))))

Likewise, I suspect it doesn’t work as intended if there are relative
file names in the list, no?

Perhaps we could add an example to the docstring. Also, the word
“reduce” doesn’t appear in the docstring, which to me suggests
suboptimal naming. ;-)

Thanks,
Ludo’.
L
L
Ludovic Courtès wrote on 30 Jun 2021 12:10
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)(address . 49149@debbugs.gnu.org)
87sg0zoe87.fsf_-_@gnu.org
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

Toggle quote (11 lines)
> --- a/doc/guix.texi
> +++ b/doc/guix.texi
> @@ -6025,6 +6025,11 @@ This produces a SquashFS image containing all the specified binaries and
> symlinks, as well as empty mount points for virtual file systems like
> procfs.
>
> +@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.

“GNU/Linux (or GNU/Hurd)” maybe.

Perhaps it should explain that the .deb contains the whole store and
installs it as /gnu/store, and that only one such pack can be installed
at a time?

Thanks,
Ludo’.
L
L
Ludovic Courtès wrote on 30 Jun 2021 12:13
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)(address . 49149@debbugs.gnu.org)
87lf6roe32.fsf_-_@gnu.org
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

Toggle quote (9 lines)
> Instead of just naming them by their pack type, add information from the
> package(s) they contain to make it easier to differentiate them.
>
> * guix/scripts/pack.scm (define-with-source): New macro.
> (manifest->friendly-name): Extract procedure from ...
> (docker-image): ... here, now defined via the above macro. Adjust REPOSITORY
> argument value accordingly.
> (guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME.

[...]

Toggle quote (13 lines)
> - (define tag
> - ;; Compute a meaningful "repository" name, which will show up in
> - ;; the output of "docker images".
> - (let ((manifest (profile-manifest #$profile)))
> - (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

I think this should not be factorized because the requirements are very
Docker-dependent. Once factorized, it becomes easy to overlook this.

Ludo’.
Z
Z
zimoun wrote on 30 Jun 2021 15:49
Re: [bug#49149] [PATCH 0/7] Add deb format for guix pack.
(address . 49149@debbugs.gnu.org)
86tulf799s.fsf@gmail.com
Hi,

I am a bit late to the party.

Thanks for this good idea of pack. Neat!


On Wed, 30 Jun 2021 at 11:15, Ludovic Courtès <ludo@gnu.org> wrote:

Toggle quote (13 lines)
> Also, what happens if you do:
>
> sudo apt install guix
> guix install stuff …
> sudo apt install ./guix-pack-generated.deb
>
> ?
>
> Will that overwrite things in /gnu/store?
>
> Admittedly it makes little sense to do something like this, but that’s
> something one could do.

The simple scenario:

scp \
$(guix pack -f deb hello -C xz -S /usr/bin/hello=bin/hello) \
remote:/tmp/
ssh remote
sudo apt install /tmp/…-hello-deb-pack.deb
realpath $(which hello)
/gnu/store/…-hello-2.10/bin/hello

works fine. Then, I am probably doing wrong:

sudo apt remove hello
hello
-bash: hello: command not found

guix help
bash: /home/simon/.config/guix/current/bin/guix: /gnu/store/…-guile-wrapper/bin/guile: bad interpreter: No such file or directory

I have not investigated. Just a quick test for this nice new feature.

Cheers,
simon
Z
Z
zimoun wrote on 30 Jun 2021 17:06
(address . 49149@debbugs.gnu.org)
86lf6r75nw.fsf@gmail.com
Hi,

Using Guix ebf07a0.

I do not know if the issue is about multi-debs or if I am doing
something wrong but IIUC ’apt’ remove all the files under data/.

$ /gnu/store/3v93dzrmh978mljw65zvvydm2w8lqaam-guile-wrapper/bin/guile --version
guile (GNU Guile) 3.0.7
Copyright (C) 2021 Free Software Foundation, Inc.

License LGPLv3+: GNU LGPL 3 or later http://gnu.org/licenses/lgpl.html.
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.


$ guix gc --references /gnu/store/3v93dzrmh978mljw65zvvydm2w8lqaam-guile-wrapper
/gnu/store/01b4w3m6mp55y531kyi1g8shh722kwqm-gcc-7.5.0-lib
/gnu/store/226ljnvrhnrb3ngjn0m6i5ih2301bbj0-guile-launcher.c
/gnu/store/6l9rix46ydxyldf74dvpgr60rf5ily0c-guile-3.0.7
/gnu/store/fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31
/gnu/store/xa45bzcbib4zqa7gk70nb35dzzwyr376-gcc-toolchain-7.5.0


$ sudo apt install y74azsczq1dws1slmagc1jq6ysidllpb-hello-deb-pack.deb
$ guix gc --references $(realpath $(which hello))
/gnu/store/01b4w3m6mp55y531kyi1g8shh722kwqm-gcc-7.5.0-lib
/gnu/store/a462kby1q51ndvxdv3b6p0rsixxrgx1h-hello-2.10
/gnu/store/fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31


$ sudo apt remove hello

$ ls /gnu/store/01b4w3m6mp55y531kyi1g8shh722kwqm-gcc-7.5.0-lib
ls: cannot access '/gnu/store/01b4w3m6mp55y531kyi1g8shh722kwqm-gcc-7.5.0-lib': No such file or directory
$ ls -l /gnu/store/3v93dzrmh978mljw65zvvydm2w8lqaam-guile-wrapper/bin/guile
-r-xr-xr-x 2 root root 17472 Jan 1 1970 /gnu/store/3v93dzrmh978mljw65zvvydm2w8lqaam-guile-wrapper/bin/guile
$ /gnu/store/3v93dzrmh978mljw65zvvydm2w8lqaam-guile-wrapper/bin/guile --version
bash: /gnu/store/3v93dzrmh978mljw65zvvydm2w8lqaam-guile-wrapper/bin/guile: No such file or directory


$ ar -xv y74azsczq1dws1slmagc1jq6ysidllpb-hello-deb-pack.deb
x - debian-binary
x - control.tar.xz
x - data.tar.xz

$ tar Jtf data.tar.xz | grep glibc | head
./gnu/store/01b4w3m6mp55y531kyi1g8shh722kwqm-gcc-7.5.0-lib/lib/gcc/x86_64-unknown-linux-gnu/7.5.0/plugin/include/config/glibc-stdint.h
./gnu/store/fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31/
./gnu/store/fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31/bin/
./gnu/store/fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31/bin/catchsegv
./gnu/store/fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31/bin/gencat
./gnu/store/fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31/bin/getconf
./gnu/store/fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31/bin/getent
./gnu/store/fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31/bin/iconv
./gnu/store/fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31/bin/ldd
./gnu/store/fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31/bin/locale


Therefore, installing and then removing ’hello’ breaks any other pack
using, for instance, 01b4w3m6mp55y531kyi1g8shh722kwqm-gcc-7.5.0-lib or
fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31. Do I miss something?


Cheers,
simon
M
M
Maxim Cournoyer wrote on 30 Jun 2021 18:42
Re: bug#49149: [PATCH 0/7] Add deb format for guix pack.
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 49149@debbugs.gnu.org)
87wnqb483r.fsf@gmail.com
Hello!

Ludovic Courtès <ludo@gnu.org> writes:

Toggle quote (33 lines)
> Howdy!
>
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> Ludovic Courtès <ludo@gnu.org> writes:
>
> [...]
>
>>> Apparently, dpkg will happily overwrite them when you install (and
>>> that’s fine, if they have the same name, they’re identical), but what
>>> happens when you remove one of them? Does it, for instance, remove
>>> /gnu/store/…-glibc just because it “belongs” to that package, without
>>> noticing that it also belongs to other installed packages?
>>
>> Actually, dpkg will error with a conflict message if two distinct
>> packages try to install the same file. Only a package with the same
>> name can overwrite itself.
>
> Ah OK.
>
> Also, what happens if you do:
>
> sudo apt install guix
> guix install stuff …
> sudo apt install ./guix-pack-generated.deb
>
> ?
>
> Will that overwrite things in /gnu/store?
>
> Admittedly it makes little sense to do something like this, but that’s
> something one could do.

It probably would conflict with what is already in the store (installed
by guix) and abort installation, guarding against this.

Toggle quote (12 lines)
>>> If dpkg cannot deal with that, it’s equivalent to a tarball pack for all
>>> practical purposes, except you’d run “sudo apt” instead of “sudo tar”.
>>
>> Given you can't install two conflicting packages, the issue of removing
>> the files of another package cannot arise. In practice that means that
>> the current implementation of 'guix pack -f deb' would only allow
>> installing *one* such .deb package on a system at a time (most
>> applications will carry the glibc and thus conflict for example).
>
> I see. So the main value over “sudo tar xf” is that dpkg knows which
> files were installed, right?

That's one good advantage (the ease of cleanly uninstalling the .deb),
but for me the main one is the ability to plug it in already established
distribution channels (such as a 3rd party apt repository) and have it
available (and updatable) easily for their users.

A real world use case I've been playing with is to have the jami-qt
package that is painstakingly built for each flavor of the leading
Deb-based distributions and available for example in various
repositories [0] built once via 'guix pack -f deb' and made available in
the same way. That'd remove the need to wrestle with OS-specifics, and
make the build (and hopefully the bugs) reproducible while preserving
the established and reliable distribution channel.

I hope this is way of doing things is obsoleted one day when Guix can be
hooked in the GNOME software "store" the same as snaps or flatpaks can,
so that users don't need to know how the command line to benefit from
the advantages provided by Guix.


Toggle quote (6 lines)
>> For a multi deb-pack scenario, we could have each .deb install their own
>> files under for example /opt/guix/deb-packs/$name/gnu/store... via the
>> relocatable option.
>
> Hmm yeah, though it doesn’t sound pretty.

In general, I find that 'guix pack's take a step away from elegance in
exchange for convenience, so that doesn't sound too terrible in that
context (it'd actually be easier to manage than a multi-tarball guix
packs deployment, for example, especially when comes the time to reclaim
some disk space).

My 2 cents :-).

Maxim
M
M
Maxim Cournoyer wrote on 30 Jun 2021 18:54
Re: [bug#49149] [PATCH 0/7] Add deb format for guix pack.
(name . zimoun)(address . zimon.toutoune@gmail.com)
87sg0z47ke.fsf@gmail.com
Hi Zimoun,

zimoun <zimon.toutoune@gmail.com> writes:

Toggle quote (19 lines)
> Hi,
>
> I am a bit late to the party.
>
> Thanks for this good idea of pack. Neat!
>
>
> On Wed, 30 Jun 2021 at 11:15, Ludovic Courtès <ludo@gnu.org> wrote:
>
>> Also, what happens if you do:
>>
>> sudo apt install guix
>> guix install stuff …
>> sudo apt install ./guix-pack-generated.deb
>>
>> ?
>>
>> Will that overwrite things in /gnu/store?

After thinking it out some more, yes! This is because the files are not
part of another deb, so dpkg will just claim ownership of the files.

Toggle quote (3 lines)
>> Admittedly it makes little sense to do something like this, but that’s
>> something one could do.

Indeed. I'll a disclaimer in the manual.

Toggle quote (19 lines)
> The simple scenario:
>
> scp \
> $(guix pack -f deb hello -C xz -S /usr/bin/hello=bin/hello) \
> remote:/tmp/
> ssh remote
> sudo apt install /tmp/…-hello-deb-pack.deb
> realpath $(which hello)
> /gnu/store/…-hello-2.10/bin/hello
>
> works fine. Then, I am probably doing wrong:
>
> sudo apt remove hello
> hello
> -bash: hello: command not found
>
> guix help
> bash: /home/simon/.config/guix/current/bin/guix: /gnu/store/…-guile-wrapper/bin/guile: bad interpreter: No such file or directory

So uninstalling the hello deb caused all the files "owned" by that
debian package to be removed, breaking the guix installed on that same
system.

It's becoming obvious that the deb-packs are not to be used on systems
where Guix is already installed nor mixed with other non-deb packs.
That's unfortunate, but there doesn't seem to be much we can do other
than document these shortcomings.

Toggle quote (2 lines)
> I have not investigated. Just a quick test for this nice new feature.

Thanks for the feedback!

Maxim
M
M
Maxim Cournoyer wrote on 30 Jun 2021 18:55
(name . zimoun)(address . zimon.toutoune@gmail.com)
87o8bn47he.fsf@gmail.com
Hi Simon,

[...]

Toggle quote (4 lines)
> Therefore, installing and then removing ’hello’ breaks any other pack
> using, for instance, 01b4w3m6mp55y531kyi1g8shh722kwqm-gcc-7.5.0-lib or
> fa6wj5bxkj5ll1d7292a70knmyl7a0cr-glibc-2.31. Do I miss something?

No, your analysis is correct.

I'm currently writing adding a disclaimer in the manual, will post it
here.

Thanks,

Maxim
M
M
Maxim Cournoyer wrote on 30 Jun 2021 19:28
(name . zimoun)(address . zimon.toutoune@gmail.com)
87k0mb45zu.fsf@gmail.com
Hi again,

How about adding these notes/disclaimers to prevent users breaking their
Guix or existing packs on foreign distributions?

Toggle snippet (51 lines)
doc: Add a note and warning regarding the usage of deb packs.

* doc/guix.texi (Invoking guix pack): Move to the end of the table, and add a
note and warning regarding the usage of deb packs.

1 file changed, 21 insertions(+), 5 deletions(-)
doc/guix.texi | 26 +++++++++++++++++++++-----

modified doc/guix.texi
@@ -6028,11 +6028,6 @@ This produces a SquashFS image containing all the specified binaries and
symlinks, as well as empty mount points for virtual file systems like
procfs.
-@item deb
-This produces a Debian archive (a package with the @samp{.deb} file
-extension) containing all the specified binaries and symbolic links,
-that can be installed on top of any dpkg-based GNU/Linux distribution.
-
@quotation Note
Singularity @emph{requires} you to provide @file{/bin/sh} in the image.
For that reason, @command{guix pack -f squashfs} always implies @code{-S
@@ -6047,6 +6042,27 @@ If you forget the @code{bash} (or similar) package, @command{singularity
run} and @command{singularity exec} will fail with an unhelpful ``no
such file or directory'' message.
@end quotation
+
+@item deb
+This produces a Debian archive (a package with the @samp{.deb} file
+extension) containing all the specified binaries and symbolic links,
+that can be installed on top of any dpkg-based GNU/Linux distribution.
+
+@quotation Note
+Because archives produced with @command{guix pack} contain a collection
+of store items and because each @command{dpkg} package must not have
+conflicting files, in practice that means you likely won't be able to
+install more one such archive on the same system.
+@end quotation
+
+@quotation Warning
+@command{dpkg} will assume ownership of any files contained in the pack
+that it does @emph{not} know about. It is unwise to install
+Guix-produced @samp{.deb} files on a system where @file{/gnu/store} is
+shared by other software, such as a Guix installation or other, non-deb
+packs.
+@end quotation
+
@end table
@cindex relocatable binaries

Thanks,

Maxim
M
M
Maxim Cournoyer wrote on 30 Jun 2021 19:36
Re: bug#49149: [PATCH 0/7] Add deb format for guix pack.
(name . zimoun)(address . zimon.toutoune@gmail.com)
87bl7n45m4.fsf_-_@gmail.com
Hi again,

Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:

[...]

Toggle quote (7 lines)
> +@quotation Note
> +Because archives produced with @command{guix pack} contain a collection
> +of store items and because each @command{dpkg} package must not have
> +conflicting files, in practice that means you likely won't be able to
> +install more one such archive on the same system.
> +@end quotation

With typo fixed:

-install more one such archive on the same system.
+install more than one such archive on a given system.

Maxim
Z
Z
zimoun wrote on 30 Jun 2021 19:47
Re: [bug#49149] [PATCH 0/7] Add deb format for guix pack.
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
86czs36y7l.fsf@gmail.com
Hi Maxim,

On Wed, 30 Jun 2021 at 13:28, Maxim Cournoyer <maxim.cournoyer@gmail.com> wrote:
Toggle quote (3 lines)
> --8<---------------cut here---------------start------------->8---
> doc: Add a note and warning regarding the usage of deb packs.

[...]

Toggle quote (25 lines)
> +@item deb
> +This produces a Debian archive (a package with the @samp{.deb} file
> +extension) containing all the specified binaries and symbolic links,
> +that can be installed on top of any dpkg-based GNU/Linux distribution.
> +
> +@quotation Note
> +Because archives produced with @command{guix pack} contain a collection
> +of store items and because each @command{dpkg} package must not have
> +conflicting files, in practice that means you likely won't be able to
> +install more one such archive on the same system.
> +@end quotation
> +
> +@quotation Warning
> +@command{dpkg} will assume ownership of any files contained in the pack
> +that it does @emph{not} know about. It is unwise to install
> +Guix-produced @samp{.deb} files on a system where @file{/gnu/store} is
> +shared by other software, such as a Guix installation or other, non-deb
> +packs.
> +@end quotation
> +
> @end table
>
> @cindex relocatable binaries
> --8<---------------cut here---------------end--------------->8---

The pack does not fully respect the FHS from the Debian Policy, right?

Hum, the disclaim LGTM. Although, it appears to me a severe limitation
to be able to install only one Guix-generated .deb pack on a Debian-like
system, IIUC. :-)

Cheers,
simon
M
M
Maxim Cournoyer wrote on 30 Jun 2021 20:16
Re: bug#49149: [PATCH 0/7] Add deb format for guix pack.
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 49149@debbugs.gnu.org)
877dib43qt.fsf@gmail.com
Hey,

Ludovic Courtès <ludo@gnu.org> writes:

[...]

Toggle quote (21 lines)
>> (define (file-prefix? file1 file2)
>> - "Return #t if FILE1 denotes the name of a file that is a parent of FILE2,
>> -where both FILE1 and FILE2 are absolute file name. For example:
>> + "Return #t if FILE1 denotes the name of a file that is a parent of FILE2.
>> +For example:
>>
>> (file-prefix? \"/gnu\" \"/gnu/store\")
>> => #t
>> @@ -240,19 +241,41 @@ where both FILE1 and FILE2 are absolute file name. For example:
>> (file-prefix? \"/gn\" \"/gnu/store\")
>> => #f
>> "
>> - (and (string-prefix? "/" file1)
>> - (string-prefix? "/" file2)
>
> Doesn’t it have the effect that now:
>
> (file-prefix? "gnu" "/gnu/store") => #t
>
> ?

Good catch. That seems sub-optimal. How about:

Toggle snippet (44 lines)
modified gnu/system/file-systems.scm
@@ -233,6 +233,8 @@
(define (file-prefix? file1 file2)
"Return #t if FILE1 denotes the name of a file that is a parent of FILE2.
+FILE1 and FILE2 must both be either absolute or relative, else #f is returned.
+
For example:
(file-prefix? \"/gnu\" \"/gnu/store\")
@@ -241,17 +243,24 @@ For example:
(file-prefix? \"/gn\" \"/gnu/store\")
=> #f
"
- (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 (absolute? file)
+ (string-prefix? "/" file))
+
+ (if (or (every absolute? (list file1 file2))
+ (every (negate absolute?) (list file1 file2)))
+ (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)))))
+ ;; FILE1 and FILE2 are a mix of absolute and relative paths.
+ #f))
(define (file-name-depth file-name)
(length (string-tokenize file-name %not-slash)))

Toggle quote (3 lines)
> I’d rather insist on absolute file names and preserve the initial
> semantics, to avoid bad surprises.

I agree that not changing the original semantics would be safest;
nevertheless, we're talking about an internal helper that isn't widely
use; its couple usages are easy to review (and deals with mount points
which seems safe to assume are exclusively using absolute paths).
Especially after the above fix :-).

Toggle quote (24 lines)
>> +(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))))
>
> Likewise, I suspect it doesn’t work as intended if there are relative
> file names in the list, no?

You can see it at work in the tests/file-systems test module; it reduces

(reduce-directories '("./opt/gnu/etc" "./opt/gnu/" "./opt/gnu/bin"
"./opt/gnu/lib/debug" "./opt/gnuism" "a/b/c"
"a/b/c"))

into '("./opt/gnu/" "./opt/gnuism" "a/b/c"), none of which are absolute
file names.

Toggle quote (4 lines)
> Perhaps we could add an example to the docstring. Also, the word
> “reduce” doesn’t appear in the docstring, which to me suggests
> suboptimal naming. ;-)

That the word 'reduce' doesn't appear in the docstring was a conscious
effort of mine to not bore the reader with repeating the same terms, ah!
But naming is hard; I'm open to suggestions.

Maxim
M
M
Maxim Cournoyer wrote on 30 Jun 2021 20:36
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 49149@debbugs.gnu.org)
8735sz42tc.fsf@gmail.com
Hello,

Ludovic Courtès <ludo@gnu.org> writes:

Toggle quote (29 lines)
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> Instead of just naming them by their pack type, add information from the
>> package(s) they contain to make it easier to differentiate them.
>>
>> * guix/scripts/pack.scm (define-with-source): New macro.
>> (manifest->friendly-name): Extract procedure from ...
>> (docker-image): ... here, now defined via the above macro. Adjust REPOSITORY
>> argument value accordingly.
>> (guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME.
>
> [...]
>
>> - (define tag
>> - ;; Compute a meaningful "repository" name, which will show up in
>> - ;; the output of "docker images".
>> - (let ((manifest (profile-manifest #$profile)))
>> - (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
>
> I think this should not be factorized because the requirements are very
> Docker-dependent. Once factorized, it becomes easy to overlook this.

Hmm, I'm not a docker format expert, but my quick reading about it
turned no restrictions about what a docker image label should look like?
So perhaps it is not specially Docker-dependent.

If there's something truly Docker-dependent about it I'd suggest adding
a #:docker-compatible? boolean option to the procedure.

Maxim
M
M
Maxim Cournoyer wrote on 30 Jun 2021 21:20
Re: [bug#49149] [PATCH 0/7] Add deb format for guix pack.
(name . zimoun)(address . zimon.toutoune@gmail.com)
87y2ar2m8v.fsf@gmail.com
Hi Simon,

zimoun <zimon.toutoune@gmail.com> writes:

Toggle quote (39 lines)
> Hi Maxim,
>
> On Wed, 30 Jun 2021 at 13:28, Maxim Cournoyer <maxim.cournoyer@gmail.com> wrote:
>> --8<---------------cut here---------------start------------->8---
>> doc: Add a note and warning regarding the usage of deb packs.
>
> [...]
>
>> +@item deb
>> +This produces a Debian archive (a package with the @samp{.deb} file
>> +extension) containing all the specified binaries and symbolic links,
>> +that can be installed on top of any dpkg-based GNU/Linux distribution.
>> +
>> +@quotation Note
>> +Because archives produced with @command{guix pack} contain a collection
>> +of store items and because each @command{dpkg} package must not have
>> +conflicting files, in practice that means you likely won't be able to
>> +install more one such archive on the same system.
>> +@end quotation
>> +
>> +@quotation Warning
>> +@command{dpkg} will assume ownership of any files contained in the pack
>> +that it does @emph{not} know about. It is unwise to install
>> +Guix-produced @samp{.deb} files on a system where @file{/gnu/store} is
>> +shared by other software, such as a Guix installation or other, non-deb
>> +packs.
>> +@end quotation
>> +
>> @end table
>>
>> @cindex relocatable binaries
>> --8<---------------cut here---------------end--------------->8---
>
> The pack does not fully respect the FHS from the Debian Policy, right?
>
> Hum, the disclaim LGTM. Although, it appears to me a severe limitation
> to be able to install only one Guix-generated .deb pack on a Debian-like
> system, IIUC. :-)

Thanks! It is! One thing that would be possible is react to a user
passing the -R(R) (relocatable) option and keep the deb pack contents
under a named prefix, such as /opt/deb-packs/name/gnu/store/[...] to
keep them from conflicting. I won't be pursuing it myself but it
shouldn't be too difficult to do!

Maxim
Z
Z
zimoun wrote on 1 Jul 2021 15:08
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
CAJ3okZ30Ez1DgM8a0aSvpBi+_RQZ_xa4FxWumiBhRaUFVkJYYQ@mail.gmail.com
Hi Maxim,

On Wed, 30 Jun 2021 at 21:20, Maxim Cournoyer <maxim.cournoyer@gmail.com> wrote:

Toggle quote (10 lines)
> > Hum, the disclaim LGTM. Although, it appears to me a severe limitation
> > to be able to install only one Guix-generated .deb pack on a Debian-like
> > system, IIUC. :-)
>
> Thanks! It is! One thing that would be possible is react to a user
> passing the -R(R) (relocatable) option and keep the deb pack contents
> under a named prefix, such as /opt/deb-packs/name/gnu/store/[...] to
> keep them from conflicting. I won't be pursuing it myself but it
> shouldn't be too difficult to do!

I understand. I keep this idea / feature under the elbow (well, have
this in reserve :-)).

Cheers,
simon
L
L
Ludovic Courtès wrote on 1 Jul 2021 15:20
Re: bug#49149: [PATCH 0/7] Add deb format for guix pack.
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)(address . 49149@debbugs.gnu.org)
87pmw2kw5t.fsf@gnu.org
Hello,

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

Toggle quote (8 lines)
>> Will that overwrite things in /gnu/store?
>>
>> Admittedly it makes little sense to do something like this, but that’s
>> something one could do.
>
> It probably would conflict with what is already in the store (installed
> by guix) and abort installation, guarding against this.

OK.

Toggle quote (14 lines)
>>> Given you can't install two conflicting packages, the issue of removing
>>> the files of another package cannot arise. In practice that means that
>>> the current implementation of 'guix pack -f deb' would only allow
>>> installing *one* such .deb package on a system at a time (most
>>> applications will carry the glibc and thus conflict for example).
>>
>> I see. So the main value over “sudo tar xf” is that dpkg knows which
>> files were installed, right?
>
> That's one good advantage (the ease of cleanly uninstalling the .deb),
> but for me the main one is the ability to plug it in already established
> distribution channels (such as a 3rd party apt repository) and have it
> available (and updatable) easily for their users.

Right. Though setting up an apt repo is quite a lot of work.

Also, would upgrading the Guix-generated package work? I suppose apt
would wipe /gnu/store of the former package and then unpack the new
package, right?

Toggle quote (8 lines)
> A real world use case I've been playing with is to have the jami-qt
> package that is painstakingly built for each flavor of the leading
> Deb-based distributions and available for example in various
> repositories [0] built once via 'guix pack -f deb' and made available in
> the same way. That'd remove the need to wrestle with OS-specifics, and
> make the build (and hopefully the bugs) reproducible while preserving
> the established and reliable distribution channel.

Nice! That’s an interesting use case.

Toggle quote (5 lines)
> I hope this is way of doing things is obsoleted one day when Guix can be
> hooked in the GNOME software "store" the same as snaps or flatpaks can,
> so that users don't need to know how the command line to benefit from
> the advantages provided by Guix.

True, having Guix as one of the app bundle options for GNOME Software
would be nice.

Toggle quote (12 lines)
>>> For a multi deb-pack scenario, we could have each .deb install their own
>>> files under for example /opt/guix/deb-packs/$name/gnu/store... via the
>>> relocatable option.
>>
>> Hmm yeah, though it doesn’t sound pretty.
>
> In general, I find that 'guix pack's take a step away from elegance in
> exchange for convenience, so that doesn't sound too terrible in that
> context (it'd actually be easier to manage than a multi-tarball guix
> packs deployment, for example, especially when comes the time to reclaim
> some disk space).

Yes, I agree that we need to be pragmatic here. :-)

Work on layered Docker images, notably by Chris Baines¹, could perhaps
be handy here.

Or, actually, one option would be for ‘guix pack -f deb’ to generate one
.deb file per store item. Does that sound reasonable?…

Thanks,
Ludo’.

L
L
Ludovic Courtès wrote on 1 Jul 2021 15:24
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)(address . 49149@debbugs.gnu.org)
87im1ukvzd.fsf@gnu.org
Hi!

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:


[...]

Toggle quote (23 lines)
>>> (define (file-prefix? file1 file2)
>>> - "Return #t if FILE1 denotes the name of a file that is a parent of FILE2,
>>> -where both FILE1 and FILE2 are absolute file name. For example:
>>> + "Return #t if FILE1 denotes the name of a file that is a parent of FILE2.
>>> +For example:
>>>
>>> (file-prefix? \"/gnu\" \"/gnu/store\")
>>> => #t
>>> @@ -240,19 +241,41 @@ where both FILE1 and FILE2 are absolute file name. For example:
>>> (file-prefix? \"/gn\" \"/gnu/store\")
>>> => #f
>>> "
>>> - (and (string-prefix? "/" file1)
>>> - (string-prefix? "/" file2)
>>
>> Doesn’t it have the effect that now:
>>
>> (file-prefix? "gnu" "/gnu/store") => #t
>>
>> ?
>
> Good catch. That seems sub-optimal. How about:

[...]

Toggle quote (6 lines)
> + (define (absolute? file)
> + (string-prefix? "/" file))
> +
> + (if (or (every absolute? (list file1 file2))
> + (every (negate absolute?) (list file1 file2)))

Yes, that could work.

Toggle quote (9 lines)
>> I’d rather insist on absolute file names and preserve the initial
>> semantics, to avoid bad surprises.
>
> I agree that not changing the original semantics would be safest;
> nevertheless, we're talking about an internal helper that isn't widely
> use; its couple usages are easy to review (and deals with mount points
> which seems safe to assume are exclusively using absolute paths).
> Especially after the above fix :-).

Sure, but it’s always easier to reason about code that is stricter.

Toggle quote (33 lines)
>>> +(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))))
>>
>> Likewise, I suspect it doesn’t work as intended if there are relative
>> file names in the list, no?
>
> You can see it at work in the tests/file-systems test module; it reduces
>
> (reduce-directories '("./opt/gnu/etc" "./opt/gnu/" "./opt/gnu/bin"
> "./opt/gnu/lib/debug" "./opt/gnuism" "a/b/c"
> "a/b/c"))
>
> into '("./opt/gnu/" "./opt/gnuism" "a/b/c"), none of which are absolute
> file names.

Oh right!

Toggle quote (8 lines)
>> Perhaps we could add an example to the docstring. Also, the word
>> “reduce” doesn’t appear in the docstring, which to me suggests
>> suboptimal naming. ;-)
>
> That the word 'reduce' doesn't appear in the docstring was a conscious
> effort of mine to not bore the reader with repeating the same terms, ah!
> But naming is hard; I'm open to suggestions.

Actually I don’t have a good suggestion. :-)
‘strip-child-directories’ maybe?

Thanks,
Ludo’.
L
L
Ludovic Courtès wrote on 1 Jul 2021 15:26
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)(address . 49149@debbugs.gnu.org)
87bl7mkvvu.fsf@gnu.org
Hi,

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

Toggle quote (35 lines)
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>>
>>> Instead of just naming them by their pack type, add information from the
>>> package(s) they contain to make it easier to differentiate them.
>>>
>>> * guix/scripts/pack.scm (define-with-source): New macro.
>>> (manifest->friendly-name): Extract procedure from ...
>>> (docker-image): ... here, now defined via the above macro. Adjust REPOSITORY
>>> argument value accordingly.
>>> (guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME.
>>
>> [...]
>>
>>> - (define tag
>>> - ;; Compute a meaningful "repository" name, which will show up in
>>> - ;; the output of "docker images".
>>> - (let ((manifest (profile-manifest #$profile)))
>>> - (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
>>
>> I think this should not be factorized because the requirements are very
>> Docker-dependent. Once factorized, it becomes easy to overlook this.
>
> Hmm, I'm not a docker format expert, but my quick reading about it
> turned no restrictions about what a docker image label should look like?
> So perhaps it is not specially Docker-dependent.

It’s a hack specifically written with Docker repository names in mind,
and the 40-or-so character limit, for instance.

Toggle quote (3 lines)
> If there's something truly Docker-dependent about it I'd suggest adding
> a #:docker-compatible? boolean option to the procedure.

To me it’s a case where factorization isn’t beneficial. Even if there’s
a similar procedure used in a different context, it’s still a different
context with different constraints. My 2¢!

Ludo’.
Z
Z
zimoun wrote on 1 Jul 2021 15:52
Re: [bug#49149] [PATCH 0/7] Add deb format for guix pack.
(name . Ludovic Courtès)(address . ludo@gnu.org)
CAJ3okZ2zQ8j6c-T9+7KGzajrhV0Gn1Psx7sD_b95uRZkVAtEmQ@mail.gmail.com
Hi,

On Thu, 1 Jul 2021 at 15:21, Ludovic Courtès <ludo@gnu.org> wrote:

Toggle quote (3 lines)
> Work on layered Docker images, notably by Chris Baines¹, could perhaps
> be handy here.

Do you mean something à la Nixery [1]?


Toggle quote (2 lines)
Cheers,
simon
M
M
Maxim Cournoyer wrote on 4 Jul 2021 05:21
Re: bug#49149: [PATCH 0/7] Add deb format for guix pack.
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 49149@debbugs.gnu.org)
87zgv2228u.fsf@gmail.com
Hi!

Ludovic Courtès <ludo@gnu.org> writes:

Toggle quote (42 lines)
> Hi,
>
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> Ludovic Courtès <ludo@gnu.org> writes:
>>
>>> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>>>
>>>> Instead of just naming them by their pack type, add information from the
>>>> package(s) they contain to make it easier to differentiate them.
>>>>
>>>> * guix/scripts/pack.scm (define-with-source): New macro.
>>>> (manifest->friendly-name): Extract procedure from ...
>>>> (docker-image): ... here, now defined via the above macro. Adjust REPOSITORY
>>>> argument value accordingly.
>>>> (guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME.
>>>
>>> [...]
>>>
>>>> - (define tag
>>>> - ;; Compute a meaningful "repository" name, which will show up in
>>>> - ;; the output of "docker images".
>>>> - (let ((manifest (profile-manifest #$profile)))
>>>> - (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
>>>
>>> I think this should not be factorized because the requirements are very
>>> Docker-dependent. Once factorized, it becomes easy to overlook this.
>>
>> Hmm, I'm not a docker format expert, but my quick reading about it
>> turned no restrictions about what a docker image label should look like?
>> So perhaps it is not specially Docker-dependent.
>
> It’s a hack specifically written with Docker repository names in mind,
> and the 40-or-so character limit, for instance.

The actual name length requirement for a Docker repository name seems to
be that it must be between 2 and 255 characters [0]; the attached patch
ensure that this is respected.

Toggle quote (4 lines)
> To me it’s a case where factorization isn’t beneficial. Even if there’s
> a similar procedure used in a different context, it’s still a different
> context with different constraints. My 2¢!

It seems to me that with the attached patch we get to share what used to
be a Docker-specific abstraction without any added risk (have our cake
and it eat to!).

What do you think?

Thanks,

Maxim
From f3dc90213423bf0a087245bd4bfc8c4a828d4df1 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sat, 3 Jul 2021 23:08:15 -0400
Subject: [PATCH] guix: docker: Ensure repository name length limits are met.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* guix/docker.scm (canonicalize-repository-name): Fix typo in doc. Capture
repository name length limits and ensure they are met, by either truncating or
padding the normalized name.

Reported-by: Ludovic Courtès <ludo@gnu.org>
---
guix/docker.scm | 28 ++++++++++++++++++++++------
1 file changed, 22 insertions(+), 6 deletions(-)

Toggle diff (56 lines)
diff --git a/guix/docker.scm b/guix/docker.scm
index bd952e45ec..4239ccdf9c 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -59,8 +60,13 @@
     (container_config . #nil)))
 
 (define (canonicalize-repository-name name)
-  "\"Repository\" names are restricted to roughtl [a-z0-9_.-].
+  "\"Repository\" names are restricted to roughly [a-z0-9_.-].
 Return a version of TAG that follows these rules."
+  ;; Refer to https://docs.docker.com/docker-hub/repos/.
+  (define min-length 2)
+  (define padding-character #\a)
+  (define max-length 255)
+
   (define ascii-letters
     (string->char-set "abcdefghijklmnopqrstuvwxyz"))
 
@@ -70,11 +76,21 @@ Return a version of TAG that follows these rules."
   (define repo-char-set
     (char-set-union char-set:digit ascii-letters separators))
 
-  (string-map (lambda (chr)
-                (if (char-set-contains? repo-char-set chr)
-                    chr
-                    #\.))
-              (string-trim (string-downcase name) separators)))
+  (define normalized-name
+    (string-map (lambda (chr)
+                  (if (char-set-contains? repo-char-set chr)
+                      chr
+                      #\.))
+                (string-trim (string-downcase name) separators)))
+
+  (let ((l (string-length normalized-name)))
+    (match l
+      ((? (cut > <> max-length))
+       (string-take normalized-name max-length))
+      ((? (cut < <> min-length ))
+       (string-append normalized-name
+                      (make-string (- min-length l) padding-character)))
+      (_ normalized-name))))
 
 (define* (manifest path id #:optional (tag "guix"))
   "Generate a simple image manifest."
-- 
2.32.0
L
L
Ludovic Courtès wrote on 5 Jul 2021 18:14
(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)(address . 49149@debbugs.gnu.org)
87tul8spod.fsf@gnu.org
Hello,

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

[...]

Toggle quote (15 lines)
>> It’s a hack specifically written with Docker repository names in mind,
>> and the 40-or-so character limit, for instance.
>
> The actual name length requirement for a Docker repository name seems to
> be that it must be between 2 and 255 characters [0]; the attached patch
> ensure that this is respected.
>
>> To me it’s a case where factorization isn’t beneficial. Even if there’s
>> a similar procedure used in a different context, it’s still a different
>> context with different constraints. My 2¢!
>
> It seems to me that with the attached patch we get to share what used to
> be a Docker-specific abstraction without any added risk (have our cake
> and it eat to!).

[...]

Toggle quote (14 lines)
> From f3dc90213423bf0a087245bd4bfc8c4a828d4df1 Mon Sep 17 00:00:00 2001
> From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
> Date: Sat, 3 Jul 2021 23:08:15 -0400
> Subject: [PATCH] guix: docker: Ensure repository name length limits are met.
> MIME-Version: 1.0
> Content-Type: text/plain; charset=UTF-8
> Content-Transfer-Encoding: 8bit
>
> * guix/docker.scm (canonicalize-repository-name): Fix typo in doc. Capture
> repository name length limits and ensure they are met, by either truncating or
> padding the normalized name.
>
> Reported-by: Ludovic Courtès <ludo@gnu.org>

LGTM, thank you!

Ludo’.
L
L
Ludovic Courtès wrote on 5 Jul 2021 18:17
Re: [bug#49149] [PATCH 0/7] Add deb format for guix pack.
(name . zimoun)(address . zimon.toutoune@gmail.com)
87pmvwspke.fsf@gnu.org
zimoun <zimon.toutoune@gmail.com> skribis:

Toggle quote (9 lines)
> On Thu, 1 Jul 2021 at 15:21, Ludovic Courtès <ludo@gnu.org> wrote:
>
>> Work on layered Docker images, notably by Chris Baines¹, could perhaps
>> be handy here.
>
> Do you mean something à la Nixery [1]?
>
> 1: <https://tazj.in/blog/nixery-layers>

Yes.

Ludo'.
M
M
Maxim Cournoyer wrote on 5 Jul 2021 22:42
Re: bug#49149: [PATCH 0/7] Add deb format for guix pack.
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 49149-done@debbugs.gnu.org)
87v95o1oij.fsf@gmail.com
Hello,

Ludovic Courtès <ludo@gnu.org> writes:

[...]

Toggle quote (18 lines)
>> From f3dc90213423bf0a087245bd4bfc8c4a828d4df1 Mon Sep 17 00:00:00 2001
>> From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
>> Date: Sat, 3 Jul 2021 23:08:15 -0400
>> Subject: [PATCH] guix: docker: Ensure repository name length limits are met.
>> MIME-Version: 1.0
>> Content-Type: text/plain; charset=UTF-8
>> Content-Transfer-Encoding: 8bit
>>
>> * guix/docker.scm (canonicalize-repository-name): Fix typo in doc. Capture
>> repository name length limits and ensure they are met, by either truncating or
>> padding the normalized name.
>>
>> Reported-by: Ludovic Courtès <ludo@gnu.org>
>
> LGTM, thank you!
>
> Ludo’.

Pushed as 38bcef1c3b.

Thanks!

Maxim
Closed
?
Your comment

This issue is archived.

To comment on this conversation send email to 49149@debbugs.gnu.org