01/05: deploy: Factorize machine deployment.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit d089b233353f05440a97afc5c1e903b8c1891969
Author: Ludovic Courtès <address@hidden>
AuthorDate: Sun Mar 29 15:51:08 2020 +0200

    deploy: Factorize machine deployment.
    
    * guix/scripts/deploy.scm (deploy-machine*): New procedure.
    (guix-deploy): Call it in 'for-each'.
---
 guix/scripts/deploy.scm | 42 ++++++++++++++++++++++++------------------
 1 file changed, 24 insertions(+), 18 deletions(-)

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 5c871cd..7a44b9a 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -30,6 +30,7 @@
   #:use-module (guix status)
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
@@ -114,6 +115,27 @@ Perform the deployment specified by FILE.\n"))
              (current-error-port))
     (display "\n\n" (current-error-port))))
 
+(define (deploy-machine* store machine)
+  "Deploy MACHINE, taking care of error handling."
+  (info (G_ "deploying to ~a...~%")
+        (machine-display-name machine))
+
+  (guard (c ((message-condition? c)
+             (report-error (G_ "failed to deploy ~a: ~a~%")
+                           (machine-display-name machine)
+                           (condition-message c)))
+            ((deploy-error? c)
+             (when (deploy-error-should-roll-back c)
+               (info (G_ "rolling back ~a...~%")
+                     (machine-display-name machine))
+               (run-with-store store (roll-back-machine machine)))
+             (apply throw (deploy-error-captured-args c))))
+    (run-with-store store (deploy-machine machine))
+
+    (info (G_ "successfully deployed ~a~%")
+          (machine-display-name machine))))
+
+
 (define (guix-deploy . args)
   (define (handle-argument arg result)
     (alist-cons 'file arg result))
@@ -129,21 +151,5 @@ Perform the deployment specified by FILE.\n"))
         (set-build-options-from-command-line store opts)
         (with-build-handler (build-notifier #:use-substitutes?
                                             (assoc-ref opts 'substitutes?))
-          (for-each (lambda (machine)
-                      (info (G_ "deploying to ~a...~%")
-                            (machine-display-name machine))
-                      (parameterize ((%graft? (assq-ref opts 'graft?)))
-                        (guard (c ((message-condition? c)
-                                   (report-error (G_ "failed to deploy ~a: 
~a~%")
-                                                 (machine-display-name machine)
-                                                 (condition-message c)))
-                                  ((deploy-error? c)
-                                   (when (deploy-error-should-roll-back c)
-                                     (info (G_ "rolling back ~a...~%")
-                                           (machine-display-name machine))
-                                     (run-with-store store (roll-back-machine 
machine)))
-                                   (apply throw (deploy-error-captured-args 
c))))
-                          (run-with-store store (deploy-machine machine))
-                          (info (G_ "successfully deployed ~a~%")
-                                (machine-display-name machine)))))
-                    machines))))))
+          (parameterize ((%graft? (assq-ref opts 'graft?)))
+            (for-each (cut deploy-machine* store <>) machines)))))))