summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/system/file-systems.scm56
-rw-r--r--guix/scripts/pack.scm6
-rw-r--r--tests/file-systems.scm7
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 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 <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