* [bug#49149] [PATCH] tentatively reuse rlib for cargo-build-system
2021-06-21 6:11 ` [bug#49149] [PATCH 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
@ 2021-06-21 6:11 ` Maxim Cournoyer
2021-06-21 20:28 ` Maxim Cournoyer
2021-06-21 6:12 ` [bug#49149] [PATCH 2/7] pack: Factorize base tar options Maxim Cournoyer
` (5 subsequent siblings)
6 siblings, 1 reply; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-21 6:11 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
---
guix/build-system/cargo.scm | 3 +-
guix/build/cargo-build-system.scm | 78 ++++++++++++++++++++++++++-----
2 files changed, 68 insertions(+), 13 deletions(-)
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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH 2/7] pack: Factorize base tar options.
2021-06-21 6:11 ` [bug#49149] [PATCH 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
2021-06-21 6:11 ` [bug#49149] [PATCH] tentatively reuse rlib for cargo-build-system Maxim Cournoyer
@ 2021-06-21 6:12 ` Maxim Cournoyer
2021-06-21 6:12 ` [bug#49149] [PATCH 3/7] pack: Fix typo Maxim Cournoyer
` (4 subsequent siblings)
6 siblings, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-21 6:12 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
* guix/docker.scm (%tar-determinism-options): Move to a new module and rename
to `tar-base-options'. Adjust references accordingly.
* guix/build/pack.scm: New file.
* Makefile.am (MODULES): Register it.
* guix/scripts/pack.scm (self-contained-tarball/builder): Use it.
---
Makefile.am | 1 +
guix/build/pack.scm | 52 +++++++++++++++++++++++++++
guix/docker.scm | 20 ++---------
guix/scripts/pack.scm | 81 +++++++++++++++++--------------------------
4 files changed, 87 insertions(+), 67 deletions(-)
create mode 100644 guix/build/pack.scm
diff --git a/Makefile.am b/Makefile.am
index aa21b5383b..9c4b33c77a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -220,6 +220,7 @@ MODULES = \
guix/build/linux-module-build-system.scm \
guix/build/store-copy.scm \
guix/build/json.scm \
+ guix/build/pack.scm \
guix/build/utils.scm \
guix/build/union.scm \
guix/build/profiles.scm \
diff --git a/guix/build/pack.scm b/guix/build/pack.scm
new file mode 100644
index 0000000000..05c7a3c594
--- /dev/null
+++ b/guix/build/pack.scm
@@ -0,0 +1,52 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build pack)
+ #:use-module (guix build utils)
+ #:export (tar-base-options))
+
+(define* (tar-base-options #:key tar compressor)
+ "Return the base GNU tar options required to produce deterministic archives
+deterministically. When TAR, a GNU tar command file name, is provided, the
+`--sort' option is used only if supported. When COMPRESSOR, a command such as
+'(\"gzip\" \"-9n\"), is provided, the compressor is explicitly specified via
+the `-I' option."
+ (define (tar-supports-sort? tar)
+ (zero? (system* tar "cf" "/dev/null" "--files-from=/dev/null"
+ "--sort=name")))
+
+ `(,@(if compressor
+ (list "-I" (string-join compressor))
+ '())
+ ;; The --sort option was added to GNU tar in version 1.28, released
+ ;; 2014-07-28. For testing, we use the bootstrap tar, which is older
+ ;; and doesn't support it.
+ ,@(if (and=> tar tar-supports-sort?)
+ '("--sort=name")
+ '())
+ ;; Use GNU format so there's no file name length limitation.
+ "--format=gnu"
+ "--mtime=@1"
+ "--owner=root:0"
+ "--group=root:0"
+ ;; The 'nlink' of the store item files leads tar to store hard links
+ ;; instead of actual copies. However, the 'nlink' count depends on
+ ;; deduplication in the store; it's an "implicit input" to the build
+ ;; process. Use '--hard-dereference' to eliminate it.
+ "--hard-dereference"
+ "--check-links"))
diff --git a/guix/docker.scm b/guix/docker.scm
index 889aaeacb5..bd952e45ec 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -21,6 +21,7 @@
(define-module (guix docker)
#:use-module (gcrypt hash)
#:use-module (guix base16)
+ #:use-module (guix build pack)
#:use-module ((guix build utils)
#:select (mkdir-p
delete-file-recursively
@@ -110,18 +111,6 @@ Return a version of TAG that follows these rules."
(rootfs . ((type . "layers")
(diff_ids . #(,(layer-diff-id layer)))))))
-(define %tar-determinism-options
- ;; GNU tar options to produce archives deterministically.
- '("--sort=name" "--mtime=@1"
- "--owner=root:0" "--group=root:0"
-
- ;; When 'build-docker-image' is passed store items, the 'nlink' of the
- ;; files therein leads tar to store hard links instead of actual copies.
- ;; However, the 'nlink' count depends on deduplication in the store; it's
- ;; an "implicit input" to the build process. '--hard-dereference'
- ;; eliminates it.
- "--hard-dereference"))
-
(define directive-file
;; Return the file or directory created by a 'evaluate-populate-directive'
;; directive.
@@ -238,7 +227,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
(apply invoke "tar" "-cf" "../layer.tar"
`(,@transformation-options
- ,@%tar-determinism-options
+ ,@(tar-base-options)
,@paths
,@(scandir "."
(lambda (file)
@@ -273,9 +262,6 @@ SRFI-19 time-utc object, as the creation time in metadata."
(scm->json (repositories prefix id repository)))))
(apply invoke "tar" "-cf" image "-C" directory
- `(,@%tar-determinism-options
- ,@(if compressor
- (list "-I" (string-join compressor))
- '())
+ `(,@(tar-base-options #:compressor compressor)
"."))
(delete-file-recursively directory)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index ac477850e6..d11f498925 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -205,12 +205,14 @@ dependencies are registered."
(not (equal? '(guix store deduplication) module))))
(with-imported-modules (source-module-closure
- `((guix build utils)
+ `((guix build pack)
+ (guix build utils)
(guix build union)
(gnu build install))
#:select? import-module?)
#~(begin
- (use-modules (guix build utils)
+ (use-modules (guix build pack)
+ (guix build utils)
((guix build union) #:select (relative-file-name))
(gnu build install)
(srfi srfi-1)
@@ -240,19 +242,10 @@ dependencies are registered."
;; Fully-qualified symlinks.
(append-map symlink->directives '#$symlinks))
- ;; The --sort option was added to GNU tar in version 1.28, released
- ;; 2014-07-28. For testing, we use the bootstrap tar, which is
- ;; older and doesn't support it.
- (define tar-supports-sort?
- (zero? (system* (string-append #+archiver "/bin/tar")
- "cf" "/dev/null" "--files-from=/dev/null"
- "--sort=name")))
-
;; Make sure non-ASCII file names are properly handled.
#+set-utf8-locale
- ;; Add 'tar' to the search path.
- (setenv "PATH" #+(file-append archiver "/bin"))
+ (define tar #+(file-append archiver "/bin/tar"))
;; Note: there is not much to gain here with deduplication and there
;; is the overhead of the '.links' directory, so turn it off.
@@ -269,45 +262,33 @@ dependencies are registered."
(for-each (cut evaluate-populate-directive <> %root)
directives)
- ;; Create the tarball. Use GNU format so there's no file name
- ;; length limitation.
+ ;; Create the tarball.
(with-directory-excursion %root
- (apply invoke "tar"
- #+@(if (compressor-command compressor)
- #~("-I"
- (string-join
- '#+(compressor-command compressor)))
- #~())
- "--format=gnu"
- ;; Avoid non-determinism in the archive.
- ;; Use mtime = 1, not zero, because that is what the daemon
- ;; does for files in the store (see the 'mtimeStore' constant
- ;; in local-store.cc.)
- (if tar-supports-sort? "--sort=name" "--mtime=@1")
- "--owner=root:0"
- "--group=root:0"
- "--check-links"
- "-cvf" #$output
- ;; Avoid adding / and /var to the tarball, so
- ;; that the ownership and permissions of those
- ;; directories will not be overwritten when
- ;; extracting the archive. Do not include /root
- ;; because the root account might have a
- ;; different home directory.
- #$@(if localstatedir?
- '("./var/guix")
- '())
-
- (string-append "." (%store-directory))
-
- (delete-duplicates
- (filter-map (match-lambda
- (('directory directory)
- (string-append "." directory))
- ((source '-> _)
- (string-append "." source))
- (_ #f))
- directives)))))))
+ (apply invoke tar
+ `(,@(tar-base-options
+ #:tar tar
+ #:compressor '#+(and=> compressor compressor-command))
+ "-cvf" ,#$output
+ ;; Avoid adding / and /var to the tarball, so
+ ;; that the ownership and permissions of those
+ ;; directories will not be overwritten when
+ ;; extracting the archive. Do not include /root
+ ;; because the root account might have a
+ ;; different home directory.
+ ,#$@(if localstatedir?
+ '("./var/guix")
+ '())
+
+ ,(string-append "." (%store-directory))
+
+ ,@(delete-duplicates
+ (filter-map (match-lambda
+ (('directory directory)
+ (string-append "." directory))
+ ((source '-> _)
+ (string-append "." source))
+ (_ #f))
+ directives))))))))
(define* (self-contained-tarball name profile
#:key target
--
2.32.0
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH 3/7] pack: Fix typo.
2021-06-21 6:11 ` [bug#49149] [PATCH 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
2021-06-21 6:11 ` [bug#49149] [PATCH] tentatively reuse rlib for cargo-build-system Maxim Cournoyer
2021-06-21 6:12 ` [bug#49149] [PATCH 2/7] pack: Factorize base tar options Maxim Cournoyer
@ 2021-06-21 6:12 ` Maxim Cournoyer
2021-06-21 6:12 ` [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names Maxim Cournoyer
` (3 subsequent siblings)
6 siblings, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-21 6:12 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
* guix/scripts/pack.scm (self-contained-tarball/builder): Fix typo.
---
guix/scripts/pack.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names.
2021-06-21 6:11 ` [bug#49149] [PATCH 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
` (2 preceding siblings ...)
2021-06-21 6:12 ` [bug#49149] [PATCH 3/7] pack: Fix typo Maxim Cournoyer
@ 2021-06-21 6:12 ` Maxim Cournoyer
2021-06-21 18:11 ` Maxime Devos
2021-06-21 6:12 ` [bug#49149] [PATCH 5/7] pack: Prevent duplicate files in tar archives Maxim Cournoyer
` (2 subsequent siblings)
6 siblings, 1 reply; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-21 6:12 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
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)
+ "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))
+
\f
;;;
;;; 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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names.
2021-06-21 6:12 ` [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names Maxim Cournoyer
@ 2021-06-21 18:11 ` Maxime Devos
2021-06-22 14:03 ` Maxim Cournoyer
2021-06-23 21:16 ` [bug#49149] [PATCH 0/7] Add deb format for guix pack Ludovic Courtès
0 siblings, 2 replies; 52+ messages in thread
From: Maxime Devos @ 2021-06-21 18:11 UTC (permalink / raw)
To: Maxim Cournoyer, 49149
[-- Attachment #1: Type: text/plain, Size: 1722 bytes --]
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):
(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.
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 52+ messages in thread* [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names.
2021-06-21 18:11 ` Maxime Devos
@ 2021-06-22 14:03 ` Maxim Cournoyer
2021-06-23 10:22 ` Maxime Devos
2021-06-23 21:16 ` [bug#49149] [PATCH 0/7] Add deb format for guix pack Ludovic Courtès
1 sibling, 1 reply; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-22 14:03 UTC (permalink / raw)
To: Maxime Devos; +Cc: 49149
Hello Maxime,
Maxime Devos <maximedevos@telenet.be> writes:
> 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.
> (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
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names.
2021-06-22 14:03 ` Maxim Cournoyer
@ 2021-06-23 10:22 ` Maxime Devos
2021-06-24 4:40 ` [bug#49149] [PATCH v2 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
2021-06-24 4:44 ` [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names Maxim Cournoyer
0 siblings, 2 replies; 52+ messages in thread
From: Maxime Devos @ 2021-06-23 10:22 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 49149
[-- Attachment #1: Type: text/plain, Size: 2471 bytes --]
> 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.
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 52+ messages in thread* [bug#49149] [PATCH v2 1/7] pack: Extract builder code from self-contained-tarball.
2021-06-23 10:22 ` Maxime Devos
@ 2021-06-24 4:40 ` Maxim Cournoyer
2021-06-24 4:40 ` [bug#49149] [PATCH v2 2/7] pack: Factorize base tar options Maxim Cournoyer
` (5 more replies)
2021-06-24 4:44 ` [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names Maxim Cournoyer
1 sibling, 6 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-24 4:40 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
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(-)
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."
+\f
+;;;
+;;; 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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH v2 2/7] pack: Factorize base tar options.
2021-06-24 4:40 ` [bug#49149] [PATCH v2 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
@ 2021-06-24 4:40 ` Maxim Cournoyer
2021-06-24 4:40 ` [bug#49149] [PATCH v2 3/7] pack: Fix typo Maxim Cournoyer
` (4 subsequent siblings)
5 siblings, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-24 4:40 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
* guix/docker.scm (%tar-determinism-options): Move to a new module and rename
to `tar-base-options'. Adjust references accordingly.
* guix/build/pack.scm: New file.
* Makefile.am (MODULES): Register it.
* guix/scripts/pack.scm (self-contained-tarball/builder): Use it.
---
Makefile.am | 1 +
guix/build/pack.scm | 52 +++++++++++++++++++++++++++
guix/docker.scm | 20 ++---------
guix/scripts/pack.scm | 81 +++++++++++++++++--------------------------
4 files changed, 87 insertions(+), 67 deletions(-)
create mode 100644 guix/build/pack.scm
diff --git a/Makefile.am b/Makefile.am
index 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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH v2 3/7] pack: Fix typo.
2021-06-24 4:40 ` [bug#49149] [PATCH v2 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
2021-06-24 4:40 ` [bug#49149] [PATCH v2 2/7] pack: Factorize base tar options Maxim Cournoyer
@ 2021-06-24 4:40 ` Maxim Cournoyer
2021-06-24 4:40 ` [bug#49149] [PATCH v2 4/7] pack: Improve naming of the packs store file names Maxim Cournoyer
` (3 subsequent siblings)
5 siblings, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-24 4:40 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
* guix/scripts/pack.scm (self-contained-tarball/builder): Fix typo.
---
guix/scripts/pack.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH v2 4/7] pack: Improve naming of the packs store file names.
2021-06-24 4:40 ` [bug#49149] [PATCH v2 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
2021-06-24 4:40 ` [bug#49149] [PATCH v2 2/7] pack: Factorize base tar options Maxim Cournoyer
2021-06-24 4:40 ` [bug#49149] [PATCH v2 3/7] pack: Fix typo Maxim Cournoyer
@ 2021-06-24 4:40 ` Maxim Cournoyer
2021-06-26 5:03 ` [bug#49149] [PATCH 0/7] Add deb format for guix pack Maxim Cournoyer
2021-06-30 10:13 ` Ludovic Courtès
2021-06-24 4:40 ` [bug#49149] [PATCH v2 5/7] pack: Prevent duplicate files in tar archives Maxim Cournoyer
` (2 subsequent siblings)
5 siblings, 2 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-24 4:40 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
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(-)
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))))))
+
\f
;;;
;;; 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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-06-24 4:40 ` [bug#49149] [PATCH v2 4/7] pack: Improve naming of the packs store file names Maxim Cournoyer
@ 2021-06-26 5:03 ` Maxim Cournoyer
2021-06-30 10:13 ` Ludovic Courtès
1 sibling, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-26 5:03 UTC (permalink / raw)
To: 49149
Hi,
Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:
[...]
> +(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.
> + (eval-when (load eval)
> + (set-procedure-property! variable 'source
> + '(define (variable args ...) body body* ...)))))
> +
Thanks,
Maxim
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-06-24 4:40 ` [bug#49149] [PATCH v2 4/7] pack: Improve naming of the packs store file names Maxim Cournoyer
2021-06-26 5:03 ` [bug#49149] [PATCH 0/7] Add deb format for guix pack Maxim Cournoyer
@ 2021-06-30 10:13 ` Ludovic Courtès
2021-06-30 18:36 ` Maxim Cournoyer
1 sibling, 1 reply; 52+ messages in thread
From: Ludovic Courtès @ 2021-06-30 10:13 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 49149
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.
Ludo’.
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-06-30 10:13 ` Ludovic Courtès
@ 2021-06-30 18:36 ` Maxim Cournoyer
2021-07-01 13:26 ` Ludovic Courtès
0 siblings, 1 reply; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-30 18:36 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 49149
Hello,
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.
If there's something truly Docker-dependent about it I'd suggest adding
a #:docker-compatible? boolean option to the procedure.
Maxim
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-06-30 18:36 ` Maxim Cournoyer
@ 2021-07-01 13:26 ` Ludovic Courtès
2021-07-04 3:21 ` Maxim Cournoyer
0 siblings, 1 reply; 52+ messages in thread
From: Ludovic Courtès @ 2021-07-01 13:26 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 49149
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.
> 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’.
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-07-01 13:26 ` Ludovic Courtès
@ 2021-07-04 3:21 ` Maxim Cournoyer
2021-07-05 16:14 ` Ludovic Courtès
0 siblings, 1 reply; 52+ messages in thread
From: Maxim Cournoyer @ 2021-07-04 3:21 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 49149
[-- Attachment #1: Type: text/plain, Size: 2500 bytes --]
Hi!
Ludovic Courtès <ludo@gnu.org> writes:
> 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.
> 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
[-- Attachment #2: 0001-guix-docker-Ensure-repository-name-length-limits-are.patch --]
[-- Type: text/x-patch, Size: 2731 bytes --]
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(-)
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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-07-04 3:21 ` Maxim Cournoyer
@ 2021-07-05 16:14 ` Ludovic Courtès
2021-07-05 20:42 ` Maxim Cournoyer
0 siblings, 1 reply; 52+ messages in thread
From: Ludovic Courtès @ 2021-07-05 16:14 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 49149
Hello,
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
[...]
>> 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!).
[...]
> 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’.
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-07-05 16:14 ` Ludovic Courtès
@ 2021-07-05 20:42 ` Maxim Cournoyer
0 siblings, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-07-05 20:42 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 49149-done
Hello,
Ludovic Courtès <ludo@gnu.org> writes:
[...]
>> 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
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH v2 5/7] pack: Prevent duplicate files in tar archives.
2021-06-24 4:40 ` [bug#49149] [PATCH v2 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
` (2 preceding siblings ...)
2021-06-24 4:40 ` [bug#49149] [PATCH v2 4/7] pack: Improve naming of the packs store file names Maxim Cournoyer
@ 2021-06-24 4:40 ` Maxim Cournoyer
2021-06-24 4:40 ` [bug#49149] [PATCH v2 6/7] tests: pack: Fix compressor extension Maxim Cournoyer
2021-06-24 4:40 ` [bug#49149] [PATCH v2 7/7] pack: Add support for the deb format Maxim Cournoyer
5 siblings, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-24 4:40 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
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(-)
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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH v2 6/7] tests: pack: Fix compressor extension.
2021-06-24 4:40 ` [bug#49149] [PATCH v2 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
` (3 preceding siblings ...)
2021-06-24 4:40 ` [bug#49149] [PATCH v2 5/7] pack: Prevent duplicate files in tar archives Maxim Cournoyer
@ 2021-06-24 4:40 ` Maxim Cournoyer
2021-06-24 4:40 ` [bug#49149] [PATCH v2 7/7] pack: Add support for the deb format Maxim Cournoyer
5 siblings, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-24 4:40 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
* 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(-)
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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH v2 7/7] pack: Add support for the deb format.
2021-06-24 4:40 ` [bug#49149] [PATCH v2 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
` (4 preceding siblings ...)
2021-06-24 4:40 ` [bug#49149] [PATCH v2 6/7] tests: pack: Fix compressor extension Maxim Cournoyer
@ 2021-06-24 4:40 ` Maxim Cournoyer
2021-06-26 16:58 ` Maxime Devos
2021-06-30 10:10 ` [bug#49149] " Ludovic Courtès
5 siblings, 2 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-24 4:40 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
* .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(-)
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))))
+\f
+;;;
+;;; 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))
+\f
+;;;
+;;; 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))))
+\f
+;;;
+;;; 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))))
+\f
+;;;
+;;; 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))))
+
\f
;;;
;;; 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)
+
\f
(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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH v2 7/7] pack: Add support for the deb format.
2021-06-24 4:40 ` [bug#49149] [PATCH v2 7/7] pack: Add support for the deb format Maxim Cournoyer
@ 2021-06-26 16:58 ` Maxime Devos
2021-06-29 19:20 ` bug#49149: [PATCH 0/7] Add deb format for guix pack Maxim Cournoyer
2021-06-30 10:10 ` [bug#49149] " Ludovic Courtès
1 sibling, 1 reply; 52+ messages in thread
From: Maxime Devos @ 2021-06-26 16:58 UTC (permalink / raw)
To: Maxim Cournoyer, 49149
[-- Attachment #1: Type: text/plain, Size: 898 bytes --]
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?
Greetings,
Maxime.
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 52+ messages in thread* bug#49149: [PATCH 0/7] Add deb format for guix pack.
2021-06-26 16:58 ` Maxime Devos
@ 2021-06-29 19:20 ` Maxim Cournoyer
0 siblings, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-29 19:20 UTC (permalink / raw)
To: Maxime Devos; +Cc: 49149-done
Hello!
Maxime Devos <maximedevos@telenet.be> writes:
> 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
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-06-24 4:40 ` [bug#49149] [PATCH v2 7/7] pack: Add support for the deb format Maxim Cournoyer
2021-06-26 16:58 ` Maxime Devos
@ 2021-06-30 10:10 ` Ludovic Courtès
1 sibling, 0 replies; 52+ messages in thread
From: Ludovic Courtès @ 2021-06-30 10:10 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 49149
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
> --- 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’.
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names.
2021-06-23 10:22 ` Maxime Devos
2021-06-24 4:40 ` [bug#49149] [PATCH v2 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
@ 2021-06-24 4:44 ` Maxim Cournoyer
1 sibling, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-24 4:44 UTC (permalink / raw)
To: Maxime Devos; +Cc: 49149
Hello Maxime & Ludovic,
Maxime Devos <maximedevos@telenet.be> writes:
>> 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:
--8<---------------cut here---------------start------------->8---
(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))))))
--8<---------------cut here---------------end--------------->8---
And then use it inside the build G-Exp via:
#$(procedure-source manifest->friendly-name)
The pack tests are still passing.
Maxim
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-06-21 18:11 ` Maxime Devos
2021-06-22 14:03 ` Maxim Cournoyer
@ 2021-06-23 21:16 ` Ludovic Courtès
1 sibling, 0 replies; 52+ messages in thread
From: Ludovic Courtès @ 2021-06-23 21:16 UTC (permalink / raw)
To: Maxime Devos; +Cc: 49149, Maxim Cournoyer
Hi,
Maxime Devos <maximedevos@telenet.be> skribis:
> Maxim Cournoyer schreef op ma 21-06-2021 om 02:12 [-0400]:
[...]
>> +;;; 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!
> Alternatively, some macroology (untested, may need some tweaks):
See also ‘define-os-with-source’ in (gnu tests).
HTH,
Ludo’.
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH 5/7] pack: Prevent duplicate files in tar archives.
2021-06-21 6:11 ` [bug#49149] [PATCH 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
` (3 preceding siblings ...)
2021-06-21 6:12 ` [bug#49149] [PATCH 4/7] pack: Improve naming of the packs store file names Maxim Cournoyer
@ 2021-06-21 6:12 ` Maxim Cournoyer
2021-06-30 10:06 ` [bug#49149] [PATCH 0/7] Add deb format for guix pack Ludovic Courtès
2021-06-21 6:12 ` [bug#49149] [PATCH 6/7] tests: pack: Fix compressor extension Maxim Cournoyer
2021-06-21 6:12 ` [bug#49149] [PATCH 7/7] pack: Add support for the deb format Maxim Cournoyer
6 siblings, 1 reply; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-21 6:12 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
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(-)
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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-06-21 6:12 ` [bug#49149] [PATCH 5/7] pack: Prevent duplicate files in tar archives Maxim Cournoyer
@ 2021-06-30 10:06 ` Ludovic Courtès
2021-06-30 18:16 ` Maxim Cournoyer
0 siblings, 1 reply; 52+ messages in thread
From: Ludovic Courtès @ 2021-06-30 10:06 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 49149
Hi,
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
> 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.
[...]
> (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.
> +(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’.
^ permalink raw reply [flat|nested] 52+ messages in thread* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-06-30 10:06 ` [bug#49149] [PATCH 0/7] Add deb format for guix pack Ludovic Courtès
@ 2021-06-30 18:16 ` Maxim Cournoyer
2021-07-01 13:24 ` Ludovic Courtès
0 siblings, 1 reply; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-30 18:16 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 49149
Hey,
Ludovic Courtès <ludo@gnu.org> writes:
[...]
>> (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:
--8<---------------cut here---------------start------------->8---
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))
--8<---------------cut here---------------end--------------->8---
(define (file-name-depth file-name)
(length (string-tokenize file-name %not-slash)))
> 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 :-).
>> +(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.
> 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
^ permalink raw reply [flat|nested] 52+ messages in thread* [bug#49149] [PATCH 0/7] Add deb format for guix pack.
2021-06-30 18:16 ` Maxim Cournoyer
@ 2021-07-01 13:24 ` Ludovic Courtès
0 siblings, 0 replies; 52+ messages in thread
From: Ludovic Courtès @ 2021-07-01 13:24 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 49149
Hi!
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
[...]
>>> (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:
[...]
> + (define (absolute? file)
> + (string-prefix? "/" file))
> +
> + (if (or (every absolute? (list file1 file2))
> + (every (negate absolute?) (list file1 file2)))
Yes, that could work.
>> 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.
>>> +(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!
>> 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’.
^ permalink raw reply [flat|nested] 52+ messages in thread
* [bug#49149] [PATCH 6/7] tests: pack: Fix compressor extension.
2021-06-21 6:11 ` [bug#49149] [PATCH 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
` (4 preceding siblings ...)
2021-06-21 6:12 ` [bug#49149] [PATCH 5/7] pack: Prevent duplicate files in tar archives Maxim Cournoyer
@ 2021-06-21 6:12 ` Maxim Cournoyer
2021-06-21 6:12 ` [bug#49149] [PATCH 7/7] pack: Add support for the deb format Maxim Cournoyer
6 siblings, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-21 6:12 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
* 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(-)
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
^ permalink raw reply related [flat|nested] 52+ messages in thread* [bug#49149] [PATCH 7/7] pack: Add support for the deb format.
2021-06-21 6:11 ` [bug#49149] [PATCH 1/7] pack: Extract builder code from self-contained-tarball Maxim Cournoyer
` (5 preceding siblings ...)
2021-06-21 6:12 ` [bug#49149] [PATCH 6/7] tests: pack: Fix compressor extension Maxim Cournoyer
@ 2021-06-21 6:12 ` Maxim Cournoyer
6 siblings, 0 replies; 52+ messages in thread
From: Maxim Cournoyer @ 2021-06-21 6:12 UTC (permalink / raw)
To: 49149; +Cc: Maxim Cournoyer
* .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(-)
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))))
+\f
+;;;
+;;; 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))
+\f
+;;;
+;;; 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))))
+\f
+;;;
+;;; 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))))
+\f
+;;;
+;;; 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))))
+
\f
;;;
;;; 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)
+
\f
(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
^ permalink raw reply related [flat|nested] 52+ messages in thread