05/11: packages: Better preserve object identity when rewriting.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 8db4ebb0cd9bfdcf1aea63eb8d20eb6af0c87c93
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Oct 20 09:18:07 2020 +0200

    packages: Better preserve object identity when rewriting.
    
    Fixes a bug whereby the presence of propagated inputs could lead to two
    non-eq? but actually equal packages in a bag's inputs.  The problem
    would manifest itself when running, for instance:
    
      guix build inkscape -d --with-graft=glib=glib-networking --no-grafts
    
    The resulting derivation would differ due from that without
    '--with-graft'.  This was due to the fact that glib propagates libffi;
    this instance of libffi was not rewritten even though other instances in
    the graph were rewritten.  Thus, glib would end up with two non-eq?
    libffi instances, which in turn would lead to duplicate entries in its
    '%build-inputs' variable.
    
    Fixes <https://bugs.gnu.org/43890>.
    
    * guix/packages.scm (package-mapping)[rewrite]: Remove call to 'cut?'
    and call 'replace' unconditionally.
    [replace]: Add 'cut?' case.
    * tests/guix-build.sh: Add test combining '--no-grafts' and
    '--with-graft'.
    * tests/packages.scm ("package-input-rewriting/spec, identity")
    ("package-input-rewriting, identity"): New tests.
---
 guix/packages.scm   | 63 +++++++++++++++++++++++++++++++++--------------------
 tests/guix-build.sh |  6 +++++
 tests/packages.scm  | 43 ++++++++++++++++++++++++++++++++++++
 3 files changed, 88 insertions(+), 24 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 24d6417..6fa761f 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1015,8 +1015,7 @@ applied to implicit inputs as well."
   (define (rewrite input)
     (match input
       ((label (? package? package) outputs ...)
-       (let ((proc (if (cut? package) proc replace)))
-         (cons* label (proc package) outputs)))
+       (cons* label (replace package) outputs))
       (_
        input)))
 
@@ -1027,28 +1026,44 @@ applied to implicit inputs as well."
   (define replace
     (mlambdaq (p)
       ;; If P is the result of a previous call, return it.
-      (if (assq-ref (package-properties p) mapping-property)
-          p
-
-          ;; Return a variant of P with PROC applied to P and its explicit
-          ;; dependencies, recursively.  Memoize the transformations.  Failing
-          ;; to do that, we would build a huge object graph with lots of
-          ;; duplicates, which in turns prevents us from benefiting from
-          ;; memoization in 'package-derivation'.
-          (let ((p (proc p)))
-            (package
-              (inherit p)
-              (location (package-location p))
-              (build-system (if deep?
-                                (build-system-with-package-mapping
-                                 (package-build-system p) rewrite)
-                                (package-build-system p)))
-              (inputs (map rewrite (package-inputs p)))
-              (native-inputs (map rewrite (package-native-inputs p)))
-              (propagated-inputs (map rewrite (package-propagated-inputs p)))
-              (replacement (and=> (package-replacement p) replace))
-              (properties `((,mapping-property . #t)
-                            ,@(package-properties p))))))))
+      (cond ((assq-ref (package-properties p) mapping-property)
+             p)
+
+            ((cut? p)
+             ;; Since P's propagated inputs are really inputs of its 
dependents,
+             ;; rewrite them as well, unless we're doing a "shallow" rewrite.
+             (let ((p (proc p)))
+               (if (or (not deep?)
+                       (null? (package-propagated-inputs p)))
+                   p
+                   (package
+                     (inherit p)
+                     (location (package-location p))
+                     (replacement (package-replacement p))
+                     (propagated-inputs (map rewrite 
(package-propagated-inputs p)))
+                     (properties `((,mapping-property . #t)
+                                   ,@(package-properties p)))))))
+
+            (else
+             ;; Return a variant of P with PROC applied to P and its explicit
+             ;; dependencies, recursively.  Memoize the transformations.  
Failing
+             ;; to do that, we would build a huge object graph with lots of
+             ;; duplicates, which in turns prevents us from benefiting from
+             ;; memoization in 'package-derivation'.
+             (let ((p (proc p)))
+               (package
+                 (inherit p)
+                 (location (package-location p))
+                 (build-system (if deep?
+                                   (build-system-with-package-mapping
+                                    (package-build-system p) rewrite)
+                                   (package-build-system p)))
+                 (inputs (map rewrite (package-inputs p)))
+                 (native-inputs (map rewrite (package-native-inputs p)))
+                 (propagated-inputs (map rewrite (package-propagated-inputs 
p)))
+                 (replacement (and=> (package-replacement p) replace))
+                 (properties `((,mapping-property . #t)
+                               ,@(package-properties p)))))))))
 
   replace)
 
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index 4a58ea1..b7602e6 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -289,6 +289,12 @@ drv1=`guix build glib -d`
 drv2=`guix build glib -d --with-input=libreoffice=inkscape`
 test "$drv1" = "$drv2"
 
+# '--with-graft' should have no effect when using '--no-grafts'.
+# See <https://bugs.gnu.org/43890>.
+drv1=`guix build inkscape -d --no-grafts`
+drv2=`guix build inkscape -d --no-grafts --with-graft=glib=glib-networking`
+test "$drv1" = "$drv2"
+
 # Rewriting implicit inputs.
 drv1=`guix build hello -d`
 drv2=`guix build hello -d --with-input=gcc=gcc-toolchain`
diff --git a/tests/packages.scm b/tests/packages.scm
index 2d13d91..18e8e16 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1450,6 +1450,49 @@
             (eq? foo grep)
             (eq? bar dep))))))
 
+(test-assert "package-input-rewriting/spec, identity"
+  ;; Make sure that 'package-input-rewriting/spec' doesn't gratuitously
+  ;; introduce variants.  In this case, the LIBFFI propagated input should not
+  ;; be duplicated when passing GOBJECT through REWRITE.
+  ;; See <https://issues.guix.gnu.org/43890>.
+  (let* ((libffi  (dummy-package "libffi"
+                    (build-system trivial-build-system)))
+         (glib    (dummy-package "glib"
+                    (build-system trivial-build-system)
+                    (propagated-inputs `(("libffi" ,libffi)))))
+         (gobject (dummy-package "gobject-introspection"
+                    (build-system trivial-build-system)
+                    (inputs `(("glib" ,glib)))
+                    (propagated-inputs `(("libffi" ,libffi)))))
+         (rewrite (package-input-rewriting/spec
+                   `(("glib" . ,identity)))))
+    (and (= (length (package-transitive-inputs gobject))
+            (length (package-transitive-inputs (rewrite gobject))))
+         (string=? (derivation-file-name
+                    (package-derivation %store (rewrite gobject)))
+                   (derivation-file-name
+                    (package-derivation %store gobject))))))
+
+(test-assert "package-input-rewriting, identity"
+  ;; Similar to the test above, but with 'package-input-rewriting'.
+  ;; See <https://issues.guix.gnu.org/43890>.
+  (let* ((libffi  (dummy-package "libffi"
+                    (build-system trivial-build-system)))
+         (glib    (dummy-package "glib"
+                    (build-system trivial-build-system)
+                    (propagated-inputs `(("libffi" ,libffi)))))
+         (gobject (dummy-package "gobject-introspection"
+                    (build-system trivial-build-system)
+                    (inputs `(("glib" ,glib)))
+                    (propagated-inputs `(("libffi" ,libffi)))))
+         (rewrite (package-input-rewriting `((,glib . ,glib)))))
+    (and (= (length (package-transitive-inputs gobject))
+            (length (package-transitive-inputs (rewrite gobject))))
+         (string=? (derivation-file-name
+                    (package-derivation %store (rewrite gobject)))
+                   (derivation-file-name
+                    (package-derivation %store gobject))))))
+
 (test-equal "package-patched-vulnerabilities"
   '(("CVE-2015-1234")
     ("CVE-2016-1234" "CVE-2018-4567")