01/07: grafts: Fix corner case involving multiple-output derivations.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 67effc1560fc175dfbcb58ef5b965b08b3942d6c
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Oct 27 23:44:39 2023 +0200

    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
---
 guix/grafts.scm  | 43 +++++++++++++++++++------------------------
 tests/grafts.scm | 50 +++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 68 insertions(+), 25 deletions(-)

diff --git a/guix/grafts.scm b/guix/grafts.scm
index f93da32981..48f4c212f7 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -176,11 +176,8 @@ references."
                     (append-map (cut references/cached store <>) items))))
       (append-map (cut references/cached store <>) items)))
 
-  (let ((refs (references* (map (cut derivation->output-path drv <>)
-                                outputs)))
-        (self (match (derivation->output-paths drv)
-                (((names . items) ...)
-                 items))))
+  (let* ((self (map (cut derivation->output-path drv <>) outputs))
+         (refs (references* self)))
     (remove (cut member <> self) refs)))
 
 (define %graft-cache
@@ -207,7 +204,7 @@ references."
            (return result)))))))
 
 (define (reference-origins drv items)
-  "Return the derivation/output pairs among the inputs of DRV, recursively,
+  "Return the derivation/output pairs among DRV and its inputs, recursively,
 that produce ITEMS.  Elements of ITEMS not produced by a derivation (i.e.,
 it's a content-addressed \"source\"), or not produced by a dependency of DRV,
 have no corresponding element in the resulting list."
@@ -238,13 +235,10 @@ have no corresponding element in the resulting list."
              ((set-contains? visited drv)
               (loop rest items result visited))
              (else
-              (let* ((inputs
-                      (map derivation-input-derivation
-                           (derivation-inputs drv)))
-                     (result items
-                             (fold2 lookup-derivers
-                                    result items inputs)))
-                (loop (append rest inputs)
+              (let ((result items (lookup-derivers drv result items)))
+                (loop (append rest
+                              (map derivation-input-derivation
+                                   (derivation-inputs drv)))
                       items result
                       (set-insert drv visited)))))))))
 
@@ -258,16 +252,17 @@ GRAFTS to the dependencies of DRV.  Return the 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.
+  (define (graft-origin? drv output graft)
+    ;; Return true if DRV and OUTPUT correspond 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)))
+      (($ <graft> (? derivation? origin) origin-output)
+       (and (string=? origin-output output)
+            (match (assoc-ref (derivation->output-paths drv) output)
+              ((? string? result)
+               (string=? result
+                         (derivation->output-path origin output)))
+              (_
+               #f))))
       (_
        #f)))
 
@@ -278,7 +273,7 @@ derivations to the corresponding set of grafts."
               ((drv . output)
                ;; If GRAFTS already contains a graft from DRV, do not
                ;; override it.
-               (if (find (cut graft-origin? drv <>) grafts)
+               (if (find (cut graft-origin? drv output <>) grafts)
                    (state-return grafts)
                    (cumulative-grafts store drv grafts
                                       #:outputs (list output)
diff --git a/tests/grafts.scm b/tests/grafts.scm
index 63dbb13830..24c4d24359 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.