grafts: Fix corner case involving multiple-output derivations.

Fixes a bug that would occur with references to two outputs of the same
derivation, with one of them referring to the other one.

For example, the references of libreoffice include both mariadb:dev and
mariadb:lib; additionally, mariadb:dev refers to mariadb:lib.  In this
case, the glibc graft would not be applied on one of the mariadb paths,
and both the grafted and ungrafted glibc would end up in the closure of
libreoffice.

Fixes <https://issues.guix.gnu.org/66662>.

* guix/grafts.scm (non-self-references): Simplify and include references
to outputs of DRV other than OUTPUTS.
(reference-origins): Simplify and possibly return outputs of DRV itself.
(cumulative-grafts)[graft-origin?]: Add OUTPUT parameter and honor it.
[dependency-grafts]: Adjust accordingly.
* tests/grafts.scm ("graft-derivation, multiple outputs need to be replaced"):
New test.

Change-Id: Iac2005024ab7049037537b3af55298696ec90e3c

1 files changed, 49 insertions, 1 deletions

diff --git a/tests/grafts.scm b/tests/grafts.scm
index 63dbb138302..24c4d243598 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2019, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2019, 2022-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2021 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -268,6 +268,54 @@
                           (readlink (string-append out "/two")))
                 (file-exists? (string-append out "/one/replacement")))))))
 
+(test-assert "graft-derivation, multiple outputs need to be replaced"
+  ;; Build a reference graph like this:
+  ;;
+  ;;         ,- p2:out --.
+  ;;         v           v
+  ;;      p1:one <---- p1:two
+  ;;         |
+  ;;         `-> p0
+  ;;
+  ;; Graft p0r in lieu of p0, and make sure all the paths from the grafted p2
+  ;; lead to p0r.  See <https://issues.guix.gnu.org/66662>.
+  (let* ((p0  (build-expression->derivation
+               %store "p0" '(mkdir (assoc-ref %outputs "out"))))
+         (p0r (build-expression->derivation
+               %store "P0"
+               '(let ((out (assoc-ref %outputs "out")))
+                  (mkdir out)
+                  (call-with-output-file (string-append out "/replacement")
+                    (const #t)))))
+         (p1  (build-expression->derivation
+               %store "p1"
+               `(let ((one (assoc-ref %outputs "one"))
+                      (two (assoc-ref %outputs "two"))
+                      (p0  (assoc-ref %build-inputs "p0")))
+                  (mkdir one)
+                  (mkdir two)
+                  (symlink p0 (string-append one "/p0"))
+                  (symlink one (string-append two "/link")))
+               #:inputs `(("p0" ,p0))
+               #:outputs '("one" "two")))
+         (p2  (build-expression->derivation
+               %store "p2"
+               `(let ((out (assoc-ref %outputs "out")))
+                  (mkdir out) (chdir out)
+                  (symlink (assoc-ref %build-inputs "p1:one") "one")
+                  (symlink (assoc-ref %build-inputs "p1:two") "two"))
+               #:inputs `(("p1:one" ,p1 "one")
+                          ("p1:two" ,p1 "two"))))
+         (p0g (list (graft
+                      (origin p0)
+                      (replacement p0r))))
+         (p2d (graft-derivation %store p2 p0g)))
+
+    (build-derivations %store (list p2d))
+    (let ((out (derivation->output-path (pk 'p2d p2d))))
+      (equal? (stat (string-append out "/one/p0/replacement"))
+              (stat (string-append out "/two/link/p0/replacement"))))))
+
 (test-assert "graft-derivation with #:outputs"
   ;; Call 'graft-derivation' with a narrowed set of outputs passed as
   ;; #:outputs.