machine: ssh: Gracefully handle failure of the effectful bits.
Previously, '&inferior-exception' raised by 'upgrade-shepherd-services' and co. would go through as-is, leaving users with an ugly backtrace. * gnu/machine/ssh.scm (deploy-managed-host): Define 'eval/error-handling' and use it in lieu of EVAL as arguments to 'switch-to-system', 'upgrade-shepherd-services', and 'install-bootloader'.
This commit is contained in:
parent
0db906c52c
commit
2885c3568e
|
@ -38,6 +38,9 @@ (define-module (gnu machine ssh)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module ((guix self) #:select (make-config.scm))
|
#:use-module ((guix self) #:select (make-config.scm))
|
||||||
|
#:use-module ((guix inferior)
|
||||||
|
#:select (inferior-exception?
|
||||||
|
inferior-exception-arguments))
|
||||||
#:use-module (gcrypt pk-crypto)
|
#:use-module (gcrypt pk-crypto)
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
@ -443,17 +446,46 @@ (define (deploy-managed-host 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))
|
(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))
|
||||||
(bootcfg (operating-system-bootcfg os menu-entries)))
|
(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)))
|
||||||
|
(run-with-store store (eval exp))))))
|
||||||
|
|
||||||
(mbegin %store-monad
|
(mbegin %store-monad
|
||||||
(with-roll-back #f
|
(with-roll-back #f
|
||||||
(switch-to-system eval os))
|
(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
|
(with-roll-back #t
|
||||||
(mbegin %store-monad
|
(mbegin %store-monad
|
||||||
(upgrade-shepherd-services eval os)
|
(upgrade-shepherd-services (eval/error-handling c
|
||||||
(install-bootloader eval bootloader-configuration bootcfg)))))))
|
(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_ "\
|
||||||
|
failed to install bootloader on '~a':~%~{~s ~}~%")
|
||||||
|
host
|
||||||
|
(inferior-exception-arguments c))))
|
||||||
|
bootloader-configuration bootcfg)))))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
@ -540,4 +572,6 @@ (define (maybe-raise-unsupported-configuration-error machine)
|
||||||
|
|
||||||
;; Local Variables:
|
;; Local Variables:
|
||||||
;; eval: (put 'remote-let 'scheme-indent-function 1)
|
;; eval: (put 'remote-let 'scheme-indent-function 1)
|
||||||
|
;; eval: (put 'with-roll-back 'scheme-indent-function 1)
|
||||||
|
;; eval: (put 'eval/error-handling 'scheme-indent-function 1)
|
||||||
;; End:
|
;; End:
|
||||||
|
|
Loading…
Reference in a new issue