diff options
author | Marius Bakke <mbakke@fastmail.com> | 2020-03-30 12:17:33 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2020-03-30 12:17:33 +0200 |
commit | ae0badf5bb791428423a98d4e4e2b8d297a5d4be (patch) | |
tree | 4282d243db3e90839a5f7d3b5878674ccd0e2e14 /guix/scripts/deploy.scm | |
parent | ee401ed9249fbe284ef1b9b437d39207ca88131b (diff) | |
parent | 927f3655662b41f25225ea03baa3ded687aa7cbb (diff) | |
download | guix-patches-ae0badf5bb791428423a98d4e4e2b8d297a5d4be.tar guix-patches-ae0badf5bb791428423a98d4e4e2b8d297a5d4be.tar.gz |
Merge branch 'master' into core-updates
Conflicts:
gnu/packages/admin.scm
gnu/packages/commencement.scm
gnu/packages/guile.scm
gnu/packages/linux.scm
gnu/packages/package-management.scm
gnu/packages/pulseaudio.scm
gnu/packages/web.scm
Diffstat (limited to 'guix/scripts/deploy.scm')
-rw-r--r-- | guix/scripts/deploy.scm | 46 |
1 files changed, 27 insertions, 19 deletions
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index f70d41f35c..4466a0c632 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) @@ -102,7 +103,7 @@ Perform the deployment specified by FILE.\n")) "Show the list of machines to deploy, MACHINES." (let ((count (length machines))) (format (current-error-port) - (N_ "The following ~*machine will be deployed:~%" + (N_ "The following ~d machine will be deployed:~%" "The following ~d machines will be deployed:~%" count) count) @@ -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,7 @@ 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?))) + (map/accumulate-builds store + (cut deploy-machine* store <>) + machines))))))) |