me
/
guix
Archived
1
0
Fork 0
Code

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
gnu/machine/ssh.scm
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
(append (machine-check-file-system-availability machine) (parameterize ((%current-system
(machine-check-initrd-modules machine) (machine-ssh-configuration-system
(list (machine-check-forward-update machine)))) (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 (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,50 +474,54 @@ 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)))
(let* ((os (machine-operating-system machine)) ;; Make sure code that check %CURRENT-SYSTEM, such as
(host (machine-ssh-configuration-host-name ;; %BASE-INITRD-MODULES, gets to see the right value.
(machine-configuration machine))) (parameterize ((%current-system system)
(eval (cut machine-remote-eval machine <>)) (%current-target-system #f))
(menu-entries (map boot-parameters->menu-entry boot-parameters)) (let* ((os (machine-operating-system machine))
(bootloader-configuration (operating-system-bootloader os)) (eval (cut machine-remote-eval machine <>))
(bootcfg (operating-system-bootcfg os menu-entries))) (menu-entries (map boot-parameters->menu-entry boot-parameters))
(define-syntax-rule (eval/error-handling condition handler ...) (bootloader-configuration (operating-system-bootloader os))
;; Return a wrapper around EVAL such that HANDLER is evaluated if an (bootcfg (operating-system-bootcfg os menu-entries)))
;; exception is raised. (define-syntax-rule (eval/error-handling condition handler ...)
(lambda (exp) ;; Return a wrapper around EVAL such that HANDLER is evaluated if an
(lambda (store) ;; exception is raised.
(guard (condition ((inferior-exception? condition) (lambda (exp)
(values (begin handler ...) store))) (lambda (store)
(values (run-with-store store (eval exp)) (guard (condition ((inferior-exception? condition)
store))))) (values (begin handler ...) store)))
(values (run-with-store store (eval exp)
#:system system)
store)))))
(mbegin %store-monad (mbegin %store-monad
(with-roll-back #f (with-roll-back #f
(switch-to-system (eval/error-handling c (switch-to-system (eval/error-handling c
(raise (formatted-message (raise (formatted-message
(G_ "\ (G_ "\
failed to switch systems while deploying '~a':~%~{~s ~}") failed to switch systems while deploying '~a':~%~{~s ~}")
host host
(inferior-exception-arguments c)))) (inferior-exception-arguments c))))
os)) os))
(with-roll-back #t (with-roll-back #t
(mbegin %store-monad (mbegin %store-monad
(upgrade-shepherd-services (eval/error-handling c (upgrade-shepherd-services (eval/error-handling c
(warning (G_ "\ (warning (G_ "\
an error occurred while upgrading services on '~a':~%~{~s ~}~%") an error occurred while upgrading services on '~a':~%~{~s ~}~%")
host host
(inferior-exception-arguments (inferior-exception-arguments
c))) c)))
os) os)
(install-bootloader (eval/error-handling c (install-bootloader (eval/error-handling c
(raise (formatted-message (raise (formatted-message
(G_ "\ (G_ "\
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))))))))
;;; ;;;