01/18: machine: ssh: Parameterize '%current-system' early on.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 1033645e9d3899edd6b052b19e24c0a718b95e88
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Sep 26 17:37:43 2022 +0200

    machine: ssh: Parameterize '%current-system' early on.
    
    Fixes <https://issues.guix.gnu.org/58084>.
    Reported by Maxim Cournoyer <maxim.cournoyer@gmail.com>.
    
    Previously, "sanity checks" and other operations would happen in a
    context where '%current-system' has its default value.  Thus, running
    'guix deploy' on x86_64-linux machine for an aarch64-linux one would
    lead things like '%base-initrd-modules' to see "x86_64-linux" as the
    '%current-system' value, in turn making the wrong choices.
    
    * gnu/machine/ssh.scm (check-deployment-sanity)[assertions]: Wrap in
    'parameterize'.
    (deploy-managed-host): Likewise for the 'mlet' body.
---
 gnu/machine/ssh.scm | 96 ++++++++++++++++++++++++++++++-----------------------
 1 file changed, 54 insertions(+), 42 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 550c989c34..60d127340a 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -339,9 +339,13 @@ by MACHINE."
   "Raise a '&message' error condition if it is clear that deploying MACHINE's
 'system' declaration would fail."
   (define assertions
-    (append (machine-check-file-system-availability machine)
-            (machine-check-initrd-modules machine)
-            (list (machine-check-forward-update machine))))
+    (parameterize ((%current-system
+                    (machine-ssh-configuration-system
+                     (machine-configuration machine)))
+                   (%current-target-system #f))
+      (append (machine-check-file-system-availability machine)
+              (machine-check-initrd-modules machine)
+              (list (machine-check-forward-update machine)))))
 
   (define aggregate-exp
     ;; Gather all the expressions so that a single round-trip is enough to
@@ -453,6 +457,10 @@ the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
 (define (deploy-managed-host machine)
   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 environment type of 'managed-host."
+  (define config (machine-configuration machine))
+  (define host   (machine-ssh-configuration-host-name config))
+  (define system (machine-ssh-configuration-system config))
+
   (maybe-raise-unsupported-configuration-error machine)
   (when (machine-ssh-configuration-authorize?
          (machine-configuration machine))
@@ -466,50 +474,54 @@ have you run 'guix archive --generate-key?'")
                                        (get-string-all port))))
                                   (machine-ssh-session machine)
                                   (machine-become-command machine)))
+
   (mlet %store-monad ((_ (check-deployment-sanity machine))
                       (boot-parameters (machine-boot-parameters machine)))
-    (let* ((os (machine-operating-system machine))
-           (host (machine-ssh-configuration-host-name
-                  (machine-configuration machine)))
-           (eval (cut machine-remote-eval machine <>))
-           (menu-entries (map boot-parameters->menu-entry boot-parameters))
-           (bootloader-configuration (operating-system-bootloader os))
-           (bootcfg (operating-system-bootcfg os menu-entries)))
-      (define-syntax-rule (eval/error-handling condition handler ...)
-        ;; Return a wrapper around EVAL such that HANDLER is evaluated if an
-        ;; exception is raised.
-        (lambda (exp)
-          (lambda (store)
-            (guard (condition ((inferior-exception? condition)
-                               (values (begin handler ...) store)))
-              (values (run-with-store store (eval exp))
-                      store)))))
-
-      (mbegin %store-monad
-        (with-roll-back #f
-          (switch-to-system (eval/error-handling c
-                              (raise (formatted-message
-                                      (G_ "\
+    ;; Make sure code that check %CURRENT-SYSTEM, such as
+    ;; %BASE-INITRD-MODULES, gets to see the right value.
+    (parameterize ((%current-system system)
+                   (%current-target-system #f))
+      (let* ((os (machine-operating-system machine))
+             (eval (cut machine-remote-eval machine <>))
+             (menu-entries (map boot-parameters->menu-entry boot-parameters))
+             (bootloader-configuration (operating-system-bootloader os))
+             (bootcfg (operating-system-bootcfg os menu-entries)))
+        (define-syntax-rule (eval/error-handling condition handler ...)
+          ;; Return a wrapper around EVAL such that HANDLER is evaluated if an
+          ;; exception is raised.
+          (lambda (exp)
+            (lambda (store)
+              (guard (condition ((inferior-exception? condition)
+                                 (values (begin handler ...) store)))
+                (values (run-with-store store (eval exp)
+                                        #:system system)
+                        store)))))
+
+        (mbegin %store-monad
+          (with-roll-back #f
+            (switch-to-system (eval/error-handling c
+                                (raise (formatted-message
+                                        (G_ "\
 failed to switch systems while deploying '~a':~%~{~s ~}")
-                                      host
-                                      (inferior-exception-arguments c))))
-                            os))
-        (with-roll-back #t
-          (mbegin %store-monad
-            (upgrade-shepherd-services (eval/error-handling c
-                                         (warning (G_ "\
+                                        host
+                                        (inferior-exception-arguments c))))
+                              os))
+          (with-roll-back #t
+            (mbegin %store-monad
+              (upgrade-shepherd-services (eval/error-handling c
+                                           (warning (G_ "\
 an error occurred while upgrading services on '~a':~%~{~s ~}~%")
-                                                  host
-                                                  (inferior-exception-arguments
-                                                   c)))
-                                       os)
-            (install-bootloader (eval/error-handling c
-                                  (raise (formatted-message
-                                          (G_ "\
+                                                    host
+                                                    
(inferior-exception-arguments
+                                                     c)))
+                                         os)
+              (install-bootloader (eval/error-handling c
+                                    (raise (formatted-message
+                                            (G_ "\
 failed to install bootloader on '~a':~%~{~s ~}~%")
-                                          host
-                                          (inferior-exception-arguments c))))
-                                bootloader-configuration bootcfg)))))))
+                                            host
+                                            (inferior-exception-arguments c))))
+                                  bootloader-configuration bootcfg))))))))
 
 
 ;;;