From c22a1324e64d6906be5e9a8e64b8716ad763434a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 27 Feb 2016 23:06:50 +0100 Subject: grafts: Graft recursively. Fixes . * guix/grafts.scm (graft-derivation): Rename to... (graft-derivation/shallow): ... this. (graft-origin-file-name, item->deriver, non-self-references) (cumulative-grafts, graft-derivation): New procedures * tests/grafts.scm ("graft-derivation, grafted item is a direct dependency"): Clarify title. Use 'grafted' instead of 'graft' to refer to the grafted derivation. ("graft-derivation, grafted item is an indirect dependency") ("graft-derivation, no dependencies on grafted output"): New tests. * guix/packages.scm (input-graft): Change to take a package instead of an input. (input-cross-graft): Likewise. (fold-bag-dependencies): New procedure. (bag-grafts): Rewrite in terms of 'fold-bag-dependencies'. * tests/packages.scm ("package-derivation, indirect grafts"): Comment out. * doc/guix.texi (Security Updates): Mention run-time dependencies and recursive grafting. --- tests/grafts.scm | 93 +++++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 78 insertions(+), 15 deletions(-) (limited to 'tests/grafts.scm') diff --git a/tests/grafts.scm b/tests/grafts.scm index 9fe314d183..4bc33709d6 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -17,12 +17,16 @@ ;;; along with GNU Guix. If not, see . (define-module (test-grafts) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix grafts) #:use-module (guix tests) #:use-module ((gnu packages) #:select (search-bootstrap-binary)) + #:use-module (gnu packages bootstrap) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (rnrs io ports)) @@ -42,7 +46,7 @@ (test-begin "grafts") -(test-assert "graft-derivation" +(test-assert "graft-derivation, grafted item is a direct dependency" (let* ((build `(begin (mkdir %output) (chdir %output) @@ -51,7 +55,7 @@ (lambda (output) (format output "foo/~a/bar" ,%mkdir))) (symlink ,%bash "sh"))) - (orig (build-expression->derivation %store "graft" build + (orig (build-expression->derivation %store "grafted" build #:inputs `(("a" ,%bash) ("b" ,%mkdir)))) (one (add-text-to-store %store "bash" "fake bash")) @@ -59,21 +63,80 @@ '(call-with-output-file %output (lambda (port) (display "fake mkdir" port))))) - (graft (graft-derivation %store orig - (list (graft - (origin %bash) - (replacement one)) - (graft - (origin %mkdir) - (replacement two)))))) - (and (build-derivations %store (list graft)) - (let ((two (derivation->output-path two)) - (graft (derivation->output-path graft))) + (grafted (graft-derivation %store orig + (list (graft + (origin %bash) + (replacement one)) + (graft + (origin %mkdir) + (replacement two)))))) + (and (build-derivations %store (list grafted)) + (let ((two (derivation->output-path two)) + (grafted (derivation->output-path grafted))) (and (string=? (format #f "foo/~a/bar" two) - (call-with-input-file (string-append graft "/text") + (call-with-input-file (string-append grafted "/text") get-string-all)) - (string=? (readlink (string-append graft "/sh")) one) - (string=? (readlink (string-append graft "/self")) graft)))))) + (string=? (readlink (string-append grafted "/sh")) one) + (string=? (readlink (string-append grafted "/self")) + grafted)))))) + +;; Make sure 'derivation-file-name' always gets to see an absolute file name. +(fluid-set! %file-port-name-canonicalization 'absolute) + +(test-assert "graft-derivation, grafted item is an indirect dependency" + (let* ((build `(begin + (mkdir %output) + (chdir %output) + (symlink %output "self") + (call-with-output-file "text" + (lambda (output) + (format output "foo/~a/bar" ,%mkdir))) + (symlink ,%bash "sh"))) + (dep (build-expression->derivation %store "dep" build + #:inputs `(("a" ,%bash) + ("b" ,%mkdir)))) + (orig (build-expression->derivation %store "thing" + '(symlink + (assoc-ref %build-inputs + "dep") + %output) + #:inputs `(("dep" ,dep)))) + (one (add-text-to-store %store "bash" "fake bash")) + (two (build-expression->derivation %store "mkdir" + '(call-with-output-file %output + (lambda (port) + (display "fake mkdir" port))))) + (grafted (graft-derivation %store orig + (list (graft + (origin %bash) + (replacement one)) + (graft + (origin %mkdir) + (replacement two)))))) + (and (build-derivations %store (list grafted)) + (let* ((two (derivation->output-path two)) + (grafted (derivation->output-path grafted)) + (dep (readlink grafted))) + (and (string=? (format #f "foo/~a/bar" two) + (call-with-input-file (string-append dep "/text") + get-string-all)) + (string=? (readlink (string-append dep "/sh")) one) + (string=? (readlink (string-append dep "/self")) dep) + (equal? (references %store grafted) (list dep)) + (lset= string=? + (list one two dep) + (references %store dep))))))) + +(test-assert "graft-derivation, no dependencies on grafted output" + (run-with-store %store + (mlet* %store-monad ((fake (text-file "bash" "Fake bash.")) + (graft -> (graft + (origin %bash) + (replacement fake))) + (drv (gexp->derivation "foo" #~(mkdir #$output))) + (grafted ((store-lift graft-derivation) drv + (list graft)))) + (return (eq? grafted drv))))) (test-assert "graft-derivation, multiple outputs" (let* ((build `(begin -- cgit v1.2.3