From 7611565fcee641f83dd2eadbe7f573c0b2fe4240 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Tue, 19 Jan 2021 18:58:48 +0100
Subject: [PATCH 1/2] utils: Add 'mkdir-p/perms'

* guix/build/utils.scm (mkdir-p/perms): New procedure.
* tests/build-utils.scm: Add test for 'mkdir-p/perms'.
---
 guix/build/utils.scm  | 10 +++++++++
 tests/build-utils.scm | 47 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 57 insertions(+)

diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 419c10195b..9f7b89d9bc 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -59,6 +59,7 @@
             reset-gzip-timestamp
             with-directory-excursion
             mkdir-p
+            mkdir-p/perms
             install-file
             make-file-writable
             copy-recursively
@@ -307,6 +308,15 @@ preserve FILE's modification time."
                  (apply throw args))))))
       (() #t))))
 
+(define (mkdir-p/perms directory owner perms)
+  "Create directory DIR and all its ancestors.
+Also set its user and group to OWNER, and its
+permission bits to PERMS. OWNER must be an
+password database entry as returned by getpwent."
+  (mkdir-p directory)
+  (chown directory (passwd:uid owner) (passwd:gid owner))
+  (chmod directory perms))
+
 (define (install-file file directory)
   "Create DIRECTORY if it does not exist and copy FILE in there under the same
 name."
diff --git a/tests/build-utils.scm b/tests/build-utils.scm
index 654b480ed9..557751c858 100644
--- a/tests/build-utils.scm
+++ b/tests/build-utils.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -241,4 +242,50 @@ print('hello world')"))
                                            "/some/other/path")))
          #f)))))
 
+;; this also tests mkdir-p itself
+(let ((owner (getpwuid (getuid)))
+      (test-bits '(#o700 #o070 #o007)))
+  (test-assert "mkdir-p/perms, creates directory"
+    (call-with-temporary-directory
+     (lambda (directory)
+       (let ((foo (string-append directory "/a/dir")))
+         (mkdir-p/perms foo owner #o700)
+         (file-exists? foo)))))
+  ;; Unfortunately, testing owner != user requires root,
+  ;; and thus cannot be tested here on Linux systems.
+  ;; TODO: test this on GNU/Hurd.
+  (test-equal "mkdir-p/perms, set permission bits of new directories"
+    test-bits
+    (map (lambda (bits)
+           (call-with-temporary-directory
+            (lambda (directory)
+              (let ((foo (string-append directory "/a/dir")))
+                (mkdir-p/perms foo owner bits)
+                ;; Prevent ‘warning: failed to delete /tmp/.../dir: Permission denied’
+                ;; noise in the logs.
+                (let ((perms (stat:perms (stat foo))))
+                  (chmod foo #o700)
+                  perms)))))
+         test-bits))
+  (test-equal "mkdir-p/perms, reset permission bits of old directories"
+    test-bits
+    (map (lambda (bits)
+           (call-with-temporary-directory
+            (lambda (directory)
+              (let ((foo (string-append directory "/a/dir")))
+                (mkdir-p/perms foo owner #o000)
+                (mkdir-p/perms foo owner bits)
+                (let ((perms (stat:perms (stat foo))))
+                  (chmod foo #o700)
+                  perms)))))
+         test-bits))
+  (test-equal "mkdir-p, use umask for creating parent directories"
+    (logxor #o777 (umask))
+    (call-with-temporary-directory
+     (lambda (directory)
+       (let* ((foo (string-append directory "/a/dir"))
+              (foo-parent (dirname foo)))
+         (mkdir-p/perms foo owner #o777)
+         (stat:perms (stat foo-parent)))))))
+
 (test-end)
-- 
2.30.0