ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 13:58:15 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2022-09-26 17:37:43 +02:00
parent 28a50eeac7
commit 1033645e9d
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 53 additions and 41 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
gnu/machine/ssh.scm
View file

@ -339,9 +339,13 @@ (define (check-deployment-sanity machine)
"Raise a '&message' error condition if it is clear that deploying MACHINE's
'system' declaration would fail."
(define assertions
(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))))
(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 @@ (define-syntax-rule (with-roll-back should-roll-back? mbody ...)
(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,11 +474,14 @@ (define (deploy-managed-host machine)
(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)))
;; 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))
(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))
@ -482,7 +493,8 @@ (define-syntax-rule (eval/error-handling condition handler ...)
(lambda (store)
(guard (condition ((inferior-exception? condition)
(values (begin handler ...) store)))
(values (run-with-store store (eval exp))
(values (run-with-store store (eval exp)
#:system system)
store)))))
(mbegin %store-monad
@ -509,7 +521,7 @@ (define-syntax-rule (eval/error-handling condition handler ...)
failed to install bootloader on '~a':~%~{~s ~}~%")
host
(inferior-exception-arguments c))))
bootloader-configuration bootcfg)))))))
bootloader-configuration bootcfg))))))))
;;;