summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-09-23 11:57:39 +0200
committerLudovic Courtès <ludo@gnu.org>2019-09-23 11:57:39 +0200
commitb69ce8a8721ad82a528acc21bed68e611e5c6114 (patch)
tree207784803367abf2cb32c894c872877d469436fb
parent90ca791ab082f0513cd5e8af7acfd8db63a6e73a (diff)
deploy: Add '--verbosity' and properly interpret build log.
This is a followup to 91300526b7d9d775bd98a700ed3758420ef9eac6. * guix/scripts/deploy.scm (show-help, %options): Add '--verbosity'. (guix-deploy): Wrap 'with-store' in 'with-status-verbosity'.
-rw-r--r--guix/scripts/deploy.scm47
1 files changed, 29 insertions, 18 deletions
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index cf571756fd..f311587ec3 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -26,6 +26,7 @@
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix grafts)
+ #:use-module (guix status)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
@@ -52,6 +53,8 @@ Perform the deployment specified by FILE.\n"))
(display (G_ "
-V, --version display version information and exit"))
(newline)
+ (display (G_ "
+ -v, --verbosity=LEVEL use the given verbosity LEVEL"))
(show-bug-report-information))
(define %options
@@ -63,6 +66,12 @@ Perform the deployment specified by FILE.\n"))
(lambda (opt name arg result)
(alist-cons 'system arg
(alist-delete 'system result eq?))))
+ (option '(#\v "verbosity") #t #f
+ (lambda (opt name arg result)
+ (let ((level (string->number* arg)))
+ (alist-cons 'verbosity level
+ (alist-delete 'verbosity result)))))
+
%standard-build-options))
(define %default-options
@@ -87,25 +96,27 @@ Perform the deployment specified by FILE.\n"))
(define (guix-deploy . args)
(define (handle-argument arg result)
(alist-cons 'file arg result))
+
(let* ((opts (parse-command-line args %options (list %default-options)
#:argument-handler handle-argument))
(file (assq-ref opts 'file))
(machines (or (and file (load-source-file file)) '())))
- (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-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)))))