[bug#56616] [PATCH] deploy: Honor '--dry-run'.

["Ludovic Courtès" <ludo@gnu.org>]

* guix/scripts/deploy.scm (%options): Add "dry-run".
(show-what-to-deploy): Add #:dry-run? and honor it.
(guix-deploy): Honor --dry-run.
---
 guix/scripts/deploy.scm | 32 ++++++++++++++++++++++----------
 1 file changed, 22 insertions(+), 10 deletions(-)

Hi!

‘guix deploy --help’ would advertise ‘--dry-run’ but it wasn’t
actually implemented.  This patch fixes that.

Note that ‘--dry-run’ doesn’t go beyond loading the deploy file.
In particular, it doesn’t attempt to build anything because that
is left to backends such as (gnu machine ssh).

Thoughts?

Ludo’.

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 27478eabc0..2c76645173 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -76,6 +76,9 @@ (define %options
                  (lambda args
                    (show-version-and-exit "guix deploy")))
 
+         (option '(#\n "dry-run") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'dry-run? #t result)))
          (option '(#\x "execute") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'execute-command? #t result)))
@@ -110,14 +113,20 @@ (module (make-user-module (append '((gnu) (gnu machine))
                                            environment-modules))))
     (load* file module)))
 
-(define (show-what-to-deploy machines)
+(define* (show-what-to-deploy machines #:key (dry-run? #f))
   "Show the list of machines to deploy, MACHINES."
   (let ((count (length machines)))
-    (format (current-error-port)
-            (N_ "The following ~d machine will be deployed:~%"
-                "The following ~d machines will be deployed:~%"
+    (if dry-run?
+        (format (current-error-port)
+                (N_ "The following ~d machine would be deployed:~%"
+                    "The following ~d machines would be deployed:~%"
+                    count)
                 count)
-            count)
+        (format (current-error-port)
+                (N_ "The following ~d 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)
                                            ", ")
@@ -241,6 +250,7 @@ (define (handle-argument arg result)
                                      #:argument-handler handle-argument))
            (file (assq-ref opts 'file))
            (machines (and file (load-source-file file)))
+           (dry-run? (assoc-ref opts 'dry-run?))
            (execute-command? (assoc-ref opts 'execute-command?)))
       (unless file
         (leave (G_ "missing deployment file argument~%")))
@@ -254,7 +264,8 @@ (define (handle-argument arg result)
           (with-build-handler (build-notifier #:use-substitutes?
                                               (assoc-ref opts 'substitutes?)
                                               #:verbosity
-                                              (assoc-ref opts 'verbosity))
+                                              (assoc-ref opts 'verbosity)
+                                              #:dry-run? dry-run?)
             (parameterize ((%graft? (assq-ref opts 'graft?)))
               (if execute-command?
                   (match command
@@ -270,7 +281,8 @@ (define (handle-argument arg result)
                     (_
                      (leave (G_ "'-x' specified but no command given~%"))))
                   (begin
-                    (show-what-to-deploy machines)
-                    (map/accumulate-builds store
-                                           (cut deploy-machine* store <>)
-                                           machines))))))))))
+                    (show-what-to-deploy machines #:dry-run? dry-run?)
+                    (unless dry-run?
+                      (map/accumulate-builds store
+                                             (cut deploy-machine* store <>)
+                                             machines)))))))))))

base-commit: 4ce7f1fb24a111f3e92d5b889d1271bebf109d09
-- 
2.36.1