diff options
| -rw-r--r-- | guix/build/profiles.scm | 15 | ||||
| -rw-r--r-- | tests/profiles.scm | 36 |
2 files changed, 48 insertions, 3 deletions
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index df785c85a7..0c23cd300e 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -94,12 +94,20 @@ definitions for all the SEARCH-PATHS." (for-each (write-environment-variable-definition port) (map (abstract-profile output) variables)))))) -(define (ensure-writable-directory directory) +(define* (ensure-writable-directory directory + #:key (symlink symlink)) "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 (absolute? file) + (string-prefix? "/" file)) + (define (unsymlink link) - (let* ((target (readlink link)) + (let* ((target (match (readlink link) + ((? absolute? target) + target) + ((? string? relative) + (string-append (dirname link) "/" relative)))) ;; TARGET might itself be a symlink, so append "/" to make sure ;; 'scandir' enters it. (files (scandir (string-append target "/") @@ -149,7 +157,8 @@ SEARCH-PATHS." ;; 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")) + (ensure-writable-directory (string-append output "/etc") + #:symlink symlink) ;; Write 'OUTPUT/etc/profile'. (build-etc/profile output search-paths)) diff --git a/tests/profiles.scm b/tests/profiles.scm index 3a59a0cc4f..9f366a04ef 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -20,6 +20,7 @@ (define-module (test-profiles) #:use-module (guix tests) #:use-module (guix profiles) + #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix grafts) @@ -543,6 +544,41 @@ get-string-all) "foo!")))))) +(test-assertm "profile-derivation when etc/ is a relative symlink" + ;; See <https://bugs.gnu.org/32686>. + (mlet* %store-monad + ((etc (gexp->derivation + "etc" + #~(begin + (mkdir #$output) + (call-with-output-file (string-append #$output "/foo") + (lambda (port) + (display "Heya!" port)))))) + (thing -> (dummy-package "dummy" + (build-system trivial-build-system) + (inputs + `(("etc" ,etc))) + (arguments + `(#:guile ,%bootstrap-guile + #:builder + (let ((out (assoc-ref %outputs "out")) + (etc (assoc-ref %build-inputs "etc"))) + (mkdir out) + (symlink etc (string-append out "/etc")) + #t))))) + (entry -> (package->manifest-entry thing)) + (drv (profile-derivation (manifest (list entry)) + #:relative-symlinks? #t + #:hooks '() + #:locales? #f)) + (profile -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (string=? (call-with-input-file + (string-append profile "/etc/foo") + get-string-all) + "Heya!"))))) + (test-equalm "union vs. dangling symlink" ;<https://bugs.gnu.org/26949> "does-not-exist" (mlet* %store-monad |