From 1b4931555b3e876a313ce31273984f3a59b2ec78 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jun 2021 11:26:22 +0200 Subject: deploy: Leave on hard error. Previously, the error message would be displayed, followed by a backtrace ending in &non-continuable. * guix/scripts/deploy.scm (deploy-machine*): Call 'leave' rather than 'report-error' when C is a &message. --- guix/scripts/deploy.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 7c62b05d12..8bb8a7932e 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -129,9 +129,9 @@ Perform the deployment specified by FILE.\n")) (raise c)) ((message-condition? c) - (report-error (G_ "failed to deploy ~a: ~a~%") - (machine-display-name machine) - (condition-message c))) + (leave (G_ "failed to deploy ~a: ~a~%") + (machine-display-name machine) + (condition-message c))) ((deploy-error? c) (when (deploy-error-should-roll-back c) (info (G_ "rolling back ~a...~%") -- cgit v1.2.3 From 7916201c4da9a29abc0ac1ef3ee80c8e3efdcf72 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jun 2021 11:33:27 +0200 Subject: reconfigure: Use 'formatted-message'. * guix/scripts/system/reconfigure.scm (ensure-forward-reconfigure): Use 'formatted-message'. * guix/scripts/deploy.scm (deploy-machine*): Handle it. --- guix/scripts/deploy.scm | 9 +++++++++ guix/scripts/system/reconfigure.scm | 9 ++++----- 2 files changed, 13 insertions(+), 5 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 8bb8a7932e..1707622c4f 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -28,6 +28,8 @@ #:use-module (guix utils) #:use-module (guix grafts) #:use-module (guix status) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -132,6 +134,13 @@ Perform the deployment specified by FILE.\n")) (leave (G_ "failed to deploy ~a: ~a~%") (machine-display-name machine) (condition-message c))) + ((formatted-message? c) + (leave (G_ "failed to deploy ~a: ~a~%") + (machine-display-name machine) + (apply format #f + (gettext (formatted-message-string c) + %gettext-domain) + (formatted-message-arguments c)))) ((deploy-error? c) (when (deploy-error-should-roll-back c) (info (G_ "rolling back ~a...~%") diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 39a818dd0b..49da6ecb16 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -308,12 +308,11 @@ ancestor of COMMIT, unless CHANNEL specifies a commit." ('self #t) (_ (raise (make-compound-condition - (condition - (&message (message - (format #f (G_ "\ + (formatted-message (G_ "\ aborting reconfiguration because commit ~a of channel '~a' is not a descendant of ~a") - commit (channel-name channel) - start))) + commit (channel-name channel) + start) + (condition (&fix-hint (hint (G_ "Use @option{--allow-downgrades} to force this downgrade."))))))))) -- cgit v1.2.3 From 7fe195f3b79a9a1369fa9f14539f82a5b5c880de Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jun 2021 16:11:02 +0200 Subject: guix substitute: Adjust comment about GnuTLS bug. * guix/scripts/substitute.scm (call-with-cached-connection): Adjust comment. --- guix/scripts/substitute.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 3ea1c73e10..03115ffe44 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -423,7 +423,7 @@ server certificates." (list error/invalid-session ;; XXX: These two are not properly handled in - ;; GnuTLS < 3.7.2, in + ;; GnuTLS < 3.7.3, in ;; 'write_to_session_record_port'; see ;; . error/again error/interrupted))) -- cgit v1.2.3 From 0ba4f0caa4148c0e1080218ffcbd32127f41887f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jun 2021 23:34:36 +0200 Subject: pull: Autoload (gnu ...) modules. This reduces startup time for 'guix pull --help' and similar. * guix/scripts/pull.scm: Autoload (gnu ...) modules. --- guix/scripts/pull.scm | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 07613240a8..c880a5b1c8 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2017 Marius Bakke ;;; Copyright © 2020, 2021 Tobias Geerinckx-Rice ;;; @@ -44,14 +44,12 @@ #:select (with-file-lock/no-wait)) #:use-module (guix git) #:use-module (git) - #:use-module (gnu packages) - #:use-module ((guix scripts package) #:select (build-and-use-profile - delete-matching-generations)) - #:use-module ((gnu packages base) #:select (canonical-package)) - #:use-module (gnu packages guile) - #:use-module ((gnu packages bootstrap) - #:select (%bootstrap-guile)) - #:use-module ((gnu packages certs) #:select (le-certs)) + #:autoload (gnu packages) (fold-available-packages) + #:autoload (guix scripts package) (build-and-use-profile + delete-matching-generations) + #:autoload (gnu packages base) (canonical-package) + #:autoload (gnu packages bootstrap) (%bootstrap-guile) + #:autoload (gnu packages certs) (le-certs) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) -- cgit v1.2.3 From f386a993ef9b75e37d708aee5f78312f7bcc9425 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jun 2021 23:36:50 +0200 Subject: pull: Use SRFI-71 instead of SRFI-11. * guix/scripts/pull.scm (display-new/upgraded-packages): Use SRFI-71 'let'. --- guix/scripts/pull.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index c880a5b1c8..fb8ce50fa7 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -51,11 +51,11 @@ #:autoload (gnu packages bootstrap) (%bootstrap-guile) #:autoload (gnu packages certs) (le-certs) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 format) @@ -601,7 +601,7 @@ Return true when there is more package info to display." (string-join lst ", "))) (cut string-join <> ", "))) - (let-values (((new upgraded) (new/upgraded-packages alist1 alist2))) + (let ((new upgraded (new/upgraded-packages alist1 alist2))) (define new-count (length new)) (define upgraded-count (length upgraded)) -- cgit v1.2.3 From fd62b4cf88578ebd8f42ccda94831a254425a329 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jun 2021 23:52:30 +0200 Subject: guix build: Autoload (gnu packages). * guix/scripts/build.scm: Autoload (gnu packages). --- guix/scripts/build.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 97e2f5a167..187ba45e79 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -46,7 +46,9 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) - #:use-module (gnu packages) + #:autoload (gnu packages) (%package-module-path + %patch-path + specification->package) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) -- cgit v1.2.3 From 05528dcd4827ef449e2014794ab74085e57651b9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Jun 2021 00:10:54 +0200 Subject: Revert "guix build: Autoload (gnu packages)." This reverts commit fd62b4cf88578ebd8f42ccda94831a254425a329, which would lead 'GUIX_PACKAGE_PATH' to be ignored for instance when using 'guix build -f file.scm', as shown by 'tests/guix-build.sh'. --- guix/scripts/build.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 187ba45e79..97e2f5a167 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -46,9 +46,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) - #:autoload (gnu packages) (%package-module-path - %patch-path - specification->package) + #:use-module (gnu packages) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) -- cgit v1.2.3 From 5ef96ecaaeeabd5500e406f0103ca52ec079fdb9 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Tue, 29 Jun 2021 00:06:34 +0200 Subject: weather: Handle zero requested store items gracefully. This can happen if the weather information of a package is requested for an unsupported system. For example, try "guix weather icecat --system=aarch64-linux". * guix/scripts/weather.scm (report-server-coverage): Do not divide by zero when zero store items are requested from a server. Fixes: Reported-By: Jack Hill Signed-off-by: Mathieu Othacehe --- guix/scripts/weather.scm | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 6d925d416c..06312d65a2 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017 Ricardo Wurmus ;;; Copyright © 2018 Kyle Meyer ;;; Copyright © 2020 Simon Tournier +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -185,9 +186,12 @@ or #f if it could not be determined." #:key display-missing?) "Report the subset of ITEMS available as substitutes on SERVER. When DISPLAY-MISSING? is true, display the list of missing substitutes. -Return the coverage ratio, an exact number between 0 and 1." +Return the coverage ratio, an exact number between 0 and 1. +In case ITEMS is an empty list, return 1 instead." (define MiB (* (expt 2 20) 1.)) + ;; TRANSLATORS: it is quite possible zero store items are + ;; looked for. (format #t (G_ "looking for ~h store items on ~a...~%") (length items) server) @@ -208,9 +212,10 @@ Return the coverage ratio, an exact number between 0 and 1." narinfos)) (time (+ (time-second time) (/ (time-nanosecond time) 1e9)))) - (format #t (G_ " ~,1f% substitutes available (~h out of ~h)~%") - (* 100. (/ obtained requested 1.)) - obtained requested) + (when (> requested 0) + (format #t (G_ " ~,1f% substitutes available (~h out of ~h)~%") + (* 100. (/ obtained requested 1.)) + obtained requested)) (let ((total (/ (reduce + 0 sizes) MiB))) (match (length sizes) ((? zero?) @@ -299,7 +304,9 @@ are queued~%") ;; Return the coverage ratio. (let ((total (length items))) - (/ (- total (length missing)) total))))) + (if (> total 0) + (/ (- total (length missing)) total) + 1))))) ;;; -- cgit v1.2.3 From 91e837283885ed735782709668c5ea7557e27dfe Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 15 Jun 2021 10:13:29 -0400 Subject: pack: Extract builder code from self-contained-tarball. 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(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 8cb4e6d2cc..ac477850e6 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -172,22 +172,17 @@ dependencies are registered." (computed-file "store-database" build #:options `(#:references-graphs ,(zip labels items)))) -(define* (self-contained-tarball name profile - #:key target - (profile-name "guix-profile") - deduplicate? - entry-point - (compressor (first %compressors)) - localstatedir? - (symlinks '()) - (archiver tar)) - "Return a self-contained tarball containing a store initialized with the -closure of PROFILE, a derivation. The tarball contains /gnu/store; if -LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db -with a properly initialized store database. - -SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be -added to the pack." + +;;; +;;; Tarball format. +;;; +(define* (self-contained-tarball/builder profile + #:key (profile-name "guix-profile") + (compressor (first %compressors)) + localstatedir? + (symlinks '()) + (archiver tar)) + "Return the G-Expression of the builder used for self-contained-tarball." (define database (and localstatedir? (file-append (store-database (list profile)) @@ -209,125 +204,142 @@ added to the pack." (and (not-config? module) (not (equal? '(guix store deduplication) module)))) - (define build - (with-imported-modules (source-module-closure - `((guix build utils) - (guix build union) - (gnu build install)) - #:select? import-module?) - #~(begin - (use-modules (guix build utils) - ((guix build union) #:select (relative-file-name)) - (gnu build install) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (with-imported-modules (source-module-closure + `((guix build utils) + (guix build union) + (gnu build install)) + #:select? import-module?) + #~(begin + (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (define %root "root") + + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownnership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + (,source + -> ,(relative-file-name parent target))))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. For testing, we use the bootstrap tar, which is + ;; older and doesn't support it. + (define tar-supports-sort? + (zero? (system* (string-append #+archiver "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + ;; Make sure non-ASCII file names are properly handled. + #+set-utf8-locale + + ;; Add 'tar' to the search path. + (setenv "PATH" #+(file-append archiver "/bin")) + + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off. + ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs + ;; with hard links: + ;; . + (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: - ;; . - (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 -- cgit v1.2.3 From 7708c0b5e3363e7551da6127268a08b0232061f9 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 21 Jun 2021 00:33:28 -0400 Subject: pack: Factorize base tar options. * 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 (limited to 'guix/scripts') diff --git a/Makefile.am b/Makefile.am index dd34447020..46414b011a 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 +;;; +;;; 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 . + +(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 -- cgit v1.2.3 From f72aa3834b83d4c5e6889aa7698d4bff16e53984 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 17 Jun 2021 01:20:29 -0400 Subject: pack: Fix typo. * guix/scripts/pack.scm (self-contained-tarball/builder): Fix typo. --- guix/scripts/pack.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/scripts') 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 "/") -- cgit v1.2.3 From 6b0e55cde901dd5f6eae72cee10723b7739cadf7 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 17 Jun 2021 15:09:46 -0400 Subject: pack: Improve naming of the packs store file names. 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(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 7ea97a4b7a..952c1455be 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 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 + object." + (let loop ((names (map manifest-entry-name + (manifest-entries manifest)))) + (define str (string-join names "-")) + (if (< (string-length str) 40) + str + (match names + ((_) str) + ((names ... _) (loop names)))))) + ;;; ;;; Tarball format. @@ -540,7 +562,7 @@ the image." (file-append (store-database (list profile)) "/db/db.sqlite"))) - (define defmod 'define-module) ;trick Geiser + (define defmod 'define-module) ;trick Geiser (define build ;; Guile-JSON and Guile-Gcrypt are required by (guix docker). @@ -558,6 +580,8 @@ the image." (srfi srfi-1) (srfi srfi-19) (ice-9 match)) + #$(procedure-source manifest->friendly-name) + (define environment (map (match-lambda ((spec . value) @@ -581,19 +605,6 @@ the image." `((directory "/tmp" ,(getuid) ,(getgid) #o1777) ,@(append-map symlink->directives '#$symlinks))) - (define tag - ;; Compute a meaningful "repository" name, which will show up in - ;; the output of "docker images". - (let ((manifest (profile-manifest #$profile))) - (let loop ((names (map manifest-entry-name - (manifest-entries manifest)))) - (define str (string-join names "-")) - (if (< (string-length str) 40) - str - (match names - ((_) str) - ((names ... _) (loop names))))))) ;drop one entry - (setenv "PATH" #+(file-append archiver "/bin")) (build-docker-image #$output @@ -601,7 +612,8 @@ the image." (call-with-input-file "profile" read-reference-graph)) #$profile - #:repository tag + #:repository (manifest->friendly-name + (profile-manifest #$profile)) #:database #+database #:system (or #$target %host-type) #:environment environment @@ -1209,8 +1221,6 @@ Create a bundle of PACKAGE.\n")) manifest) manifest))) (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) (compressor (if bootstrap? @@ -1244,7 +1254,10 @@ Create a bundle of PACKAGE.\n")) (hooks (if bootstrap? '() %default-profile-hooks)) - (locales? (not bootstrap?))))) + (locales? (not bootstrap?)))) + (name (string-append (manifest->friendly-name manifest) + "-" (symbol->string pack-format) + "-pack"))) (define (lookup-package package) (manifest-lookup manifest (manifest-pattern (name package)))) -- cgit v1.2.3 From 4f3bdc8f21657dbda857027b3ec8754dd4c7c67b Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 17 Jun 2021 01:22:35 -0400 Subject: pack: Prevent duplicate files in tar archives. 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(-) (limited to 'guix/scripts') 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 @@ -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 952c1455be..cee1444110 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 -;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2020, 2021 Maxim Cournoyer ;;; ;;; 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 -- cgit v1.2.3 From 82daab42811a2e3c7684ebdf12af75ff0fa67b99 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 15 Jun 2021 10:21:50 -0400 Subject: pack: Add support for the deb format. * .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. * NEWS: Add news entry. --- .dir-locals.el | 1 + NEWS | 7 +- doc/guix.texi | 5 ++ guix/scripts/pack.scm | 180 +++++++++++++++++++++++++++++++++++++++++++++++++- tests/pack.scm | 75 +++++++++++++++++++++ 5 files changed, 265 insertions(+), 3 deletions(-) (limited to 'guix/scripts') 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/NEWS b/NEWS index 1d3f5aaffd..b0647b3700 100644 --- a/NEWS +++ b/NEWS @@ -4,6 +4,7 @@ Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès Copyright © 2016, 2017, 2018 Ricardo Wurmus +Copyright © 2021 Maxim Cournoyer Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright @@ -11,10 +12,12 @@ Copyright © 2016, 2017, 2018 Ricardo Wurmus Please send Guix bug reports to bug-guix@gnu.org. -* Changes in 1.3.0 (since 1.2.0) - +* Changes in 1.4.0 (since 1.3.0) ** Package management + * New 'deb' format for the 'guix pack' command +* Changes in 1.3.0 (since 1.2.0) +** Package management *** POWER9 (powerpc64le-linux) is now supported as a technology preview *** New ‘--export-manifest’ and ‘--export-channels’ options of ‘guix package’ *** New ‘--profile’ option for ‘guix environment’ diff --git a/doc/guix.texi b/doc/guix.texi index 37936bb0f3..e0668b1f5f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6028,6 +6028,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 symbolic links, +that can be installed on top of any dpkg-based GNU/Linux distribution. + @quotation Note Singularity @emph{requires} you to provide @file{/bin/sh} in the image. For that reason, @command{guix pack -f squashfs} always implies @code{-S diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index cee1444110..6d8b70d1c7 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2018 Efraim Flashner ;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; Copyright © 2020 Eric Bavier +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -65,6 +66,7 @@ %compressors lookup-compressor self-contained-tarball + debian-archive docker-image squashfs-image @@ -346,6 +348,10 @@ added to the pack." #:target target #:references-graphs `(("profile" ,profile)))) + +;;; +;;; Singularity. +;;; (define (singularity-environment-file profile) "Return a shell script that defines the environment variables corresponding to the search paths of PROFILE." @@ -372,6 +378,10 @@ to the search paths of PROFILE." (computed-file "singularity-environment.sh" build)) + +;;; +;;; SquashFS image format. +;;; (define* (squashfs-image name profile #:key target (profile-name "guix-profile") @@ -546,6 +556,10 @@ added to the pack." #:target target #:references-graphs `(("profile" ,profile)))) + +;;; +;;; Docker image format. +;;; (define* (docker-image name profile #:key target (profile-name "guix-profile") @@ -633,6 +647,167 @@ the image." #:target target #:references-graphs `(("profile" ,profile)))) + +;;; +;;; Debian archive format. +;;; +;;; TODO: When relocatable option is selected, install to a unique prefix. +;;; This would enable installation of multiple deb packs with conflicting +;;; files at the same time. +;;; TODO: Allow passing a custom control file from the CLI. +;;; TODO: Allow providing a postinst script. +(define* (debian-archive name profile + #:key target + (profile-name "guix-profile") + deduplicate? + entry-point + (compressor (first %compressors)) + localstatedir? + (symlinks '()) + (archiver tar)) + "Return a Debian archive (.deb) containing a store initialized with the +closure of PROFILE, a derivation. The archive contains /gnu/store; if +LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db +with a properly initialized store database. The supported compressors are +\"none\", \"gz\" or \"xz\". + +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the pack." + ;; For simplicity, limit the supported compressors to the superset of + ;; compressors able to compress both the control file (gz or xz) and the + ;; data tarball (gz, bz2 or xz). + (define %valid-compressors '("gzip" "xz" "none")) + + (let ((compressor-name (compressor-name compressor))) + (unless (member compressor-name %valid-compressors) + (leave (G_ "~a is not a valid Debian archive compressor. \ +Valid compressors are: ~a~%") compressor-name %valid-compressors))) + + (when entry-point + (warning (G_ "entry point not supported in the '~a' format~%") + 'deb)) + + (define data-tarball + (computed-file (string-append "data.tar" + (compressor-extension compressor)) + (self-contained-tarball/builder + profile + #:profile-name profile-name + #:compressor compressor + #:localstatedir? localstatedir? + #:symlinks symlinks + #:archiver archiver) + #:local-build? #f ;allow offloading + #:options (list #:references-graphs `(("profile" ,profile)) + #:target target))) + + (define build + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + `((guix build pack) + (guix build utils) + (guix profiles)) + #:select? not-config?)) + #~(begin + (use-modules (guix build pack) + (guix build utils) + (guix profiles) + (ice-9 match) + (srfi srfi-1)) + + (define machine-type + ;; Extract the machine type from the specified target, else from the + ;; current system. + (and=> (or #$target %host-type) (lambda (triplet) + (first (string-split triplet #\-))))) + + (define (gnu-machine-type->debian-machine-type type) + "Translate machine TYPE from the GNU to Debian terminology." + ;; Debian has its own jargon, different from the one used in GNU, for + ;; machine types (see data/cputable in the sources of dpkg). + (match type + ("i586" "i386") + ("i486" "i386") + ("i686" "i386") + ("x86_64" "amd64") + ("aarch64" "arm64") + ("mipsisa32r6" "mipsr6") + ("mipsisa32r6el" "mipsr6el") + ("mipsisa64r6" "mips64r6") + ("mipsisa64r6el" "mips64r6el") + ("powerpcle" "powerpcel") + ("powerpc64" "ppc64") + ("powerpc64le" "ppc64el") + (machine machine))) + + (define architecture + (gnu-machine-type->debian-machine-type machine-type)) + + #$(procedure-source manifest->friendly-name) + + (define manifest (profile-manifest #$profile)) + + (define single-entry ;manifest entry + (match (manifest-entries manifest) + ((entry) + entry) + (() #f))) + + (define package-name (or (and=> single-entry manifest-entry-name) + (manifest->friendly-name manifest))) + + (define package-version + (or (and=> single-entry manifest-entry-version) + "0.0.0")) + + (define debian-format-version "2.0") + + ;; Generate the debian-binary file. + (call-with-output-file "debian-binary" + (lambda (port) + (format port "~a~%" debian-format-version))) + + (define data-tarball-file-name (strip-store-file-name + #+data-tarball)) + + (copy-file #+data-tarball data-tarball-file-name) + + (define control-tarball-file-name + (string-append "control.tar" + #$(compressor-extension compressor))) + + ;; Write the compressed control tarball. Only the control file is + ;; mandatory (see: 'man deb' and 'man deb-control'). + (call-with-output-file "control" + (lambda (port) + (format port "\ +Package: ~a +Version: ~a +Description: Debian archive generated by GNU Guix. +Maintainer: GNU Guix +Architecture: ~a +~%" package-name package-version architecture))) + + (define tar (string-append #+archiver "/bin/tar")) + + (apply invoke tar + `(,@(tar-base-options + #:tar tar + #:compressor '#+(and=> compressor compressor-command)) + "-cvf" ,control-tarball-file-name + "control")) + + ;; Create the .deb archive using GNU ar. + (invoke (string-append #+binutils "/bin/ar") "-rv" #$output + "debian-binary" + control-tarball-file-name data-tarball-file-name))))) + + (gexp->derivation (string-append name ".deb") + build + #:target target + #:references-graphs `(("profile" ,profile)))) + ;;; ;;; Compiling C programs. @@ -965,7 +1140,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 +1153,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 ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,7 @@ #:use-module ((gnu packages base) #:select (glibc-utf8-locales)) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages compression) #:select (squashfs-tools)) + #:use-module ((gnu packages debian) #:select (dpkg)) #:use-module ((gnu packages guile) #:select (guile-sqlite3)) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) #:use-module (srfi srfi-64)) @@ -56,6 +58,8 @@ (define %tar-bootstrap %bootstrap-coreutils&co) +(define %ar-bootstrap %bootstrap-binutils) + (test-begin "pack") @@ -270,6 +274,77 @@ 1) (pk 'guilelink (readlink "bin")))) (mkdir #$output)))))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "deb archive with symlinks" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (deb (debian-archive "deb-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/opt/gnu/bin" -> "bin")) + #:archiver %tar-bootstrap)) + (check + (gexp->derivation "check-deb-pack" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match) + (ice-9 popen) + (ice-9 rdelim) + (ice-9 textual-ports) + (rnrs base)) + + (setenv "PATH" (string-join + (list (string-append #+%tar-bootstrap "/bin") + (string-append #+dpkg "/bin") + (string-append #+%ar-bootstrap "/bin")) + ":")) + + ;; Validate the output of 'dpkg --info'. + (let* ((port (open-pipe* OPEN_READ "dpkg" "--info" #$deb)) + (info (get-string-all port)) + (exit-val (status:exit-val (close-pipe port)))) + (assert (zero? exit-val)) + + (assert (string-contains + info + (string-append "Package: " + #+(package-name %bootstrap-guile)))) + + (assert (string-contains + info + (string-append "Version: " + #+(package-version %bootstrap-guile))))) + + ;; Sanity check .deb contents. + (invoke "ar" "-xv" #$deb) + (assert (file-exists? "debian-binary")) + (assert (file-exists? "data.tar.gz")) + (assert (file-exists? "control.tar.gz")) + + ;; Verify there are no hard links in data.tar.gz, as hard + ;; links would cause dpkg to fail unpacking the archive. + (define hard-links + (let ((port (open-pipe* OPEN_READ "tar" "-tvf" "data.tar.gz"))) + (let loop ((hard-links '())) + (match (read-line port) + ((? eof-object?) + (assert (zero? (status:exit-val (close-pipe port)))) + hard-links) + (line + (if (string-prefix? "u" line) + (loop (cons line hard-links)) + (loop hard-links))))))) + + (unless (null? hard-links) + (error "hard links found in data.tar.gz" hard-links)) + + (mkdir #$output)))))) (built-derivations (list check))))) (test-end) -- cgit v1.2.3 From 481d66052762c292798e123482e5b8f7358d1876 Mon Sep 17 00:00:00 2001 From: Steve Sprang Date: Tue, 9 Jan 2018 14:10:04 -0800 Subject: package: Improve output appearance when listing packages. * guix/scripts/package.scm (process-query): Use pretty-print-table when listing installed and available packages. Modified-by: Maxim Cournoyer Signed-off-by: Maxim Cournoyer --- guix/scripts/package.scm | 37 ++++++++++++++++++------------------- 1 file changed, 18 insertions(+), 19 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 694959d326..a34ecdcb54 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2019 Tobias Geerinckx-Rice ;;; Copyright © 2020 Ricardo Wurmus ;;; Copyright © 2020 Simon Tournier +;;; Copyright © 2018 Steve Sprang ;;; ;;; This file is part of GNU Guix. ;;; @@ -831,15 +832,14 @@ processed, #f otherwise." (map profile-manifest profiles))) (installed (manifest-entries manifest))) (leave-on-EPIPE - (for-each (match-lambda - (($ name version output path _) - (when (or (not regexp) - (regexp-exec regexp name)) - (format #t "~a\t~a\t~a\t~a~%" - name (or version "?") output path)))) - - ;; Show most recently installed packages last. - (reverse installed)))) + (let ((rows (filter-map + (match-lambda + (($ name version output path _) + (and (regexp-exec regexp name) + (list name (or version "?") output path)))) + installed))) + ;; Show most recently installed packages last. + (pretty-print-table (reverse rows))))) #t) (('list-available regexp) @@ -862,16 +862,15 @@ processed, #f otherwise." result)) '()))) (leave-on-EPIPE - (for-each (match-lambda - ((name version outputs location) - (format #t "~a\t~a\t~a\t~a~%" - name version - (string-join outputs ",") - (location->string location)))) - (sort available - (match-lambda* - (((name1 . _) (name2 . _)) - (stringstring location)))) + (sort available + (match-lambda* + (((name1 . _) (name2 . _)) + (string Date: Wed, 7 Jul 2021 22:58:45 +0200 Subject: substitute: Fix handling of short option "-h". The short option was listed in the help-text, but not recognized. --- guix/scripts/substitute.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 03115ffe44..c044e1d47a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -777,7 +777,7 @@ default value." (loop)))))) ((or ("-V") ("--version")) (show-version-and-exit "guix substitute")) - (("--help") + ((or ("-h") ("--help")) (show-help)) (opts (leave (G_ "~a: unrecognized options~%") opts)))))) -- cgit v1.2.3 From aeded14b8342c1e72afd014a1bc121770f8c3a1c Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 2 Jul 2021 22:47:51 -0400 Subject: pack: Allow embedding custom control files in deb packs. * guix/scripts/pack.scm (self-contained-tarball/builder) [extra-options]: New argument. (self-contained-tarball, squashfs-image, docker-image) (debian-archive): Likewise. Remove two TODO comments. Document EXTRA-OPTIONS. Use the custom control files when provided. (%deb-format-options): New variable. (show-deb-format-options, show-deb-format-options/detailed): New procedures. (%options): Register new options. (show-help): Augment with new usage. (guix-pack): Validate and propagate new argument values. * doc/guix.texi (Invoking guix pack)[deb]: Document how to list advanced options. Add an example. * tests/pack.scm (deb archive...): Provide extra-options to the debian-archive procedure, and validate that the provided files are embedded in the pack. --- doc/guix.texi | 8 ++++ guix/scripts/pack.scm | 121 ++++++++++++++++++++++++++++++++++++++++++-------- tests/pack.scm | 27 ++++++++--- 3 files changed, 133 insertions(+), 23 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index cca46218f2..b3c16e6507 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6047,6 +6047,14 @@ such file or directory'' message. This produces a Debian archive (a package with the @samp{.deb} file extension) containing all the specified binaries and symbolic links, that can be installed on top of any dpkg-based GNU(/Linux) distribution. +Advanced options can be revealed via the @option{--help-deb-format} +option. They allow embedding control files for more fine-grained +control, such as activating specific triggers or providing a maintainer +configure script to run arbitrary setup code upon installation. + +@example +guix pack -f deb -C xz -S /usr/bin/hello=bin/hello hello +@end example @quotation Note Because archives produced with @command{guix pack} contain a collection diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 6d8b70d1c7..6a8d49e042 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -205,7 +205,8 @@ its source property." (compressor (first %compressors)) localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "Return the G-Expression of the builder used for self-contained-tarball." (define database (and localstatedir? @@ -324,7 +325,8 @@ its source property." (compressor (first %compressors)) localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "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 @@ -389,7 +391,8 @@ to the search paths of PROFILE." entry-point localstatedir? (symlinks '()) - (archiver squashfs-tools)) + (archiver squashfs-tools) + (extra-options '())) "Return a squashfs image containing a store initialized with the closure of PROFILE, a derivation. The image contains a subset of /gnu/store, empty mount points for virtual file systems (like procfs), and optional symlinks. @@ -567,7 +570,8 @@ added to the pack." entry-point localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "Return a derivation to construct a Docker image of PROFILE. The image is a tarball conforming to the Docker Image Specification, compressed with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it @@ -654,8 +658,6 @@ the image." ;;; 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") @@ -664,7 +666,8 @@ the image." (compressor (first %compressors)) localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "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 @@ -672,7 +675,8 @@ 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." +added to the pack. EXTRA-OPTIONS may contain the CONFIG-FILE, POSTINST-FILE +or TRIGGERS-FILE keyword arguments." ;; 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). @@ -714,21 +718,23 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (guix build utils) (guix profiles) (ice-9 match) + ((oop goops) #:select (get-keyword)) (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 #\-))))) + (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 - ("i586" "i386") ("i486" "i386") + ("i586" "i386") ("i686" "i386") ("x86_64" "amd64") ("aarch64" "arm64") @@ -773,21 +779,40 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (copy-file #+data-tarball data-tarball-file-name) + ;; Generate the control archive. + (define control-file + (get-keyword #:control-file '#$extra-options)) + + (define postinst-file + (get-keyword #:postinst-file '#$extra-options)) + + (define triggers-file + (get-keyword #:triggers-file '#$extra-options)) + (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 "\ + (if control-file + (copy-file control-file "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))) +~%" package-name package-version architecture)))) + + (when postinst-file + (copy-file postinst-file "postinst") + (chmod "postinst" #o755)) + + (when triggers-file + (copy-file triggers-file "triggers")) (define tar (string-append #+archiver "/bin/tar")) @@ -796,7 +821,9 @@ Architecture: ~a #:tar tar #:compressor '#+(and=> compressor compressor-command)) "-cvf" ,control-tarball-file-name - "control")) + "control" + ,@(if postinst-file '("postinst") '()) + ,@(if triggers-file '("triggers") '()))) ;; Create the .deb archive using GNU ar. (invoke (string-append #+binutils "/bin/ar") "-rv" #$output @@ -1157,6 +1184,34 @@ last resort for relocation." deb Debian archive installable via dpkg/apt")) (newline)) +(define %deb-format-options + (let ((required-option (lambda (symbol) + (option (list (symbol->string symbol)) #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons symbol arg result) + rest)))))) + (list (required-option 'control-file) + (required-option 'postinst-file) + (required-option 'triggers-file)))) + +(define (show-deb-format-options) + (display (G_ " + --help-deb-format list options specific to the deb format"))) + +(define (show-deb-format-options/detailed) + (display (G_ " + --control-file=FILE + Embed the provided control FILE")) + (display (G_ " + --postinst-file=FILE + Embed the provided postinst script")) + (display (G_ " + --triggers-file=FILE + Embed the provided triggers FILE")) + (newline) + (exit 0)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -1250,7 +1305,12 @@ last resort for relocation." (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) - (append %transformation-options + (option '("help-deb-format") #f #f + (lambda args + (show-deb-format-options/detailed))) + + (append %deb-format-options + %transformation-options %standard-build-options))) (define (show-help) @@ -1260,6 +1320,8 @@ Create a bundle of PACKAGE.\n")) (newline) (show-transformation-options-help) (newline) + (show-deb-format-options) + (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) (display (G_ " @@ -1369,6 +1431,18 @@ Create a bundle of PACKAGE.\n")) (else (packages->manifest packages)))))) + (define (process-file-arg opts name) + ;; Validate that the file exists and return it as a object, + ;; else #f. + (let ((value (assoc-ref opts name))) + (match value + ((and (? string?) (not (? file-exists?))) + (leave (G_ "file provided with option ~a does not exist: ~a~%") + (string-append "--" (symbol->string name)) value)) + ((? string?) + (local-file value)) + (#f #f)))) + (with-error-handling (with-store store (with-status-verbosity (assoc-ref opts 'verbosity) @@ -1401,6 +1475,15 @@ Create a bundle of PACKAGE.\n")) manifest) manifest))) (pack-format (assoc-ref opts 'format)) + (extra-options (match pack-format + ('deb + (list #:control-file + (process-file-arg opts 'control-file) + #:postinst-file + (process-file-arg opts 'postinst-file) + #:triggers-file + (process-file-arg opts 'triggers-file))) + (_ '()))) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) (compressor (if bootstrap? @@ -1465,7 +1548,9 @@ to your package list."))) #:profile-name profile-name #:archiver - archiver))) + archiver + #:extra-options + extra-options))) (mbegin %store-monad (mwhen derivation? (return (format #t "~a~%" diff --git a/tests/pack.scm b/tests/pack.scm index 9473d4f384..e9b4c36e0e 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -277,17 +277,25 @@ (built-derivations (list check)))) (unless store (test-skip 1)) - (test-assertm "deb archive with symlinks" store + (test-assertm "deb archive with symlinks and control files" 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)) + (deb (debian-archive + "deb-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/opt/gnu/bin" -> "bin")) + #:archiver %tar-bootstrap + #:extra-options + (list #:triggers-file + (plain-file "triggers" + "activate-noawait /usr/share/icons/hicolor\n") + #:postinst-file + (plain-file "postinst" + "echo running configure script\n")))) (check (gexp->derivation "check-deb-pack" (with-imported-modules '((guix build utils)) @@ -344,6 +352,15 @@ (unless (null? hard-links) (error "hard links found in data.tar.gz" hard-links)) + ;; Verify the presence of the control files. + (invoke "tar" "-xf" "control.tar.gz") + (assert (file-exists? "control")) + (assert (and (file-exists? "postinst") + (= #o111 ;script is executable + (logand #o111 (stat:perms + (stat "postinst")))))) + (assert (file-exists? "triggers")) + (mkdir #$output)))))) (built-derivations (list check))))) -- cgit v1.2.3 From b019496fc3643f0bd837c62078086e3ff51b6001 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 5 Jul 2021 20:03:58 -0400 Subject: pack/deb: Add default section and priority fields to the control file. These fields, while optional per dpkg, are required by other tools such as reprepro, commonly used to generate apt repositories. * guix/scripts/pack.scm (debian-archive): Set the control file section field to 'misc' and the priority field to 'optional'. --- guix/scripts/pack.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix/scripts') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 6a8d49e042..78201d6f5f 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -805,6 +805,8 @@ Version: ~a Description: Debian archive generated by GNU Guix. Maintainer: GNU Guix Architecture: ~a +Priority: optional +Section: misc ~%" package-name package-version architecture)))) (when postinst-file -- cgit v1.2.3 From 11f0698243da27be93b16cec574fbf262279779a Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 6 Jul 2021 12:27:36 -0400 Subject: pack: Streamline how files are included in tarballs. Thanks to Guillem Jover on the OFTC's #debian-dpkg channel for helping with troubleshooting. Letting GNU Tar recursively walk the complete files hierarchy side-steps the risks associated with providing a list of file names: 1. Duplicated files in the archive (recorded as hard links by GNU Tar) 2. Missing parent directories. The above would cause dpkg to malfunction, for example by aborting early and skipping triggers when there were missing parent directories. * guix/scripts/pack.scm (self-contained-tarball/builder): Do not call POPULATE-SINGLE-PROFILE-DIRECTORY, which creates extraneous files such as /root. Instead, call POPULATE-STORE and INSTALL-DATABASE-AND-GC-ROOTS individually to more precisely generate the file system. Replace the list of files by the current directory, "." and streamline the way options are passed. * gnu/system/file-systems.scm (reduce-directories): Remove procedure. * tests/file-systems.scm ("reduce-directories"): Remove test. --- gnu/system/file-systems.scm | 22 -------------------- guix/scripts/pack.scm | 49 +++++++++++++++------------------------------ tests/file-systems.scm | 7 +------ 3 files changed, 17 insertions(+), 61 deletions(-) (limited to 'guix/scripts') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 4a3c1fe008..b9eda80958 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -55,7 +55,6 @@ file-system-dependencies file-system-location - reduce-directories file-system-type-predicate btrfs-subvolume? btrfs-store-subvolume-file-name @@ -266,27 +265,6 @@ For example: (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 record. When the device is a UUID, its representation is chosen depending on diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 78201d6f5f..9e1f270dfb 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -231,17 +231,17 @@ its source property." (with-imported-modules (source-module-closure `((guix build pack) + (guix build store-copy) (guix build utils) (guix build union) - (gnu build install) - (gnu system file-systems)) + (gnu build install)) #:select? import-module?) #~(begin (use-modules (guix build pack) + (guix build store-copy) (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)) @@ -279,11 +279,11 @@ its source property." ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs ;; with hard links: ;; . - (populate-single-profile-directory %root - #:profile #$profile - #:profile-name #$profile-name - #:closure "profile" - #:database #+database) + (populate-store (list "profile") %root #:deduplicate? #f) + + (when #+localstatedir? + (install-database-and-gc-roots %root #+database #$profile + #:profile-name #$profile-name)) ;; Create SYMLINKS. (for-each (cut evaluate-populate-directive <> %root) @@ -291,31 +291,14 @@ its source property." ;; Create the tarball. (with-directory-excursion %root - (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)) - - ,@(reduce-directories - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives)))))))) + ;; GNU Tar recurses directories by default. Simply add the whole + ;; current directory, which contains all the generated files so far. + ;; This avoids creating duplicate files in the archives that would + ;; be stored as hard links by GNU Tar. + (apply invoke tar "-cvf" #$output "." + (tar-base-options + #:tar tar + #:compressor '#+(and=> compressor compressor-command))))))) (define* (self-contained-tarball name profile #:key target diff --git a/tests/file-systems.scm b/tests/file-systems.scm index 80acb6d5b9..7f7c373884 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 -;;; Copyright © 2020, 2021 Maxim Cournoyer +;;; Copyright © 2020 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,11 +50,6 @@ (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 -- cgit v1.2.3