diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/grafts.scm | 62 | ||||
| -rw-r--r-- | tests/graph.scm | 22 | ||||
| -rw-r--r-- | tests/packages.scm | 106 |
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. |