summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-02-27 23:06:50 +0100
committerLudovic Courtès <ludo@gnu.org>2016-03-01 16:00:46 +0100
commitc22a1324e64d6906be5e9a8e64b8716ad763434a (patch)
treea85accaeaa4c727c703f208e01a9296821832de7 /tests
parentd06fc008bdb86169d951721bbb4604948368d7c2 (diff)
grafts: Graft recursively.
Fixes <http://bugs.gnu.org/22139>. * 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.
Diffstat (limited to 'tests')
-rw-r--r--tests/grafts.scm93
-rw-r--r--tests/packages.scm38
2 files changed, 99 insertions, 32 deletions
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 <http://www.gnu.org/licenses/>.
(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
diff --git a/tests/packages.scm b/tests/packages.scm
index 6315c2204f..46391783b0 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -605,23 +605,27 @@
(origin (package-derivation %store dep))
(replacement (package-derivation %store new)))))))
-(test-assert "package-derivation, indirect grafts"
- (let* ((new (dummy-package "dep"
- (arguments '(#:implicit-inputs? #f))))
- (dep (package (inherit new) (version "0.0")))
- (dep* (package (inherit dep) (replacement new)))
- (dummy (dummy-package "dummy"
- (arguments '(#:implicit-inputs? #f))
- (inputs `(("dep" ,dep*)))))
- (guile (package-derivation %store (canonical-package guile-2.0)
- #:graft? #f)))
- (equal? (package-derivation %store dummy)
- (graft-derivation %store
- (package-derivation %store dummy #:graft? #f)
- (package-grafts %store dummy)
-
- ;; Use the same Guile as 'package-derivation'.
- #:guile guile))))
+;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
+;;; find out about their run-time dependencies, so this test is no longer
+;;; applicable since it would trigger a full rebuild.
+;;
+;; (test-assert "package-derivation, indirect grafts"
+;; (let* ((new (dummy-package "dep"
+;; (arguments '(#:implicit-inputs? #f))))
+;; (dep (package (inherit new) (version "0.0")))
+;; (dep* (package (inherit dep) (replacement new)))
+;; (dummy (dummy-package "dummy"
+;; (arguments '(#:implicit-inputs? #f))
+;; (inputs `(("dep" ,dep*)))))
+;; (guile (package-derivation %store (canonical-package guile-2.0)
+;; #:graft? #f)))
+;; (equal? (package-derivation %store dummy)
+;; (graft-derivation %store
+;; (package-derivation %store dummy #:graft? #f)
+;; (package-grafts %store dummy)
+
+;; ;; Use the same Guile as 'package-derivation'.
+;; #:guile guile))))
(test-equal "package->bag"
`("foo86-hurd" #f (,(package-source gnu-make))