nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

This is a followup to 91300526b7.

* guix/scripts/deploy.scm (show-help, %options): Add '--verbosity'.
(guix-deploy): Wrap 'with-store' in 'with-status-verbosity'.
master
Ludovic Courtès 2019-09-23 11:57:39 +02:00
parent 90ca791ab0
commit b69ce8a872
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 29 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
guix/scripts/deploy.scm
View File

@ -26,6 +26,7 @@
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix grafts) #:use-module (guix grafts)
#:use-module (guix status)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
@ -52,6 +53,8 @@ Perform the deployment specified by FILE.\n"))
(display (G_ " (display (G_ "
-V, --version display version information and exit")) -V, --version display version information and exit"))
(newline) (newline)
(display (G_ "
-v, --verbosity=LEVEL use the given verbosity LEVEL"))
(show-bug-report-information)) (show-bug-report-information))
(define %options (define %options
@ -63,6 +66,12 @@ Perform the deployment specified by FILE.\n"))
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'system arg (alist-cons 'system arg
(alist-delete 'system result eq?)))) (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)) %standard-build-options))
(define %default-options (define %default-options
@ -87,25 +96,27 @@ Perform the deployment specified by FILE.\n"))
(define (guix-deploy . args) (define (guix-deploy . args)
(define (handle-argument arg result) (define (handle-argument arg result)
(alist-cons 'file arg result)) (alist-cons 'file arg result))
(let* ((opts (parse-command-line args %options (list %default-options) (let* ((opts (parse-command-line args %options (list %default-options)
#:argument-handler handle-argument)) #:argument-handler handle-argument))
(file (assq-ref opts 'file)) (file (assq-ref opts 'file))
(machines (or (and file (load-source-file file)) '()))) (machines (or (and file (load-source-file file)) '())))
(with-store store (with-status-verbosity (assoc-ref opts 'verbosity)
(set-build-options-from-command-line store opts) (with-store store
(for-each (lambda (machine) (set-build-options-from-command-line store opts)
(info (G_ "deploying to ~a...~%") (for-each (lambda (machine)
(machine-display-name machine)) (info (G_ "deploying to ~a...~%")
(parameterize ((%graft? (assq-ref opts 'graft?))) (machine-display-name machine))
(guard (c ((message-condition? c) (parameterize ((%graft? (assq-ref opts 'graft?)))
(report-error (G_ "failed to deploy ~a: ~a~%") (guard (c ((message-condition? c)
(machine-display-name machine) (report-error (G_ "failed to deploy ~a: ~a~%")
(condition-message c))) (machine-display-name machine)
((deploy-error? c) (condition-message c)))
(when (deploy-error-should-roll-back c) ((deploy-error? c)
(info (G_ "rolling back ~a...~%") (when (deploy-error-should-roll-back c)
(machine-display-name machine)) (info (G_ "rolling back ~a...~%")
(run-with-store store (roll-back-machine machine))) (machine-display-name machine))
(apply throw (deploy-error-captured-args c)))) (run-with-store store (roll-back-machine machine)))
(run-with-store store (deploy-machine machine))))) (apply throw (deploy-error-captured-args c))))
machines)))) (run-with-store store (deploy-machine machine)))))
machines)))))