diff options
| -rw-r--r-- | gnu/system/file-systems.scm | 22 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 49 | ||||
| -rw-r--r-- | tests/file-systems.scm | 7 |
3 files changed, 17 insertions, 61 deletions
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 <file-system> 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: ;; <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) + (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 <ludo@gnu.org> -;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; 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 |