diff options
| -rw-r--r-- | guix/build/profiles.scm | 74 | ||||
| -rw-r--r-- | tests/profiles.scm | 29 |
2 files changed, 88 insertions, 15 deletions
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index eda54cb37a..525d59b979 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 de1411dca2..ac7f28bf53 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") |