From 2885c3568edec35086f8feeae5b60259cbea407c Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 1 Jun 2021 22:35:28 +0200
Subject: 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'.
---
 gnu/machine/ssh.scm | 40 +++++++++++++++++++++++++++++++++++++---
 1 file changed, 37 insertions(+), 3 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index fa942169c4..93b0a007da 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -38,6 +38,9 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #: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 (ice-9 format)
   #:use-module (ice-9 match)
@@ -443,17 +446,46 @@ have you run 'guix archive --generate-key?'")
   (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)))
+              (run-with-store store (eval exp))))))
+
       (mbegin %store-monad
         (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
           (mbegin %store-monad
-            (upgrade-shepherd-services eval os)
-            (install-bootloader eval bootloader-configuration bootcfg)))))))
+            (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_ "\
+failed to install bootloader on '~a':~%~{~s ~}~%")
+                                          host
+                                          (inferior-exception-arguments c))))
+                                bootloader-configuration bootcfg)))))))
 
 
 ;;;
@@ -540,4 +572,6 @@ for environment of type '~a'")
 
 ;; Local Variables:
 ;; 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:
-- 
cgit 1.4.1