aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-10-10 21:36:58 +0200
committerLudovic Courtès <ludo@gnu.org>2016-10-10 21:40:23 +0200
commitd72267863382041b84a9712eea354882be72ef55 (patch)
tree1240e2211f80a6feee97943881335032ecd71c3c
parent813bcbc4eaa820821c3fc52e539c5244e192601c (diff)
downloadguix-d72267863382041b84a9712eea354882be72ef55.tar
guix-d72267863382041b84a9712eea354882be72ef55.tar.gz
grafts: Always make directories #o755.
Fixes <http://bugs.gnu.org/22954>. Reported by Albin <albin@fripost.org> and Jeffrey Serio <serio.jeffrey@gmail.com>. * guix/build/graft.scm (mkdir-p*): New procedure. (rewrite-directory): Use it instead of 'mkdir-p'.
-rw-r--r--guix/build/graft.scm30
1 files changed, 28 insertions, 2 deletions
diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index b08b65b7cf..7025b72fea 100644
--- a/guix/build/graft.scm
+++ b/guix/build/graft.scm
@@ -210,6 +210,32 @@ an exception is caught."
(print-exception port #f key args)
(primitive-exit 1))))))
+(define* (mkdir-p* dir #:optional (mode #o755))
+ "This is a variant of 'mkdir-p' that works around
+<http://bugs.gnu.org/24659> by passing MODE explicitly in each 'mkdir' call."
+ (define absolute?
+ (string-prefix? "/" dir))
+
+ (define not-slash
+ (char-set-complement (char-set #\/)))
+
+ (let loop ((components (string-tokenize dir not-slash))
+ (root (if absolute?
+ ""
+ ".")))
+ (match components
+ ((head tail ...)
+ (let ((path (string-append root "/" head)))
+ (catch 'system-error
+ (lambda ()
+ (mkdir path mode)
+ (loop tail path))
+ (lambda args
+ (if (= EEXIST (system-error-errno args))
+ (loop tail path)
+ (apply throw args))))))
+ (() #t))))
+
(define* (rewrite-directory directory output mapping
#:optional (store (%store-directory)))
"Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of
@@ -258,7 +284,7 @@ file name pairs."
(define (rewrite-leaf file)
(let ((stat (lstat file))
(dest (destination file)))
- (mkdir-p (dirname dest))
+ (mkdir-p* (dirname dest))
(case (stat:type stat)
((symlink)
(let ((target (readlink file)))
@@ -277,7 +303,7 @@ file name pairs."
store)
(chmod output (stat:perms stat)))))))
((directory)
- (mkdir-p dest))
+ (mkdir-p* dest))
(else
(error "unsupported file type" stat)))))