me
/
guix
Archived
1
0
Fork 0

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.
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

View File

@ -339,9 +339,13 @@ by MACHINE."
"Raise a '&message' error condition if it is clear that deploying MACHINE's "Raise a '&message' error condition if it is clear that deploying MACHINE's
'system' declaration would fail." 'system' declaration would fail."
(define assertions (define assertions
(parameterize ((%current-system
(machine-ssh-configuration-system
(machine-configuration machine)))
(%current-target-system #f))
(append (machine-check-file-system-availability machine) (append (machine-check-file-system-availability machine)
(machine-check-initrd-modules machine) (machine-check-initrd-modules machine)
(list (machine-check-forward-update machine)))) (list (machine-check-forward-update machine)))))
(define aggregate-exp (define aggregate-exp
;; Gather all the expressions so that a single round-trip is enough to ;; 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) (define (deploy-managed-host machine)
"Internal implementation of 'deploy-machine' for MACHINE instances with an "Internal implementation of 'deploy-machine' for MACHINE instances with an
environment type of 'managed-host." 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) (maybe-raise-unsupported-configuration-error machine)
(when (machine-ssh-configuration-authorize? (when (machine-ssh-configuration-authorize?
(machine-configuration machine)) (machine-configuration machine))
@ -466,11 +474,14 @@ have you run 'guix archive --generate-key?'")
(get-string-all port)))) (get-string-all port))))
(machine-ssh-session machine) (machine-ssh-session machine)
(machine-become-command machine))) (machine-become-command machine)))
(mlet %store-monad ((_ (check-deployment-sanity machine)) (mlet %store-monad ((_ (check-deployment-sanity machine))
(boot-parameters (machine-boot-parameters 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)) (let* ((os (machine-operating-system machine))
(host (machine-ssh-configuration-host-name
(machine-configuration machine)))
(eval (cut machine-remote-eval machine <>)) (eval (cut machine-remote-eval machine <>))
(menu-entries (map boot-parameters->menu-entry boot-parameters)) (menu-entries (map boot-parameters->menu-entry boot-parameters))
(bootloader-configuration (operating-system-bootloader os)) (bootloader-configuration (operating-system-bootloader os))
@ -482,7 +493,8 @@ have you run 'guix archive --generate-key?'")
(lambda (store) (lambda (store)
(guard (condition ((inferior-exception? condition) (guard (condition ((inferior-exception? condition)
(values (begin handler ...) store))) (values (begin handler ...) store)))
(values (run-with-store store (eval exp)) (values (run-with-store store (eval exp)
#:system system)
store))))) store)))))
(mbegin %store-monad (mbegin %store-monad
@ -509,7 +521,7 @@ an error occurred while upgrading services on '~a':~%~{~s ~}~%")
failed to install bootloader on '~a':~%~{~s ~}~%") failed to install bootloader on '~a':~%~{~s ~}~%")
host host
(inferior-exception-arguments c)))) (inferior-exception-arguments c))))
bootloader-configuration bootcfg))))))) bootloader-configuration bootcfg))))))))
;;; ;;;