diff options
author | Marius Bakke <mbakke@fastmail.com> | 2020-03-27 00:12:15 +0100 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2020-03-27 00:12:15 +0100 |
commit | 18af6870370226b4d502d7372844e7f2aded5887 (patch) | |
tree | 749d93209bd0cb9710ccaae2207df670f37eaa36 /guix/scripts/deploy.scm | |
parent | 0ab8ad46322bea331ed5f5592843ba35e7f38b37 (diff) | |
parent | 3089b70d766bd9ec70e1464867130b7b864fbe17 (diff) |
Merge branch 'master' into core-updates
Conflicts:
gnu/packages/icu4c.scm
gnu/packages/man.scm
gnu/packages/python-xyz.scm
guix/scripts/environment.scm
guix/scripts/pack.scm
guix/scripts/package.scm
guix/scripts/pull.scm
guix/store.scm
Diffstat (limited to 'guix/scripts/deploy.scm')
-rw-r--r-- | guix/scripts/deploy.scm | 55 |
1 files changed, 39 insertions, 16 deletions
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index ad05c333dc..f70d41f35c 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 David Thompson <davet@gnu.org> ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -97,6 +98,22 @@ Perform the deployment specified by FILE.\n")) environment-modules)))) (load* file module))) +(define (show-what-to-deploy machines) + "Show the list of machines to deploy, MACHINES." + (let ((count (length machines))) + (format (current-error-port) + (N_ "The following ~*machine will be deployed:~%" + "The following ~d machines will be deployed:~%" + count) + count) + (display (indented-string + (fill-paragraph (string-join (map machine-display-name machines) + ", ") + (- (%text-width) 2) 2) + 2) + (current-error-port)) + (display "\n\n" (current-error-port)))) + (define (guix-deploy . args) (define (handle-argument arg result) (alist-cons 'file arg result)) @@ -105,22 +122,28 @@ Perform the deployment specified by FILE.\n")) #:argument-handler handle-argument)) (file (assq-ref opts 'file)) (machines (or (and file (load-source-file file)) '()))) + (show-what-to-deploy machines) + (with-status-verbosity (assoc-ref opts 'verbosity) (with-store store (set-build-options-from-command-line store opts) - (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))))) - machines))))) + (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)))))) |