03/03: grafts: Always make directories #o755.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit d72267863382041b84a9712eea354882be72ef55
Author: Ludovic Courtès <address@hidden>
Date:   Mon Oct 10 21:36:58 2016 +0200

    grafts: Always make directories #o755.
    
    Fixes <http://bugs.gnu.org/22954>.
    Reported by Albin <address@hidden>
    and Jeffrey Serio <address@hidden>.
    
    * guix/build/graft.scm (mkdir-p*): New procedure.
    (rewrite-directory): Use it instead of 'mkdir-p'.
---
 guix/build/graft.scm |   30 ++++++++++++++++++++++++++++--
 1 file changed, 28 insertions(+), 2 deletions(-)

diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index b08b65b..7025b72 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)))))