From aebaee95cc26d404a8d7b62aece77dfbddb75836 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 5 Dec 2016 18:16:04 +0100
Subject: 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'.
---
 guix/scripts/offload.scm | 87 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 87 insertions(+)

(limited to 'guix/scripts')

diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 237a9638d3..4d697f7d00 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -623,6 +623,86 @@ (define* (process-request wants-local? system drv features
              ;; Not now, all the machines are busy.
              (display "# postpone\n")))))))
 
+
+;;;
+;;; 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 @@ (define not-coma
                    (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")
-- 
cgit v1.2.3