01/01: guix: offload: Add "status" sub-command.

[Ricardo Wurmus]

rekado pushed a commit to branch master
in repository guix.

commit dafc3dafeada11e4df043bf751a611b1ac8fc22a
Author: Ricardo Wurmus <address@hidden>
Date:   Wed Dec 13 23:42:40 2017 +0100

    guix: offload: Add "status" sub-command.
    
    * guix/scripts/offload.scm (check-machine-status): New procedure.
    (guix-offload): Call it when the argument is "status".
    * doc/guix.texi (Daemon Offload Setup): Document it.
---
 doc/guix.texi            |  9 +++++++++
 guix/scripts/offload.scm | 39 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 48 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 64f73b3..cb6e6b1 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -1066,6 +1066,15 @@ regular expression like this:
 # guix offload test machines.scm '\.gnu\.org$'
 @end example
 
address@hidden offload status
+To display the current load of all build hosts, run this command on the
+main node:
+
address@hidden
+# guix offload status
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 ebd0bf7..7e114fa 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2017 Ricardo Wurmus <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -629,6 +630,32 @@ machine."
       (for-each assert-node-can-import nodes names sockets)
       (for-each assert-node-can-export nodes names sockets))))
 
+(define (check-machine-status machine-file pred)
+  "Print the load of each machine matching PRED in MACHINE-FILE."
+  (define (build-machine=? m1 m2)
+    (and (string=? (build-machine-name m1) (build-machine-name m2))
+         (= (build-machine-port m1) (build-machine-port m2))))
+
+  ;; A given build machine may appear several times (e.g., once for
+  ;; "x86_64-linux" and a second time for "i686-linux"); test them only once.
+  (let ((machines (filter pred
+                          (delete-duplicates (build-machines machine-file)
+                                             build-machine=?))))
+    (info (G_ "getting status of ~a build machines defined in '~a'...~%")
+          (length machines) machine-file)
+    (for-each (lambda (machine)
+                (let* ((node (make-node (open-ssh-session machine)))
+                       (uts (node-eval node '(uname))))
+                  (format #t "~a~%  kernel: ~a ~a~%  architecture: ~a~%\
+  host name: ~a~%  normalized load: ~a~%"
+                          (build-machine-name machine)
+                          (utsname:sysname uts) (utsname:release uts)
+                          (utsname:machine uts)
+                          (utsname:nodename uts)
+                          (parameterize ((current-error-port (%make-void-port 
"rw+")))
+                                        (machine-load machine)))))
+              machines)))
+
 
 ;;;
 ;;; Entry point.
@@ -691,6 +718,18 @@ machine."
                        (()     (values %machine-file (const #t)))
                        (x      (leave (G_ "wrong number of arguments~%"))))))
          (check-machine-availability (or file %machine-file) pred))))
+    (("status" rest ...)
+     (with-error-handling
+       (let-values (((file pred)
+                     (match rest
+                       ((file regexp)
+                        (values file
+                                (compose (cut string-match regexp <>)
+                                         build-machine-name)))
+                       ((file) (values file (const #t)))
+                       (()     (values %machine-file (const #t)))
+                       (x      (leave (G_ "wrong number of arguments~%"))))))
+         (check-machine-status (or file %machine-file) pred))))
     (("--version")
      (show-version-and-exit "guix offload"))
     (("--help")