summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2016-10-17 16:47:12 -0400
committerMark H Weaver <mhw@netris.org>2016-10-17 16:47:12 -0400
commitdcaf70897a0bad38a4638a2905aaa3c46b1f1402 (patch)
tree439c42bf27972a628ebc0fef11a63b9130ca19a5 /tests
parentbf62b8ff79f9d60136996b8251b6475965cf4994 (diff)
parent040b6299d505c034b4960c335434a500ae2f8187 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'tests')
-rw-r--r--tests/grafts.scm62
-rw-r--r--tests/graph.scm22
-rw-r--r--tests/packages.scm106
3 files changed, 174 insertions, 16 deletions
diff --git a/tests/grafts.scm b/tests/grafts.scm
index f2ff839fd8..4eff06b4b3 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -218,4 +218,66 @@
(let ((out (derivation->output-path grafted)))
(file-is-directory? (string-append out "/" repl))))))
+(test-assert "graft-derivation, grafts are not shadowed"
+ ;; We build a DAG as below, where dotted arrows represent replacements and
+ ;; solid arrows represent dependencies:
+ ;;
+ ;; P1 ·············> P1R
+ ;; |\__________________.
+ ;; v v
+ ;; P2 ·············> P2R
+ ;; |
+ ;; v
+ ;; P3
+ ;;
+ ;; We want to make sure that the two grafts we want to apply to P3 are
+ ;; honored and not shadowed by other computed grafts.
+ (let* ((p1 (build-expression->derivation
+ %store "p1"
+ '(mkdir (assoc-ref %outputs "out"))))
+ (p1r (build-expression->derivation
+ %store "P1"
+ '(let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (call-with-output-file (string-append out "/replacement")
+ (const #t)))))
+ (p2 (build-expression->derivation
+ %store "p2"
+ `(let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p1") "p1"))
+ #:inputs `(("p1" ,p1))))
+ (p2r (build-expression->derivation
+ %store "P2"
+ `(let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p1") "p1")
+ (call-with-output-file (string-append out "/replacement")
+ (const #t)))
+ #:inputs `(("p1" ,p1))))
+ (p3 (build-expression->derivation
+ %store "p3"
+ `(let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p2") "p2"))
+ #:inputs `(("p2" ,p2))))
+ (p1g (graft
+ (origin p1)
+ (replacement p1r)))
+ (p2g (graft
+ (origin p2)
+ (replacement (graft-derivation %store p2r (list p1g)))))
+ (p3d (graft-derivation %store p3 (list p1g p2g))))
+ (and (build-derivations %store (list p3d))
+ (let ((out (derivation->output-path (pk p3d))))
+ ;; Make sure OUT refers to the replacement of P2, which in turn
+ ;; refers to the replacement of P1, as specified by P1G and P2G.
+ ;; It used to be the case that P2G would be shadowed by a simple
+ ;; P2->P2R graft, which is not what we want.
+ (and (file-exists? (string-append out "/p2/replacement"))
+ (file-exists? (string-append out "/p2/p1/replacement")))))))
+
(test-end)
diff --git a/tests/graph.scm b/tests/graph.scm
index 1ce06cc817..f2e441cee6 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -232,6 +232,28 @@ edges."
(list out txt))
(equal? edges `((,out ,txt)))))))))))
+(test-assert "referrer DAG"
+ (let-values (((backend nodes+edges) (make-recording-backend)))
+ (run-with-store %store
+ (mlet* %store-monad ((txt (text-file "referrer-node" (random-text)))
+ (drv (gexp->derivation "referrer"
+ #~(symlink #$txt #$output)))
+ (out -> (derivation->output-path drv)))
+ ;; We should see only TXT and OUT, with an edge from the former to the
+ ;; latter.
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (export-graph (list txt) 'port
+ #:node-type %referrer-node-type
+ #:backend backend)
+ (let-values (((nodes edges) (nodes+edges)))
+ (return
+ (and (equal? (match nodes
+ (((ids labels) ...)
+ ids))
+ (list txt out))
+ (equal? edges `((,txt ,out)))))))))))
+
(test-assert "node-edges"
(run-with-store %store
(let ((packages (fold-packages cons '())))
diff --git a/tests/packages.scm b/tests/packages.scm
index b8e1f111cd..5f5fb5de87 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -662,22 +662,25 @@
(origin (package-derivation %store dep))
(replacement (package-derivation %store new)))))))
-(test-assert "package-grafts, indirect grafts, cross"
- (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*)))))
- (target "mips64el-linux-gnu"))
- ;; XXX: There might be additional grafts, for instance if the distro
- ;; defines replacements for core packages like Perl.
- (member (graft
- (origin (package-cross-derivation %store dep target))
- (replacement
- (package-cross-derivation %store new target)))
- (package-grafts %store dummy #:target target))))
+;; XXX: This test would require building the cross toolchain just to see if it
+;; needs grafting, which is obviously too expensive, and thus disabled.
+;;
+;; (test-assert "package-grafts, indirect grafts, cross"
+;; (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*)))))
+;; (target "mips64el-linux-gnu"))
+;; ;; XXX: There might be additional grafts, for instance if the distro
+;; ;; defines replacements for core packages like Perl.
+;; (member (graft
+;; (origin (package-cross-derivation %store dep target))
+;; (replacement
+;; (package-cross-derivation %store new target)))
+;; (package-grafts %store dummy #:target target))))
(test-assert "package-grafts, indirect grafts, propagated inputs"
(let* ((new (dummy-package "dep"
@@ -719,6 +722,77 @@
(replacement #f))))
(replacement (package-derivation %store new)))))))
+(test-assert "replacement also grafted"
+ ;; We build a DAG as below, where dotted arrows represent replacements and
+ ;; solid arrows represent dependencies:
+ ;;
+ ;; P1 ·············> P1R
+ ;; |\__________________.
+ ;; v v
+ ;; P2 ·············> P2R
+ ;; |
+ ;; v
+ ;; P3
+ ;;
+ ;; We want to make sure that:
+ ;; grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
+ ;; where:
+ ;; (A,B) is a graft to replace A by B
+ ;; grafted(DRV,G) denoted DRV with graft G applied
+ (let* ((p1r (dummy-package "P1"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (call-with-output-file
+ (string-append out "/replacement")
+ (const #t)))))))
+ (p1 (package
+ (inherit p1r) (name "p1") (replacement p1r)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (mkdir (assoc-ref %outputs "out"))))))
+ (p2r (dummy-package "P2"
+ (build-system trivial-build-system)
+ (inputs `(("p1" ,p1)))
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p1") "p1")
+ (call-with-output-file (string-append out "/replacement")
+ (const #t)))))))
+ (p2 (package
+ (inherit p2r) (name "p2") (replacement p2r)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p1")
+ "p1"))))))
+ (p3 (dummy-package "p3"
+ (build-system trivial-build-system)
+ (inputs `(("p2" ,p2)))
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out)
+ (symlink (assoc-ref %build-inputs "p2")
+ "p2")))))))
+ (lset= equal?
+ (package-grafts %store p3)
+ (list (graft
+ (origin (package-derivation %store p1 #:graft? #f))
+ (replacement (package-derivation %store p1r)))
+ (graft
+ (origin (package-derivation %store p2 #:graft? #f))
+ (replacement
+ (package-derivation %store p2r #:graft? #t)))))))
+
;;; 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.