From 98c075c24e26798ef52ab66641faa7b0aa87726b Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 1 Jul 2021 21:30:46 +0200
Subject: 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 a66dbea1b7..3ba61b42c9 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 47d10af5bc..47fc34d3ce 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)))
-- 
cgit v1.2.3