summaryrefslogtreecommitdiff
path: root/guix/scripts/deploy.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-03-29 15:51:08 +0200
committerLudovic Courtès <ludo@gnu.org>2020-03-29 23:14:27 +0200
commitd089b233353f05440a97afc5c1e903b8c1891969 (patch)
treebaa5e3d242cbae77bcea89a47d7667fbb548c413 /guix/scripts/deploy.scm
parent4c60d5325e5ea5534d57518e315c442f70745a7a (diff)
deploy: Factorize machine deployment.
* guix/scripts/deploy.scm (deploy-machine*): New procedure. (guix-deploy): Call it in 'for-each'.
Diffstat (limited to 'guix/scripts/deploy.scm')
-rw-r--r--guix/scripts/deploy.scm42
1 files changed, 24 insertions, 18 deletions
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 5c871cd6ed..7a44b9a503 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)))))))