02/02: offload: Add "test" sub-command.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit aebaee95cc26d404a8d7b62aece77dfbddb75836
Author: Ludovic Courtès <address@hidden>
Date:   Mon Dec 5 18:16:04 2016 +0100

    offload: Add "test" sub-command.
    
    * guix/scripts/offload.scm (assert-node-repl, assert-node-has-guix)
    (nonce, assert-node-can-import, assert-node-can-export)
    (check-machine-availability): New procedures.
    (%random-state): New variable.
    (guix-offload): Add case for "test".
    * doc/guix.texi (Daemon Offload Setup): Document it.  Remove obsolete
    bit about remote invocation of 'guix build'.
---
 doc/guix.texi            |   25 +++++++++++--
 guix/scripts/offload.scm |   87 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 109 insertions(+), 3 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 47d0d71..4d7f96d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -941,9 +941,8 @@ name, and they will be scheduled on matching build machines.
 @end table
 @end deftp
 
-The @code{guix} command must be in the search path on the build
-machines, since offloading works by invoking the @code{guix archive} and
address@hidden build} commands.  In addition, the Guix modules must be in
+The @code{guile} command must be in the search path on the build
+machines.  In addition, the Guix modules must be in
 @code{$GUILE_LOAD_PATH} on the build machine---you can check whether
 this is the case by running:
 
@@ -978,6 +977,26 @@ the master receives files from a build machine (and 
@i{vice versa}), its
 build daemon can make sure they are genuine, have not been tampered
 with, and that they are signed by an authorized key.
 
address@hidden offload test
+To test whether your setup is operational, run this command on the
+master node:
+
address@hidden
+# guix offload test
address@hidden example
+
+This will attempt to connect to each of the build machines specified in
address@hidden/etc/guix/machines.scm}, make sure Guile and the Guix modules are
+available on each machine, attempt to export to the machine and import
+from it, and report any error in the process.
+
+If you want to test a different machine file, just specify it on the
+command line:
+
address@hidden
+# guix offload test machines-qualif.scm
address@hidden example
+
 
 @node Invoking guix-daemon
 @section Invoking @command{guix-daemon}
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 237a963..4d697f7 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -625,6 +625,86 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
 
 
 ;;;
+;;; Installation tests.
+;;;
+
+(define (assert-node-repl node name)
+  "Bail out if NODE is not running Guile."
+  (match (node-guile-version node)
+    (#f
+     (leave (_ "Guile could not be started on '~a'~%")
+            name))
+    ((? string? version)
+     ;; Note: The version string already contains the word "Guile".
+     (info (_ "'~a' is running ~a~%")
+           name (node-guile-version node)))))
+
+(define (assert-node-has-guix node name)
+  "Bail out if NODE lacks the (guix) module, or if its daemon is not running."
+  (match (node-eval node
+                    '(begin
+                       (use-modules (guix))
+                       (with-store store
+                         (add-text-to-store store "test"
+                                            "Hello, build machine!"))))
+    ((? string? str)
+     (info (_ "Guix is usable on '~a' (test returned ~s)~%")
+           name str))
+    (x
+     (leave (_ "failed to use Guix module on '~a' (test returned ~s)~%")
+            name x))))
+
+(define %random-state
+  (delay
+    (seed->random-state (logxor (getpid) (car (gettimeofday))))))
+
+(define (nonce)
+  (string-append (gethostname) "-"
+                 (number->string (random 1000000 (force %random-state)))))
+
+(define (assert-node-can-import node name daemon-socket)
+  "Bail out if NODE refuses to import our archives."
+  (let ((session (node-session node)))
+    (with-store store
+      (let* ((item   (add-text-to-store store "export-test" (nonce)))
+             (remote (connect-to-remote-daemon session daemon-socket)))
+        (send-files (list item) remote)
+        (if (valid-path? remote item)
+            (info (_ "'~a' successfully imported '~a'~%")
+                  name item)
+            (leave (_ "'~a' was not properly imported on '~a'~%")
+                   item name))))))
+
+(define (assert-node-can-export node name daemon-socket)
+  "Bail out if we cannot import signed archives from NODE."
+  (let* ((session (node-session node))
+         (remote  (connect-to-remote-daemon session daemon-socket))
+         (item    (add-text-to-store remote "import-test" (nonce)))
+         (port    (store-export-channel session (list item))))
+    (with-store store
+      (if (and (import-paths store port)
+               (valid-path? store item))
+          (info (_ "successfully imported '~a' from '~a'~%")
+                item name)
+          (leave (_ "failed to import '~a' from '~a'~%")
+                 item name)))))
+
+(define (check-machine-availability machine-file)
+  "Check that each machine in MACHINE-FILE is usable as a build machine."
+  (let ((machines (build-machines machine-file)))
+    (info (_ "testing ~a build machines defined in '~a'...~%")
+          (length machines) machine-file)
+    (let* ((names    (map build-machine-name machines))
+           (sockets  (map build-machine-daemon-socket machines))
+           (sessions (map open-ssh-session machines))
+           (nodes    (map make-node sessions)))
+      (for-each assert-node-repl nodes names)
+      (for-each assert-node-has-guix nodes names)
+      (for-each assert-node-can-import nodes names sockets)
+      (for-each assert-node-can-export nodes names sockets))))
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -673,6 +753,13 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
                    (else
                     (leave (_ "invalid request line: ~s~%") line)))
              (loop (read-line)))))))
+    (("test" rest ...)
+     (with-error-handling
+       (let ((file (match rest
+                     ((file) file)
+                     (()     %machine-file)
+                     (_      (leave (_ "wrong number of arguments~%"))))))
+         (check-machine-availability (or file %machine-file)))))
     (("--version")
      (show-version-and-exit "guix offload"))
     (("--help")