02/05: profiles: Ensure the profile's etc/ directory is writable.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit a0dac7a01f766e75dc73200a889f31c3920a2d98
Author: Ludovic Courtès <address@hidden>
Date:   Fri May 8 15:39:45 2015 +0200

    profiles: Ensure the profile's etc/ directory is writable.
    
    Reported by 宋文武 <address@hidden>.
    
    * guix/build/profiles.scm (build-etc/profile,
      ensure-writable-directory): New procedures.
      (build-profile): Use them.
    * tests/profiles.scm ("etc/profile when etc/ already exists"): New test.
---
 guix/build/profiles.scm |   74 +++++++++++++++++++++++++++++++++++++---------
 tests/profiles.scm      |   29 ++++++++++++++++++
 2 files changed, 88 insertions(+), 15 deletions(-)

diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index eda54cb..525d59b 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -21,6 +21,7 @@
   #:use-module (guix build utils)
   #:use-module (guix search-paths)
   #:use-module (srfi srfi-26)
+  #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (ice-9 pretty-print)
   #:export (build-profile))
@@ -57,21 +58,9 @@ user-friendly name of the profile is, for instance 
~/.guix-profile rather than
               port)
      (newline port))))
 
-(define* (build-profile output inputs
-                        #:key manifest search-paths)
-  "Build a user profile from INPUTS in directory OUTPUT.  Write MANIFEST, an
-sexp, to OUTPUT/manifest.  Create OUTPUT/etc/profile with Bash definitions for
-all the variables listed in SEARCH-PATHS."
-  ;; Make the symlinks.
-  (union-build output inputs
-               #:log-port (%make-void-port "w"))
-
-  ;; Store meta-data.
-  (call-with-output-file (string-append output "/manifest")
-    (lambda (p)
-      (pretty-print manifest p)))
-
-  ;; Add a ready-to-use Bash profile.
+(define (build-etc/profile output search-paths)
+  "Build the 'OUTPUT/etc/profile' shell file containing environment variable
+definitions for all the SEARCH-PATHS."
   (mkdir-p (string-append output "/etc"))
   (call-with-output-file (string-append output "/etc/profile")
     (lambda (port)
@@ -99,4 +88,59 @@ all the variables listed in SEARCH-PATHS."
         (for-each (write-environment-variable-definition port)
                   (map (abstract-profile output) variables))))))
 
+(define (ensure-writable-directory directory)
+  "Ensure DIRECTORY exists and is writable.  If DIRECTORY is currently a
+symlink (to a read-only directory in the store), then delete the symlink and
+instead make DIRECTORY a \"real\" directory containing symlinks."
+  (define (unsymlink link)
+    (let* ((target (readlink link))
+           (files  (scandir target
+                            (negate (cut member <> '("." ".."))))))
+      (delete-file link)
+      (mkdir link)
+      (for-each (lambda (file)
+                  (symlink (string-append target "/" file)
+                           (string-append link "/" file)))
+                files)))
+
+  (catch 'system-error
+    (lambda ()
+      (mkdir directory))
+    (lambda args
+      (let ((errno (system-error-errno args)))
+        (if (= errno EEXIST)
+            (let ((stat (lstat directory)))
+              (case (stat:type stat)
+                ((symlink)
+                 ;; "Unsymlink" DIRECTORY so that it is writable.
+                 (unsymlink directory))
+                ((directory)
+                 #t)
+                (else
+                 (error "cannot mkdir because a same-named file exists"
+                        directory))))
+            (apply throw args))))))
+
+(define* (build-profile output inputs
+                        #:key manifest search-paths)
+  "Build a user profile from INPUTS in directory OUTPUT.  Write MANIFEST, an
+sexp, to OUTPUT/manifest.  Create OUTPUT/etc/profile with Bash definitions for
+-all the variables listed in SEARCH-PATHS."
+  ;; Make the symlinks.
+  (union-build output inputs
+               #:log-port (%make-void-port "w"))
+
+  ;; Store meta-data.
+  (call-with-output-file (string-append output "/manifest")
+    (lambda (p)
+      (pretty-print manifest p)))
+
+  ;; Make sure we can write to 'OUTPUT/etc'.  'union-build' above could have
+  ;; made 'etc' a symlink to a read-only sub-directory in the store so we need
+  ;; to work around that.
+  (ensure-writable-directory (string-append output "/etc"))
+
+  ;; Write 'OUTPUT/etc/profile'.
+  (build-etc/profile output search-paths))
+
 ;;; profile.scm ends here
diff --git a/tests/profiles.scm b/tests/profiles.scm
index de1411d..ac7f28b 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -24,6 +24,7 @@
   #:use-module (guix monads)
   #:use-module (guix packages)
   #:use-module (guix derivations)
+  #:use-module (guix build-system trivial)
   #:use-module (gnu packages bootstrap)
   #:use-module ((gnu packages base) #:prefix packages:)
   #:use-module ((gnu packages guile) #:prefix packages:)
@@ -248,6 +249,34 @@
          (and (zero? (close-pipe pipe))
               (string-contains path (string-append profile "/bin"))))))))
 
+(test-assertm "etc/profile when etc/ already exists"
+  ;; Here 'union-build' makes the profile's etc/ a symlink to the package's
+  ;; etc/ directory, which makes it read-only.  Make sure the profile build
+  ;; handles that.
+  (mlet* %store-monad
+      ((thing ->   (dummy-package "dummy"
+                     (build-system trivial-build-system)
+                     (arguments
+                      `(#:guile ,%bootstrap-guile
+                        #:builder
+                        (let ((out (assoc-ref %outputs "out")))
+                          (mkdir out)
+                          (mkdir (string-append out "/etc"))
+                          (call-with-output-file (string-append out "/etc/foo")
+                            (lambda (port)
+                              (display "foo!" port))))))))
+       (entry ->   (package->manifest-entry thing))
+       (drv        (profile-derivation (manifest (list entry))
+                                       #:hooks '()))
+       (profile -> (derivation->output-path drv)))
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (return (and (file-exists? (string-append profile "/etc/profile"))
+                   (string=? (call-with-input-file
+                                 (string-append profile "/etc/foo")
+                               get-string-all)
+                             "foo!"))))))
+
 (test-end "profiles")