branch core-updates-frozen updated: gexp: Leave grafting as is when lowering allowed/disallowed references.

[guix-commits]

This is an automated email from the git hooks/post-receive script.

civodul pushed a commit to branch core-updates-frozen
in repository guix.

The following commit(s) were added to refs/heads/core-updates-frozen by this 
push:
     new df46bef  gexp: Leave grafting as is when lowering allowed/disallowed 
references.
df46bef is described below

commit df46bef48eaa43c502fa9193371692c039b460c1
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Sep 24 23:00:11 2021 +0200

    gexp: Leave grafting as is when lowering allowed/disallowed references.
    
    Fixes <https://issues.guix.gnu.org/50676>.
    Reported by Mathieu Othacehe <othacehe@gnu.org>.
    
    Commit a779363b6aa581e88eda21f9f35530962d54ac25 was partially incorrect:
    references passed to #:allowed-references or #:references-graphs *can*
    be lowered as references to grafted elements.  This is for example the
    case when doing:
    
      (computed-file "partition.img" exp
                      #:options `(#:references-graphs ,inputs))
    
    Here INPUTS must be lowered as a reference to suitably grafted elements.
    Failing to do that, the reference graph will not match the actual
    INPUTS.
    
    However, when building a package, those references must indeed refer
    only to ungrafted packages.  This commit preserves that by having build
    systems pass #:graft? #f.
    
    * guix/gexp.scm (lower-reference-graphs, lower-references): Remove uses
    of 'without-grafting'.  This reverts
    a779363b6aa581e88eda21f9f35530962d54ac25.
    * guix/build-system/cmake.scm (cmake-build, cmake-cross-build):
    Pass #:graft? #f.
    * guix/build-system/glib-or-gtk.scm (glib-or-gtk-build)
    (glib-or-gtk-cross-build): Likewise.
    * guix/build-system/gnu.scm (gnu-build, gnu-cross-build): Likewise.
    * guix/build-system/meson.scm (meson-build, meson-cross-build): Likewise.
    * guix/build-system/trivial.scm (trivial-build, trivial-cross-build):
    Likewise.
    * tests/gexp.scm ("lower-object, computed-file + grafts"): New test.
    * tests/packages.scm ("trivial with #:allowed-references + grafts"): New
    test.
---
 guix/build-system/cmake.scm       |  2 ++
 guix/build-system/glib-or-gtk.scm |  2 ++
 guix/build-system/gnu.scm         |  4 ++++
 guix/build-system/meson.scm       |  2 ++
 guix/build-system/trivial.scm     |  2 ++
 guix/gexp.scm                     | 17 +++++++----------
 tests/gexp.scm                    | 36 ++++++++++++++++++++++++++++++++++++
 tests/packages.scm                | 22 ++++++++++++++++++++++
 8 files changed, 77 insertions(+), 10 deletions(-)

diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index d500ecc..2056c04 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -158,6 +158,7 @@ provides a 'CMakeLists.txt' file as its build system."
     (gexp->derivation name build
                       #:system system
                       #:target #f
+                      #:graft? #f
                       #:substitutable? substitutable?
                       #:guile-for-build guile)))
 
@@ -248,6 +249,7 @@ build system."
     (gexp->derivation name builder
                       #:system system
                       #:target target
+                      #:graft? #f
                       #:substitutable? substitutable?
                       #:guile-for-build guile)))
 
diff --git a/guix/build-system/glib-or-gtk.scm 
b/guix/build-system/glib-or-gtk.scm
index ec491ff..0c88f03 100644
--- a/guix/build-system/glib-or-gtk.scm
+++ b/guix/build-system/glib-or-gtk.scm
@@ -186,6 +186,7 @@
     (gexp->derivation name build
                       #:system system
                       #:target #f
+                      #:graft? #f
                       #:allowed-references allowed-references
                       #:disallowed-references disallowed-references
                       #:guile-for-build guile)))
@@ -279,6 +280,7 @@
     (gexp->derivation name builder
                       #:system system
                       #:target target
+                      #:graft? #f
                       #:modules imported-modules
                       #:allowed-references allowed-references
                       #:disallowed-references disallowed-references
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index ea91be5..6514150 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -423,9 +423,12 @@ are allowed to refer to."
 
   (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
                                                   system #:graft? #f)))
+    ;; Note: Always pass #:graft? #f.  Without it, ALLOWED-REFERENCES &
+    ;; co. would be interpreted as referring to grafted packages.
     (gexp->derivation name builder
                       #:system system
                       #:target #f
+                      #:graft? #f
                       #:substitutable? substitutable?
                       #:allowed-references allowed-references
                       #:disallowed-references disallowed-references
@@ -560,6 +563,7 @@ platform."
     (gexp->derivation name builder
                       #:system system
                       #:target target
+                      #:graft? #f
                       #:modules imported-modules
                       #:substitutable? substitutable?
                       #:allowed-references allowed-references
diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm
index dcad3f3..198aa08 100644
--- a/guix/build-system/meson.scm
+++ b/guix/build-system/meson.scm
@@ -233,6 +233,7 @@ has a 'meson.build' file."
     (gexp->derivation name builder
                       #:system system
                       #:target #f
+                      #:graft? #f
                       #:substitutable? substitutable?
                       #:allowed-references allowed-references
                       #:disallowed-references disallowed-references
@@ -332,6 +333,7 @@ SOURCE has a 'meson.build' file."
     (gexp->derivation name builder
                       #:system system
                       #:target target
+                      #:graft? #f
                       #:substitutable? substitutable?
                       #:allowed-references allowed-references
                       #:disallowed-references disallowed-references
diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm
index cd35c84..378ae48 100644
--- a/guix/build-system/trivial.scm
+++ b/guix/build-system/trivial.scm
@@ -61,6 +61,7 @@ ignored."
     (gexp->derivation name (with-build-variables inputs outputs builder)
                       #:system system
                       #:target #f
+                      #:graft? #f
                       #:modules modules
                       #:allowed-references allowed-references
                       #:guile-for-build guile)))
@@ -85,6 +86,7 @@ ignored."
                              builder)
                       #:system system
                       #:target target
+                      #:graft? #f
                       #:modules modules
                       #:allowed-references allowed-references
                       #:guile-for-build guile)))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index ff5ede2..56b1bb4 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -923,9 +923,8 @@ corresponding <derivation-input> or store item."
 
   (match graphs
     (((file-names . inputs) ...)
-     (mlet %store-monad ((inputs (without-grafting
-                                  (lower-inputs (map tuple->gexp-input inputs)
-                                                system target))))
+     (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs)
+                                               system target)))
        (return (map cons file-names inputs))))))
 
 (define* (lower-references lst #:key system target)
@@ -938,15 +937,13 @@ names and file names suitable for the 
#:allowed-references argument to
        ((? string? output)
         (return output))
        (($ <gexp-input> thing output native?)
-        (mlet %store-monad ((drv (without-grafting
-                                  (lower-object thing system
-                                                #:target (if native?
-                                                             #f target)))))
+        (mlet %store-monad ((drv (lower-object thing system
+                                               #:target (if native?
+                                                            #f target))))
           (return (derivation->output-path drv output))))
        (thing
-        (mlet %store-monad ((drv (without-grafting
-                                  (lower-object thing system
-                                                #:target target))))
+        (mlet %store-monad ((drv (lower-object thing system
+                                               #:target target)))
           (return (derivation->output-path drv))))))
 
     (mapm/accumulate-builds lower lst)))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 709a198..28d09f5 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1475,6 +1475,42 @@ importing.* \\(guix config\\) from the host"
                      (string=? (readlink (string-append comp "/text"))
                                text)))))))
 
+(test-assert "lower-object, computed-file + grafts"
+  ;; The reference graph should refer to grafted packages when grafts are
+  ;; enabled.  See <https://issues.guix.gnu.org/50676>.
+  (let* ((base    (package
+                    (inherit (dummy-package "trivial"))
+                    (build-system trivial-build-system)
+                    (arguments
+                     `(#:guile ,%bootstrap-guile
+                       #:builder (mkdir %output)))))
+         (pkg     (package
+                    (inherit base)
+                    (version "1.1")
+                    (replacement (package
+                                   (inherit base)
+                                   (version "9.9")))))
+         (exp      #~(begin
+                       (use-modules (ice-9 rdelim))
+                       (let ((item (call-with-input-file "graph" read-line)))
+                         (call-with-output-file #$output
+                           (lambda (port)
+                             (display item port))))))
+         (computed (computed-file "computed" exp
+                                  #:options
+                                  `(#:references-graphs (("graph" ,pkg)))))
+         (drv0     (package-derivation %store pkg #:graft? #t))
+         (drv1     (parameterize ((%graft? #t))
+                     (run-with-store %store
+                       (lower-object computed)))))
+    (build-derivations %store (list drv1))
+
+    ;; The graph obtained in COMPUTED should refer to the grafted version of
+    ;; PKG, not to PKG itself.
+    (string=? (call-with-input-file (derivation->output-path drv1)
+                get-string-all)
+              (derivation->output-path drv0))))
+
 (test-equal "lower-object, computed-file, #:system"
   '("mips64el-linux")
   (run-with-store %store
diff --git a/tests/packages.scm b/tests/packages.scm
index 46f4da1..a9494b5 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -882,6 +882,28 @@
       (build-derivations %store (list d))
       #f)))
 
+(test-assert "trivial with #:allowed-references + grafts"
+  (let* ((g (package
+              (inherit %bootstrap-guile)
+              (replacement (package
+                             (inherit %bootstrap-guile)
+                             (version "9.9")))))
+         (p (package
+              (inherit (dummy-package "trivial"))
+              (build-system trivial-build-system)
+              (inputs (list g))
+              (arguments
+               `(#:guile ,g
+                 #:allowed-references (,g)
+                 #:builder (mkdir %output)))))
+         (d0 (package-derivation %store p #:graft? #f))
+         (d1 (parameterize ((%graft? #t))
+               (package-derivation %store p #:graft? #t))))
+    ;; D1 should be equal to D2 because there's nothing to graft.  In
+    ;; particular, its #:disallowed-references should be lowered in the same
+    ;; way (ungrafted) whether or not #:graft? is true.
+    (string=? (derivation-file-name d1) (derivation-file-name d0))))
+
 (test-assert "search paths"
   (let* ((p (make-prompt-tag "return-search-paths"))
          (t (make-parameter "guile-0"))