01/04: deploy: Add '--verbosity' and properly interpret build log.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit b69ce8a8721ad82a528acc21bed68e611e5c6114
Author: Ludovic Courtès <address@hidden>
Date:   Mon Sep 23 11:57:39 2019 +0200

    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'.
---
 guix/scripts/deploy.scm | 47 +++++++++++++++++++++++++++++------------------
 1 file changed, 29 insertions(+), 18 deletions(-)

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index cf57175..f311587 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)))))