02/12: system: <operating-system> compiler truly honors the 'system' argument.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 7046e777212233b89df68379c270b448c45195ce
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Jun 14 08:55:03 2022 +0200

    system: <operating-system> compiler truly honors the 'system' argument.
    
    Fixes <https://issues.guix.gnu.org/55951>.
    
    * gnu/system.scm (operating-system-compiler): Parameterize
    '%current-system' and '%current-target-system' before calling
    'operating-system-derivation'.
    * tests/system.scm ("lower-object, %current-system sensitivity"): New
    test.
---
 gnu/system.scm   | 11 ++++++++---
 tests/system.scm | 21 ++++++++++++++++++++-
 2 files changed, 28 insertions(+), 4 deletions(-)

diff --git a/gnu/system.scm b/gnu/system.scm
index 2c81478d00..ba1b7b5152 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -1582,8 +1582,13 @@ configurations."
     (lambda (store)
       ;; XXX: This is not super elegant but we can't pass SYSTEM and TARGET to
       ;; 'operating-system-derivation'.
-      (run-with-store store (operating-system-derivation os)
-                      #:system system
-                      #:target target)))))
+      (parameterize ((%current-system system)
+                     (%current-target-system target))
+        (run-with-store store
+          (mbegin %store-monad
+            (set-guile-for-build (default-guile))
+            (operating-system-derivation os))
+          #:system system
+          #:target target))))))
 
 ;;; system.scm ends here
diff --git a/tests/system.scm b/tests/system.scm
index 019c720e65..873fed4aee 100644
--- a/tests/system.scm
+++ b/tests/system.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2018, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -21,6 +21,10 @@
   #:use-module (gnu)
   #:use-module ((gnu services) #:select (service-value))
   #:use-module (guix store)
+  #:use-module (guix monads)
+  #:use-module ((guix gexp) #:select (lower-object))
+  #:use-module ((guix utils) #:select (%current-system))
+  #:use-module (guix grafts)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64))
 
@@ -64,6 +68,8 @@
                         %base-file-systems))
     (users %base-user-accounts)))
 
+(%graft? #f)
+
 
 (test-begin "system")
 
@@ -140,4 +146,17 @@
                            (type "ext4")
                            (dependencies (list %luks-device))))))))))
 
+(test-assert "lower-object, %current-system sensitivity"
+  ;; Make sure that 'lower-object' returns the same derivation, no matter what
+  ;; '%current-system' is.  See <https://issues.guix.gnu.org/55951>.
+  (let ((drv1 (with-store store
+                (parameterize ((%current-system "x86_64-linux"))
+                  (run-with-store store
+                    (lower-object %os "aarch64-linux")))))
+        (drv2 (with-store store
+                (parameterize ((%current-system "aarch64-linux"))
+                  (run-with-store store
+                    (lower-object %os "aarch64-linux"))))))
+    (eq? drv1 drv2)))
+
 (test-end)