summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-09-26 17:37:43 +0200
committerLudovic Courtès <ludo@gnu.org>2022-09-26 23:29:35 +0200
commit1033645e9d3899edd6b052b19e24c0a718b95e88 (patch)
treec97fa94b8a9dc58a117ccbfd11de9766e7a0f9b9 /gnu
parent28a50eeac796d1b45200746cc685c7e20413d05c (diff)
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.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/machine/ssh.scm96
1 files 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))))))))
;;;