diff options
Diffstat (limited to 'guix/scripts')
-rw-r--r-- | guix/scripts/archive.scm | 2 | ||||
-rw-r--r-- | guix/scripts/build.scm | 8 | ||||
-rw-r--r-- | guix/scripts/copy.scm | 2 | ||||
-rw-r--r-- | guix/scripts/deploy.scm | 46 | ||||
-rw-r--r-- | guix/scripts/environment.scm | 2 | ||||
-rw-r--r-- | guix/scripts/pack.scm | 2 | ||||
-rw-r--r-- | guix/scripts/package.scm | 3 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 2 | ||||
-rw-r--r-- | guix/scripts/system.scm | 2 |
9 files changed, 39 insertions, 30 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 80f3b704d7..41a2a42c21 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -183,7 +183,7 @@ Export/import one or more packages from/to the store.\n")) (alist-delete 'verbosity result))))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) %standard-build-options)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index af18d8b6f9..79bd84a1a0 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -778,7 +778,7 @@ must be one of 'package', 'all', or 'transitive'~%") (alist-cons 'manifest arg result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) @@ -920,8 +920,10 @@ build." (with-unbound-variable-handling (parameterize ((%graft? graft?)) (append-map (lambda (system) - (append-map (cut compute-derivation <> system) - things-to-build)) + (concatenate + (map/accumulate-builds store + (cut compute-derivation <> system) + things-to-build))) systems)))) (define (show-build-log store file urls) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 2fa31ecf45..f6f64d0a11 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -135,7 +135,7 @@ Copy ITEMS to or from the specified host over SSH.\n")) (alist-delete 'verbosity result))))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\h "help") #f #f (lambda args 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))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index e6f45d3eba..03f455ab7b 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -254,7 +254,7 @@ use '--preserve' instead~%")) (alist-cons 'ad-hoc? #t result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 9d981c05d6..a4b38735a7 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -823,7 +823,7 @@ last resort for relocation." (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\d "derivation") #f #f (lambda (opt name arg result) (alist-cons 'derivation-only? #t result))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 8af0a7a27e..304084796a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -487,8 +487,7 @@ kind of search path~%") #f))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result arg-handler) - (values (alist-cons 'dry-run? #t - (alist-cons 'graft? #f result)) + (values (alist-cons 'dry-run? #t result) #f))) (option '(#\v "verbosity") #t #f (lambda (opt name arg result arg-handler) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index dbd02431fe..dfe7ee7ad5 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -168,7 +168,7 @@ Download and deploy the latest version of Guix.\n")) (alist-delete 'system result eq?)))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\v "verbosity") #t #f (lambda (opt name arg result) (let ((level (string->number* arg))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 61a3c95dbd..a178761203 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1041,7 +1041,7 @@ Some ACTIONS support additional ARGS.\n")) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) - (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (alist-cons 'dry-run? #t result))) (option '(#\v "verbosity") #t #f (lambda (opt name arg result) (let ((level (string->number* arg))) |