Merge branch 'master' into core-updates

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.