[bug#53486] [PATCH] deploy: Add '--execute'.

[Ludovic Courtès]

* guix/scripts/deploy.scm (show-help, %options): Add '--execute'.
(invoke-command): New procedure.
(guix-deploy): Break arguments at "--" and handle '-x' and associated
command.
* doc/guix.texi (Invoking guix deploy): Document it.
---
 doc/guix.texi           |  24 +++++++++
 guix/scripts/deploy.scm | 111 +++++++++++++++++++++++++++++++++++++---
 2 files changed, 127 insertions(+), 8 deletions(-)

Hi!

Here's a simple but handy option for ‘guix deploy’.

One of the primary use cases for me is being able to run ‘herd
restart XYZ’ after deployment, but I’m also thinking of adding
special support for such things in <machine>:

  • ‘deploy-hook’, which would take a gexp to run after
    successful deployment;

  • and/or ‘services-to-restart’, which would take a list
    of Shepherd services to restart after successful deployment.

Thoughts?

Thanks,
Ludo’.

diff --git a/doc/guix.texi b/doc/guix.texi
index 912a8e3c5a..dbbb50682b 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -35627,6 +35627,30 @@ be accomplished with the following operating system 
configuration snippet:
 For more information regarding the format of the @file{sudoers} file,
 consult @command{man sudoers}.
 
+Once you've deployed a system on a set of machines, you may find it
+useful to run a command on all of them.  The @option{--execute} or
+@option{-x} option lets you do that; the example below runs
+@command{uname -a} on all the machines listed in the deployment file:
+
+@example
+guix deploy @var{file} -x -- uname -a
+@end example
+
+One thing you may often need to do after deployment is restart specific
+services on all the machines, which you can do like so:
+
+@example
+guix deploy @var{file} -x -- herd restart @var{service}
+@end example
+
+The @command{guix deploy -x} command returns zero if and only if the
+command succeeded on all the machines.
+
+@c FIXME/TODO: Separate the API doc from the CLI doc.
+
+Below are the data types you need to know about when writing a
+deployment file.
+
 @deftp {Data Type} machine
 This is the data type representing a single machine in a heterogeneous Guix
 deployment.
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 1707622c4f..27478eabc0 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 David Thompson <davet@gnu.org>
 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,18 +24,21 @@ (define-module (guix scripts deploy)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
   #:use-module (guix store)
+  #:use-module (guix gexp)
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix grafts)
-  #:use-module (guix status)
+  #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module (guix diagnostics)
   #:use-module (guix i18n)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
   #: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)
+  #:use-module (srfi srfi-71)
   #:export (guix-deploy))
 
 ;;; Commentary:
@@ -58,6 +61,9 @@ (define (show-help)
   -V, --version          display version information and exit"))
   (newline)
   (display (G_ "
+  -x, --execute          execute the following command on all the machines"))
+  (newline)
+  (display (G_ "
   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
   (show-bug-report-information))
 
@@ -70,6 +76,9 @@ (define %options
                  (lambda args
                    (show-version-and-exit "guix deploy")))
 
+         (option '(#\x "execute") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'execute-command? #t result)))
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
@@ -152,6 +161,74 @@ (define (deploy-machine* store machine)
     (info (G_ "successfully deployed ~a~%")
           (machine-display-name machine))))
 
+(define (invoke-command store machine command)
+  "Invoke COMMAND, a list of strings, on MACHINE.  Display its output (if any)
+and its error code if it's non-zero.  Return true if COMMAND succeeded, false
+otherwise."
+  (define invocation
+    #~(begin
+        (use-modules (ice-9 match)
+                     (ice-9 rdelim)
+                     (srfi srfi-11))
+
+        (define (spawn . command)
+          ;; Spawn COMMAND; return its PID and an input port to read its
+          ;; standard output and standard error.
+          (match (pipe)
+            ((input . output)
+             (match (pipe)
+               ((input .  output)
+                (match (primitive-fork)
+                  (0
+                   (dynamic-wind
+                     (const #t)
+                     (lambda ()
+                       (close-port input)
+                       (dup2 (fileno output) 1)
+                       (dup2 (fileno output) 2)
+                       (apply execlp (car command) command))
+                     (lambda ()
+                       (primitive-exit 127))))
+                  (pid
+                   (close-port output)
+                   (values pid input))))))))
+
+        ;; XXX: 'open-pipe*' is unsuitable here because it does not capture
+        ;; stderr, so roll our own.
+        (let-values (((pid pipe) (spawn #$@command)))
+          (let loop ((lines '()))
+            (match (read-line pipe 'concat)
+              ((? eof-object?)
+               (list (cdr (waitpid pid))
+                     (string-concatenate-reverse lines)))
+              (line
+               (loop (cons line lines))))))))
+
+  (match (run-with-store store
+           (machine-remote-eval machine invocation))
+    ((code output)
+     (match code
+       ((? zero?)
+        (info (G_ "~a: command succeeded~%")
+              (machine-display-name machine)))
+       ((= status:exit-val code)
+        (report-error (G_ "~a: command exited with code ~a~%")
+                      (machine-display-name machine) code))
+       ((= status:stop-sig signal)
+        (report-error (G_ "~a: command stopped with signal ~a~%")
+                      signal))
+       ((= status:term-sig signal)
+        (report-error (G_ "~a: command terminated with signal ~a~%")
+                      signal)))
+
+     (unless (string-null? output)
+       (info (G_ "command output on ~a:~%")
+             (machine-display-name machine))
+       (display output)
+       (newline))
+
+     (zero? code))))
+
 
 (define-command (guix-deploy . args)
   (synopsis "deploy operating systems on a set of machines")
@@ -159,14 +236,17 @@ (define (handle-argument arg result)
     (alist-cons 'file arg result))
 
   (with-error-handling
-    (let* ((opts (parse-command-line args %options (list %default-options)
+    (let* ((args command (break (cut string=? "--" <>) args))
+           (opts (parse-command-line args %options (list %default-options)
                                      #:argument-handler handle-argument))
            (file (assq-ref opts 'file))
-           (machines (and file (load-source-file file))))
+           (machines (and file (load-source-file file)))
+           (execute-command? (assoc-ref opts 'execute-command?)))
       (unless file
         (leave (G_ "missing deployment file argument~%")))
 
-      (show-what-to-deploy machines)
+      (when (and (pair? command) (not execute-command?))
+        (leave (G_ "'--' was used by '-x' was not specified~%")))
 
       (with-status-verbosity (assoc-ref opts 'verbosity)
         (with-store store
@@ -176,6 +256,21 @@ (define (handle-argument arg result)
                                               #:verbosity
                                               (assoc-ref opts 'verbosity))
             (parameterize ((%graft? (assq-ref opts 'graft?)))
-              (map/accumulate-builds store
-                                     (cut deploy-machine* store <>)
-                                     machines))))))))
+              (if execute-command?
+                  (match command
+                    (("--" command ..1)
+                     ;; Exit with zero unless COMMAND failed on one or more
+                     ;; machines.
+                     (exit
+                      (fold (lambda (machine result)
+                              (and (invoke-command store machine command)
+                                   result))
+                            #t
+                            machines)))
+                    (_
+                     (leave (G_ "'-x' specified but no command given~%"))))
+                  (begin
+                    (show-what-to-deploy machines)
+                    (map/accumulate-builds store
+                                           (cut deploy-machine* store <>)
+                                           machines))))))))))

base-commit: ee6bf00b2d89f6acab55b7a82896d99e39c1229b
-- 
2.34.0