02/02: packages: 'package-derivation' honors 'system' again.

[guix-commits]

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

commit 98c075c24e26798ef52ab66641faa7b0aa87726b
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Jul 1 21:30:46 2021 +0200

    packages: 'package-derivation' honors 'system' again.
    
    Fixes a regression introduced in
    7d873f194ca69d6096d28d7a224ab78e83e34fe1.
    
    Starting from 7d873f194ca69d6096d28d7a224ab78e83e34fe1, running
    
      guix build -s aarch64-linux sed
    
    on an x86_64-linux machine would return an x86_64-linux machine, whereby
    only the top derivation of the graph would be aarch64-linux while all
    its dependencies would be x86_64-linux.
    
    * guix/packages.scm (expand-input): Add 'system' parameter and honor it.
    (bag->derivation, bag->cross-derivation): Pass SYSTEM to 'expand-input'.
    * tests/packages.scm ("package-derivation, different system"): New test.
---
 guix/packages.scm  | 22 +++++++++++++---------
 tests/packages.scm | 15 +++++++++++++++
 2 files changed, 28 insertions(+), 9 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index a66dbea..3ba61b4 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1211,7 +1211,7 @@ Return the cached result when available."
          (#f
           (cache! cache package key thunk)))))))
 
-(define* (expand-input package input #:key target)
+(define* (expand-input package input system #:key target)
   "Expand INPUT, an input tuple, to a name/<gexp-input> tuple.  PACKAGE is
 only used to provide contextual information in exceptions."
   (with-monad %store-monad
@@ -1224,15 +1224,19 @@ only used to provide contextual information in 
exceptions."
       ;; derivation.
       (((? string? name) (? package? package))
        (mlet %store-monad ((drv (if target
-                                    (package->cross-derivation package target
+                                    (package->cross-derivation package
+                                                               target system
                                                                #:graft? #f)
-                                    (package->derivation package #:graft? 
#f))))
+                                    (package->derivation package system
+                                                         #:graft? #f))))
          (return (list name (gexp-input drv #:native? (not target))))))
       (((? string? name) (? package? package) (? string? output))
        (mlet %store-monad ((drv (if target
-                                    (package->cross-derivation package target
+                                    (package->cross-derivation package
+                                                               target system
                                                                #:graft? #f)
-                                    (package->derivation package #:graft? 
#f))))
+                                    (package->derivation package system
+                                                         #:graft? #f))))
          (return (list name (gexp-input drv output #:native? (not target))))))
 
       (((? string? name) (? file-like? thing))
@@ -1462,7 +1466,7 @@ error reporting."
       (mlet* %store-monad ((system ->  (bag-system bag))
                            (inputs ->  (bag-transitive-inputs bag))
                            (input-drvs (mapm %store-monad
-                                             (cut expand-input context <>)
+                                             (cut expand-input context <> 
system)
                                              inputs))
                            (paths ->   (delete-duplicates
                                         (append-map (match-lambda
@@ -1489,15 +1493,15 @@ This is an internal procedure."
                        (host ->     (bag-transitive-host-inputs bag))
                        (host-drvs   (mapm %store-monad
                                           (cut expand-input context <>
-                                               #:target target)
+                                               system #:target target)
                                           host))
                        (target* ->  (bag-transitive-target-inputs bag))
                        (target-drvs (mapm %store-monad
-                                          (cut expand-input context <>)
+                                          (cut expand-input context <> system)
                                           target*))
                        (build ->    (bag-transitive-build-inputs bag))
                        (build-drvs  (mapm %store-monad
-                                          (cut expand-input context <>)
+                                          (cut expand-input context <> system)
                                           build))
                        (all ->      (append build target* host))
                        (paths ->    (delete-duplicates
diff --git a/tests/packages.scm b/tests/packages.scm
index 47d10af..47fc34d 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -717,6 +717,21 @@
     (string=? (derivation-file-name (package-derivation %store p0))
               (derivation-file-name (package-derivation %store p1)))))
 
+(test-assert "package-derivation, different system"
+  ;; Make sure the 'system' argument of 'package-derivation' is respected.
+  (let* ((system (if (string=? (%current-system) "x86_64-linux")
+                     "aarch64-linux"
+                     "x86_64-linux"))
+         (drv    (package-derivation %store (dummy-package "p")
+                                     system #:graft? #f)))
+    (define right-system?
+      (mlambdaq (drv)
+        (and (string=? (derivation-system drv) system)
+             (every (compose right-system? derivation-input-derivation)
+                    (derivation-inputs drv)))))
+
+    (right-system? drv)))
+
 (test-assert "package-output"
   (let* ((package  (dummy-package "p"))
          (drv      (package-derivation %store package)))