[bug#40149] [PATCH 0/5] Assorted 'guix deploy' improvements

[bug#40149] [PATCH 0/5] Assorted 'guix deploy' improvements

[Ludovic Courtès]

Hello!

The first patch arranges so that a single round trip is enough
to perform all the sanity checks on the remote machine.  Previously,
we’d build N derivations, send their results, and perform N remote
evaluation (with N typically in the 3–5 range depending on details
of the OS config.)

(There’s a more general optimization pattern lurking here: I’d really
like to find a way to somehow gather operations like ‘remote-eval’ that
are more efficiently done as a batch, and then scatter results back
to their continuations.  I’ve been thinking about this for some time
and it still hasn’t clicked.  Ideas welcome!)

The remaining patches are basic UI improvements.

Feedback welcome!

Ludo’.

Ludovic Courtès (5):
  machine: ssh: Make sanity checks in a single round trip.
  ui: Add 'indented-string'.
  deploy: Show what machines will be deployed.
  deploy: Write a message upon successful deployment.
  machine: ssh: Better report missing initrd modules.

 gnu/machine/ssh.scm     | 138 +++++++++++++++++++++++-----------------
 guix/scripts/deploy.scm |  23 ++++++-
 guix/scripts/pull.scm   |  17 +----
 guix/ui.scm             |  18 ++++++
 4 files changed, 123 insertions(+), 73 deletions(-)

-- 
2.25.1

[bug#40149] [PATCH 1/5] machine: ssh: Make sanity checks in a single round trip.

[Ludovic Courtès]

* gnu/machine/ssh.scm (<remote-assertion>): New record type.
(remote-let): New macro.
(machine-check-file-system-availability): Rewrite to use 'remote-let'
instead of 'mlet' and 'machine-remote-eval'.
(machine-check-initrd-modules): Likewise.
(machine-check-building-for-appropriate-system): Make non-monadic.
(check-deployment-sanity): Rewrite to gather all the assertions as a
single gexp and pass it to 'machine-remote-eval'.
---
 gnu/machine/ssh.scm | 138 ++++++++++++++++++++++++++------------------
 1 file changed, 81 insertions(+), 57 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 6374373e22..85ecbb6d14 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -39,6 +40,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 textual-ports)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -142,9 +144,24 @@ an environment type of 'managed-host."
 ;;; Safety checks.
 ;;;
 
+;; Assertion to be executed remotely.  This abstraction exists to allow us to
+;; gather a list of expressions to be evaluated and eventually evaluate them
+;; all at once instead of one by one.  (This is pretty much a monad.)
+(define-record-type <remote-assertion>
+  (remote-assertion exp proc)
+  remote-assertion?
+  (exp   remote-assertion-expression)
+  (proc  remote-assertion-procedure))
+
+(define-syntax-rule (remote-let ((var exp)) body ...)
+  "Return a <remote-assertion> that binds VAR to the result of evaluating EXP,
+a gexp, remotely, and evaluate BODY in that context."
+  (remote-assertion exp (lambda (var) body ...)))
+
 (define (machine-check-file-system-availability machine)
-  "Raise a '&message' error condition if any of the file-systems specified in
-MACHINE's 'system' declaration do not exist on the machine."
+  "Return a list of <remote-assertion> that raise a '&message' error condition
+if any of the file-systems specified in MACHINE's 'system' declaration do not
+exist on the machine."
   (define file-systems
     (filter (lambda (fs)
               (and (file-system-mount? fs)
@@ -154,22 +171,18 @@ MACHINE's 'system' declaration do not exist on the machine."
             (operating-system-file-systems (machine-operating-system machine))))
 
   (define (check-literal-file-system fs)
-    (define remote-exp
-      #~(catch 'system-error
-          (lambda ()
-            (stat #$(file-system-device fs))
-            #t)
-          (lambda args
-            (system-error-errno args))))
-
-    (mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
+    (remote-let ((errno #~(catch 'system-error
+                            (lambda ()
+                              (stat #$(file-system-device fs))
+                              #t)
+                            (lambda args
+                              (system-error-errno args)))))
       (when (number? errno)
         (raise (condition
                 (&message
                  (message (format #f (G_ "device '~a' not found: ~a")
                                   (file-system-device fs)
-                                  (strerror errno)))))))
-      (return #t)))
+                                  (strerror errno)))))))))
 
   (define (check-labeled-file-system fs)
     (define remote-exp
@@ -180,14 +193,13 @@ MACHINE's 'system' declaration do not exist on the machine."
             (find-partition-by-label #$(file-system-label->string
                                         (file-system-device fs))))))
 
-    (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
+    (remote-let ((result remote-exp))
       (unless result
         (raise (condition
                 (&message
                  (message (format #f (G_ "no file system with label '~a'")
                                   (file-system-label->string
-                                   (file-system-device fs))))))))
-      (return #t)))
+                                   (file-system-device fs))))))))))
 
   (define (check-uuid-file-system fs)
     (define remote-exp
@@ -203,31 +215,30 @@ MACHINE's 'system' declaration do not exist on the machine."
 
             (find-partition-by-uuid uuid))))
 
-    (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
+    (remote-let ((result remote-exp))
       (unless result
         (raise (condition
                 (&message
                  (message (format #f (G_ "no file system with UUID '~a'")
-                                  (uuid->string (file-system-device fs))))))))
-      (return #t)))
+                                  (uuid->string (file-system-device fs))))))))))
 
-  (mbegin %store-monad
-    (mapm %store-monad check-literal-file-system
-          (filter (lambda (fs)
-                    (string? (file-system-device fs)))
-                  file-systems))
-    (mapm %store-monad check-labeled-file-system
-          (filter (lambda (fs)
-                    (file-system-label? (file-system-device fs)))
-                  file-systems))
-    (mapm %store-monad check-uuid-file-system
-          (filter (lambda (fs)
-              (uuid? (file-system-device fs)))
-                  file-systems))))
+  (append (map check-literal-file-system
+               (filter (lambda (fs)
+                         (string? (file-system-device fs)))
+                       file-systems))
+          (map check-labeled-file-system
+               (filter (lambda (fs)
+                         (file-system-label? (file-system-device fs)))
+                       file-systems))
+          (map check-uuid-file-system
+               (filter (lambda (fs)
+                         (uuid? (file-system-device fs)))
+                       file-systems))))
 
 (define (machine-check-initrd-modules machine)
-  "Raise a '&message' error condition if any of the modules needed by
-'needed-for-boot' file systems in MACHINE are not available in the initrd."
+  "Return a list of <remote-assertion> that raise a '&message' error condition
+if any of the modules needed by 'needed-for-boot' file systems in MACHINE are
+not available in the initrd."
   (define file-systems
     (filter file-system-needed-for-boot?
             (operating-system-file-systems (machine-operating-system machine))))
@@ -255,20 +266,16 @@ MACHINE's 'system' declaration do not exist on the machine."
 
               (missing-modules dev '#$(operating-system-initrd-modules
                                        (machine-operating-system machine)))))))
-    (mlet %store-monad ((missing (machine-remote-eval machine remote-exp)))
-      (return (list fs missing))))
 
-  (mlet %store-monad ((device (mapm %store-monad missing-modules file-systems)))
-    (for-each (match-lambda
-                ((fs missing)
-                 (unless (null? missing)
-                   (raise (condition
-                           (&message
-                            (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
-                                             (file-system-device fs)
-                                             missing))))))))
-              device)
-    (return #t)))
+    (remote-let ((missing remote-exp))
+      (unless (null? missing)
+        (raise (condition
+                (&message
+                 (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
+                                  (file-system-device fs)
+                                  missing))))))))
+
+  (map missing-modules file-systems))
 
 (define (machine-check-building-for-appropriate-system machine)
   "Raise a '&message' error condition if MACHINE is configured to be built
@@ -280,21 +287,38 @@ by MACHINE."
                (not (string= system (machine-ssh-configuration-system config))))
       (raise (condition
               (&message
-               (message (format #f (G_ "incorrect target system \
-('~a' was given, while the system reports that it is '~a')~%")
+               (message (format #f (G_ "incorrect target system\
+ ('~a' was given, while the system reports that it is '~a')~%")
                                 (machine-ssh-configuration-system config)
-                                system)))))))
-  (with-monad %store-monad (return #t)))
+                                system))))))))
 
 (define (check-deployment-sanity machine)
   "Raise a '&message' error condition if it is clear that deploying MACHINE's
 'system' declaration would fail."
-  ;; Order is important here -- an incorrect value for 'system' will cause
-  ;; invocations of 'remote-eval' to fail.
-  (mbegin %store-monad
-    (machine-check-building-for-appropriate-system machine)
-    (machine-check-file-system-availability machine)
-    (machine-check-initrd-modules machine)))
+  (define assertions
+    (append (machine-check-file-system-availability machine)
+            (machine-check-initrd-modules machine)))
+
+  (define aggregate-exp
+    ;; Gather all the expressions so that a single round-trip is enough to
+    ;; evaluate all the ASSERTIONS remotely.
+    #~(map (lambda (file)
+             (false-if-exception (primitive-load file)))
+           '#$(map (lambda (assertion)
+                     (scheme-file "remote-assertion.scm"
+                                  (remote-assertion-expression assertion)))
+                   assertions)))
+
+  ;; First check MACHINE's system type--an incorrect value for 'system' would
+  ;; cause subsequent invocations of 'remote-eval' to fail.
+  (machine-check-building-for-appropriate-system machine)
+
+  (mlet %store-monad ((values (machine-remote-eval machine aggregate-exp)))
+    (for-each (lambda (proc value)
+                (proc value))
+              (map remote-assertion-procedure assertions)
+              values)
+    (return #t)))
 
 \f
 ;;;
-- 
2.25.1

[bug#40149] [PATCH 2/5] ui: Add 'indented-string'.

[Ludovic Courtès]

* guix/scripts/pull.scm (display-news-entry): Remove extra space in
format string for 'indented-string'.
(indented-string): Remove.
(display-new/upgraded-packages)[pretty]: Pass #:initial-indent? to
'indented-string'.
* guix/ui.scm (indented-string): New procedure.
---
 guix/scripts/pull.scm | 17 ++---------------
 guix/ui.scm           | 18 ++++++++++++++++++
 2 files changed, 20 insertions(+), 15 deletions(-)

diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 51d4da209a..1db5ab7237 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -269,7 +269,7 @@ code, to PORT."
   (let ((body (or (assoc-ref body language)
                   (assoc-ref body (%default-message-language))
                   "")))
-    (format port "    ~a~%"
+    (format port "~a~%"
             (indented-string
              (parameterize ((%text-width (- (%text-width) 4)))
                (string-trim-right
@@ -523,19 +523,6 @@ true, display what would be built without actually building it."
 ;;; Queries.
 ;;;
 
-(define (indented-string str indent)
-  "Return STR with each newline preceded by IDENT spaces."
-  (define indent-string
-    (make-list indent #\space))
-
-  (list->string
-   (string-fold-right (lambda (chr result)
-                        (if (eqv? chr #\newline)
-                            (cons chr (append indent-string result))
-                            (cons chr result)))
-                      '()
-                      str)))
-
 (define profile-package-alist
   (mlambda (profile)
     "Return a name/version alist representing the packages in PROFILE."
@@ -592,7 +579,7 @@ Return true when there is more package info to display."
   (define (pretty str column)
     (indented-string (fill-paragraph str (- (%text-width) 4)
                                      column)
-                     4))
+                     4 #:initial-indent? #f))
 
   (define concise/max-item-count
     ;; Maximum number of items to display when CONCISE? is true.
diff --git a/guix/ui.scm b/guix/ui.scm
index 6f1ca9c0b2..698111dd9a 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -103,6 +103,7 @@
             read/eval
             read/eval-package-expression
             check-available-space
+            indented-string
             fill-paragraph
             %text-width
             texi->plain-text
@@ -1163,6 +1164,23 @@ replacement if PORT is not Unicode-capable."
       (lambda ()
         body ...)))))
 
+(define* (indented-string str indent
+                          #:key (initial-indent? #t))
+  "Return STR with each newline preceded by IDENT spaces.  When
+INITIAL-INDENT? is true, the first line is also indented."
+  (define indent-string
+    (make-list indent #\space))
+
+  (list->string
+   (string-fold-right (lambda (chr result)
+                        (if (eqv? chr #\newline)
+                            (cons chr (append indent-string result))
+                            (cons chr result)))
+                      '()
+                      (if initial-indent?
+                          (string-append (list->string indent-string) str)
+                          str))))
+
 (define* (fill-paragraph str width #:optional (column 0))
   "Fill STR such that each line contains at most WIDTH characters, assuming
 that the first character is at COLUMN.
-- 
2.25.1

[bug#40149] [PATCH 3/5] deploy: Show what machines will be deployed.

[Ludovic Courtès]

* guix/scripts/deploy.scm (show-what-to-deploy): New procedure.
(guix-deploy): Call it.
---
 guix/scripts/deploy.scm | 19 +++++++++++++++++++
 1 file changed, 19 insertions(+)

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index ad05c333dc..1f1ca58476 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -1,6 +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 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -97,6 +98,22 @@ Perform the deployment specified by FILE.\n"))
                                            environment-modules))))
     (load* file module)))
 
+(define (show-what-to-deploy machines)
+  "Show the list of machines to deploy, MACHINES."
+  (let ((count (length machines)))
+    (format (current-error-port)
+            (N_ "The following ~*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)
+                                           ", ")
+                              (- (%text-width) 2) 2)
+              2)
+             (current-error-port))
+    (display "\n\n" (current-error-port))))
+
 (define (guix-deploy . args)
   (define (handle-argument arg result)
     (alist-cons 'file arg result))
@@ -105,6 +122,8 @@ Perform the deployment specified by FILE.\n"))
                                    #:argument-handler handle-argument))
          (file (assq-ref opts 'file))
          (machines (or (and file (load-source-file file)) '())))
+    (show-what-to-deploy machines)
+
     (with-status-verbosity (assoc-ref opts 'verbosity)
       (with-store store
         (set-build-options-from-command-line store opts)
-- 
2.25.1

[bug#40149] [PATCH 4/5] deploy: Write a message upon successful deployment.

[Ludovic Courtès]

* guix/scripts/deploy.scm (guix-deploy): Write message upon successful
deployment.
---
 guix/scripts/deploy.scm | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 1f1ca58476..1d652d019d 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -141,5 +141,7 @@ Perform the deployment specified by FILE.\n"))
                                          (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)))))
+                        (run-with-store store (deploy-machine machine))
+                        (info (G_ "successfully deployed ~a~%")
+                              (machine-display-name machine)))))
                   machines)))))
-- 
2.25.1

[bug#40149] [PATCH 5/5] machine: ssh: Better report missing initrd modules.

[Ludovic Courtès]

* gnu/machine/ssh.scm (machine-check-initrd-modules): Improve message
upon module mismatch.
---
 gnu/machine/ssh.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 85ecbb6d14..116da86327 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -271,7 +271,7 @@ not available in the initrd."
       (unless (null? missing)
         (raise (condition
                 (&message
-                 (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
+                 (message (format #f (G_ "missing modules for ~a:~{ ~a~}~%")
                                   (file-system-device fs)
                                   missing))))))))
 
-- 
2.25.1

bug#40149: [PATCH 0/5] Assorted 'guix deploy' improvements

[Ludovic Courtès]

Ludovic Courtès <ludo@gnu.org> skribis:

>   machine: ssh: Make sanity checks in a single round trip.
>   ui: Add 'indented-string'.
>   deploy: Show what machines will be deployed.
>   deploy: Write a message upon successful deployment.
>   machine: ssh: Better report missing initrd modules.

Pushed as 8bc745052e051d142213a0ea74c39bdd7c5ace70.

Ludo’.