grafts: 'graft-derivation' does now introduce grafts that shadow other grafts.

Partly fixes <http://bugs.gnu.org/24418>.

* guix/grafts.scm (cumulative-grafts)[graft-origin?]: New procedure.
[dependency-grafts]: Use it in new 'if' around recursive call.
* tests/grafts.scm ("graft-derivation, grafts are not shadowed"): New test.

2 files changed, 82 insertions, 4 deletions

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 53e697688a..3e7a81a4c7 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -227,13 +227,29 @@ resulting list of grafts.
 
 This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping
 derivations to the corresponding set of grafts."
+  (define (graft-origin? drv graft)
+    ;; Return true if DRV corresponds to the origin of GRAFT.
+    (match graft
+      (($ <graft> (? derivation? origin) output)
+       (match (assoc-ref (derivation->output-paths drv) output)
+         ((? string? result)
+          (string=? result
+                    (derivation->output-path origin output)))
+         (_
+          #f)))
+      (_
+       #f)))
+
   (define (dependency-grafts item)
     (let-values (((drv output) (item->deriver store item)))
       (if drv
-          (cumulative-grafts store drv grafts references
-                             #:outputs (list output)
-                             #:guile guile
-                             #:system system)
+          ;; If GRAFTS already contains a graft from DRV, do not override it.
+          (if (find (cut graft-origin? drv <>) grafts)
+              (state-return grafts)
+              (cumulative-grafts store drv grafts references
+                                 #:outputs (list output)
+                                 #:guile guile
+                                 #:system system))
           (state-return grafts))))
 
   (define (return/cache cache value)
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)