From 2ca41030d5189d83ea2a28ea64cf0e19efed5fd7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Jun 2019 14:34:36 +0200 Subject: gexp: Add 'lower-gexp' and express 'gexp->derivation' in terms of it. * guix/gexp.scm (gexp-input-thing, gexp-input-output) (gexp-input-native?): Export. (lower-inputs): Return records instead of tuples. (lower-reference-graphs): Adjust accordingly. (): New record type. (lower-gexp, gexp-input->tuple): New procedure. (gexp->derivation)[%modules]: Remove. [requested-graft?]: New variable. [add-modules]: New procedure. Rewrite in terms of 'lower-gexp'. (gexp-inputs): Add TODO comment. * tests/gexp.scm ("lower-gexp"): New test. --- tests/gexp.scm | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) (limited to 'tests') diff --git a/tests/gexp.scm b/tests/gexp.scm index cee2c96610..23904fce2e 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -832,6 +832,43 @@ (built-derivations (list drv)) (return (equal? '(42 84) (call-with-input-file out read)))))) +(test-assertm "lower-gexp" + (mlet* %store-monad + ((extension -> %extension-package) + (extension-drv (package->derivation %extension-package)) + (coreutils-drv (package->derivation coreutils)) + (exp -> (with-extensions (list extension) + (with-imported-modules `((guix build utils)) + #~(begin + (use-modules (guix build utils) + (hg2g)) + #$coreutils:debug + mkdir-p + the-answer)))) + (lexp (lower-gexp exp + #:effective-version "2.0"))) + (define (matching-input drv output) + (lambda (input) + (and (eq? (gexp-input-thing input) drv) + (string=? (gexp-input-output input) output)))) + + (mbegin %store-monad + (return (and (find (matching-input extension-drv "out") + (lowered-gexp-inputs (pk 'lexp lexp))) + (find (matching-input coreutils-drv "debug") + (lowered-gexp-inputs lexp)) + (member (string-append + (derivation->output-path extension-drv) + "/share/guile/site/2.0") + (lowered-gexp-load-path lexp)) + (= 2 (length (lowered-gexp-load-path lexp))) + (member (string-append + (derivation->output-path extension-drv) + "/lib/guile/2.0/site-ccache") + (lowered-gexp-load-compiled-path lexp)) + (= 2 (length (lowered-gexp-load-compiled-path lexp))) + (eq? (lowered-gexp-guile lexp) (%guile-for-build))))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) -- cgit v1.2.3 From b1510fd8d252c1ab0d32a32f064513105b99cf39 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Jul 2019 23:09:11 +0200 Subject: derivations: 'derivation-build-plan' recurses on substituables. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This fixes a bug whereby "guix build texlive -n" would report: 0.0 MB would be downloaded: /gnu/store/…-texlive-20180414 instead of: The following derivation would be built: /gnu/store/…-texlive-texmf-20180414.drv 2,595.2 MB would be downloaded: /gnu/store/…-texlive-20180414-texmf.tar.xz /gnu/store/…-texlive-20180414 where 'texlive-texmf' is a non-substitutable dependency of 'texlive'. * guix/derivations.scm (dependencies-of-substitutables): New procedure. (derivation-build-plan): When 'input-substitutable-info' returns true, append the subset of DEPS that corresponds to SUBSTITUABLES to the first argument of 'loop'. * guix/ui.scm (show-what-to-build): Remove half-baked traversal of DOWNLOAD. * tests/derivations.scm ("derivation-build-plan and substitutes, non-substitutable dep"): New test. --- guix/derivations.scm | 29 +++++++++++++++++++++-------- guix/ui.scm | 12 ------------ tests/derivations.scm | 29 +++++++++++++++++++++++++++++ 3 files changed, 50 insertions(+), 20 deletions(-) (limited to 'tests') diff --git a/guix/derivations.scm b/guix/derivations.scm index 186d7a3f8f..caa76bd16c 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -352,6 +352,16 @@ substituter many times." (#f #f) ((key . value) value))))) +(define (dependencies-of-substitutables substitutables inputs) + "Return the subset of INPUTS whose output file names is among the references +of SUBSTITUTABLES." + (let ((items (fold set-insert (set) + (append-map substitutable-references substitutables)))) + (filter (lambda (input) + (any (cut set-contains? items <>) + (derivation-input-output-paths input))) + inputs))) + (define* (derivation-build-plan store inputs #:key (mode (build-mode normal)) @@ -391,7 +401,9 @@ by 'substitution-oracle'." (() (values build substitute)) ((input rest ...) - (let ((key (derivation-input-key input))) + (let ((key (derivation-input-key input)) + (deps (derivation-inputs + (derivation-input-derivation input)))) (cond ((set-contains? visited key) (loop rest build substitute visited)) ((input-built? input) @@ -400,16 +412,17 @@ by 'substitution-oracle'." ((input-substitutable-info input) => (lambda (substitutables) - (loop rest build + (loop (append (dependencies-of-substitutables substitutables + deps) + rest) + build (append substitutables substitute) (set-insert key visited)))) (else - (let ((deps (derivation-inputs - (derivation-input-derivation input)))) - (loop (append deps rest) - (cons (derivation-input-derivation input) build) - substitute - (set-insert key visited)))))))))) + (loop (append deps rest) + (cons (derivation-input-derivation input) build) + substitute + (set-insert key visited))))))))) (define-deprecated (derivation-prerequisites-to-build store drv #:rest rest) derivation-build-plan diff --git a/guix/ui.scm b/guix/ui.scm index 6d243ef041..2ce82ff658 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -844,18 +844,6 @@ check and report what is prerequisites are available for download." #:mode mode #:substitutable-info substitutable-info)) - ((download) ; add the references of DOWNLOAD - (if use-substitutes? - (delete-duplicates - (append download - (filter-map (lambda (item) - (if (valid-path? store item) - #f - (substitutable-info item))) - (append-map - substitutable-references - download)))) - download)) ((graft hook build) (match (fold (lambda (drv acc) (let ((file (derivation-file-name drv))) diff --git a/tests/derivations.scm b/tests/derivations.scm index d173a78906..7be7726163 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -896,6 +896,35 @@ (((= derivation-file-name build)) (string=? build (derivation-file-name drv))))))))) +(test-assert "derivation-build-plan and substitutes, non-substitutable dep" + (with-store store + (let* ((drv1 (build-expression->derivation store "prereq-no-subst" + (random 1000) + #:substitutable? #f)) + (drv2 (build-expression->derivation store "substitutable" + (random 1000) + #:inputs `(("dep" ,drv1))))) + + ;; Make sure substitutes are usable. + (set-build-options store #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) + + (with-derivation-narinfo drv2 + (sha256 => (make-bytevector 32 0)) + (references => (list (derivation->output-path drv1))) + + (let-values (((build download) + (derivation-build-plan store + (list (derivation-input drv2))))) + ;; Although DRV2 is available as a substitute, we must build its + ;; dependency, DRV1, due to #:substitutable? #f. + (and (match download + (((= substitutable-path item)) + (string=? item (derivation->output-path drv2)))) + (match build + (((= derivation-file-name build)) + (string=? build (derivation-file-name drv1)))))))))) + (test-assert "derivation-build-plan and substitutes, local build" (with-store store (let* ((drv (build-expression->derivation store "prereq-subst-local" -- cgit v1.2.3 From b6dc08393e6a8313b88ce422fc3c1e4e9c0efc6f Mon Sep 17 00:00:00 2001 From: Carl Dong Date: Sat, 29 Jun 2019 17:15:11 -0400 Subject: scripts: environment: Add --no-cwd. * doc/guix.texi (Invoking guix environment): Add --no-cwd. * guix/scripts/environment.scm (show-help, %options): Add --no-cwd. (launch-environment/container): Add 'map-cwd?' param; only add mapping for cwd if #t. Only change to cwd within container if #t, otherwise home. (guix-environment): Error if --no-cwd without --container. Provide '(not no-cwd?)' to launch-environment/container as 'map-cwd?'. * tests/guix-environment.sh: Add test for no-cwd. Co-authored-by: Mike Gerwitz --- doc/guix.texi | 8 ++++++++ guix/scripts/environment.scm | 36 +++++++++++++++++++++++++++--------- tests/guix-environment.sh | 8 ++++++++ 3 files changed, 43 insertions(+), 9 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 0b50482530..3e0788ed3a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4657,6 +4657,14 @@ While this will limit the leaking of user identity through home paths and each of the user fields, this is only one useful component of a broader privacy/anonymity solution---not one in and of itself. +@item --no-cwd +For containers, the default behavior is to share the current working +directory with the isolated container and immediately change to that +directory within the container. If this is undesirable, @code{--no-cwd} +will cause the current working directory to @emph{not} be automatically +shared and will change to the user's home directory within the container +instead. See also @code{--user}. + @item --expose=@var{source}[=@var{target}] For containers, expose the file system @var{source} from the host system as the read-only file system @var{target} within the container. If diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 949ba1124f..cf58768300 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -161,6 +161,10 @@ COMMAND or an interactive shell in that environment.\n")) -u, --user=USER instead of copying the name and home of the current user into an isolated container, use the name USER with home directory /home/USER")) + (display (G_ " + --no-cwd do not share current working directory with an + isolated container")) + (display (G_ " --share=SPEC for containers, share writable host file system according to SPEC")) @@ -269,6 +273,9 @@ use '--preserve' instead~%")) (lambda (opt name arg result) (alist-cons 'user arg (alist-delete 'user result eq?)))) + (option '("no-cwd") #f #f + (lambda (opt name arg result) + (alist-cons 'no-cwd? #t result))) (option '("share") #t #f (lambda (opt name arg result) (alist-cons 'file-system-mapping @@ -444,7 +451,8 @@ regexps in WHITE-LIST." ((_ . status) status))))) (define* (launch-environment/container #:key command bash user user-mappings - profile manifest link-profile? network?) + profile manifest link-profile? network? + map-cwd?) "Run COMMAND within a container that features the software in PROFILE. Environment variables are set according to the search paths of MANIFEST. The global shell is BASH, a file name for a GNU Bash binary in the @@ -483,11 +491,13 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (override-user-mappings user home (append user-mappings - ;; Current working directory. - (list (file-system-mapping - (source cwd) - (target cwd) - (writable? #t))))) + ;; Share current working directory, unless asked not to. + (if map-cwd? + (list (file-system-mapping + (source cwd) + (target cwd) + (writable? #t))) + '()))) ;; When in Rome, do as Nix build.cc does: Automagically ;; map common network configuration files. (if network? @@ -537,8 +547,10 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (write-group groups) ;; For convenience, start in the user's current working - ;; directory rather than the root directory. - (chdir (override-user-dir user home cwd)) + ;; directory or, if unmapped, the home directory. + (chdir (if map-cwd? + (override-user-dir user home cwd) + home-dir)) (primitive-exit/status ;; A container's environment is already purified, so no need to @@ -665,6 +677,7 @@ message if any test fails." (container? (assoc-ref opts 'container?)) (link-prof? (assoc-ref opts 'link-profile?)) (network? (assoc-ref opts 'network?)) + (no-cwd? (assoc-ref opts 'no-cwd?)) (user (assoc-ref opts 'user)) (bootstrap? (assoc-ref opts 'bootstrap?)) (system (assoc-ref opts 'system)) @@ -685,6 +698,9 @@ message if any test fails." (leave (G_ "'--link-profile' cannot be used without '--container'~%"))) (when (and (not container?) user) (leave (G_ "'--user' cannot be used without '--container'~%"))) + (when (and (not container?) no-cwd?) + (leave (G_ "--no-cwd cannot be used without --container~%"))) + (with-store store (with-status-verbosity (assoc-ref opts 'verbosity) @@ -741,7 +757,9 @@ message if any test fails." #:profile profile #:manifest manifest #:link-profile? link-prof? - #:network? network?))) + #:network? network? + #:map-cwd? (not no-cwd?)))) + (else (return (exit/status diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index a670db36be..5a5a69d58c 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -84,6 +84,14 @@ echo "(use-modules (guix profiles) (gnu packages bootstrap)) guix environment --bootstrap --manifest=$tmpdir/manifest.scm --pure \ -- "$SHELL" -c 'test -f "$GUIX_ENVIRONMENT/bin/guile"' +# if not sharing CWD, chdir home +( + cd "$tmpdir" \ + && guix environment --bootstrap --container --no-cwd --user=foo \ + --ad-hoc guile-bootstrap --pure \ + -- /bin/sh -c 'test $(pwd) == "/home/foo" -a ! -d '"$tmpdir" +) + # Make sure '-r' works as expected. rm -f "$gcroot" expected="`guix environment --bootstrap --ad-hoc guile-bootstrap \ -- cgit v1.2.3