offload: Decompose 'machine-load' into simpler procedures.

* guix/scripts/offload.scm (machine-load): Remove.
(node-load, normalized-load): New procedures.
(choose-build-machine): Call 'open-ssh-session' and 'make-node' from
here; pass the node to 'node-load'.
(check-machine-status): Use 'node-load' instead of 'machine-load'.  Call
'disconnect!' on SESSION.

guix/scripts/offload.scm

@@ -392,33 +392,31 @@ MACHINE."
                (build-requirements-features requirements)
                (build-machine-features machine))))
 
-(define (machine-load machine)
+(define (node-load node)
-  "Return the load of MACHINE, divided by the number of parallel builds
+  "Return the load on NODE.  Return +∞ if NODE is misbehaving."
-allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
+  (let ((line (node-eval node
-  ;; Note: This procedure is costly since it creates a new SSH session.
+                         '(begin
-  (match (false-if-exception (open-ssh-session machine))
+                            (use-modules (ice-9 rdelim))
-    ((? session? session)
+                            (call-with-input-file "/proc/loadavg"
-     (let* ((pipe (open-remote-pipe* session OPEN_READ
+                              read-string)))))
-                                     "cat" "/proc/loadavg"))
-            (line (read-line pipe)))
-       (close-port pipe)
-       (disconnect! session)
-
     (if (eof-object? line)
         +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
         (match (string-tokenize line)
           ((one five fifteen . x)
-              (let* ((raw        (string->number one))
+           (string->number one))
-                     (jobs       (build-machine-parallel-builds machine))
+          (x
-                     (normalized (/ raw jobs)))
+           +inf.0)))))
+
+(define (normalized-load machine load)
+  "Divide LOAD by the number of parallel builds of MACHINE."
+  (if (rational? load)
+      (let* ((jobs       (build-machine-parallel-builds machine))
+             (normalized (/ load jobs)))
         (format (current-error-port) "load on machine '~a' is ~s\
  (normalized: ~s)~%"
-                        (build-machine-name machine) raw normalized)
+                (build-machine-name machine) load normalized)
-                normalized))
+        normalized)
-             (x
+      load))
-              +inf.0)))))        ;something's fishy about MACHINE, so avoid it
-    (x
-     +inf.0)))                      ;failed to connect to MACHINE, so avoid it
 
 (define (machine-lock-file machine hint)
   "Return the name of MACHINE's lock file for HINT."
@@ -484,9 +482,13 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
       (match machines+slots
         (((best slot) others ...)
          ;; Return the best machine unless it's already overloaded.
-         ;; Note: We call 'machine-load' only as a last resort because it is
+         ;; Note: We call 'node-load' only as a last resort because it is
          ;; too costly to call it once for every machine.
-         (if (< (machine-load best) 2.)
+         (let* ((session (false-if-exception (open-ssh-session best)))
+                (node    (and session (make-node session)))
+                (load    (and node (normalized-load best (node-load node)))))
+           (when session (disconnect! session))
+           (if (and node (< load 2.))
                (match others
                  (((machines slots) ...)
                   ;; Release slots from the uninteresting machines.
@@ -498,7 +500,7 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
                (begin
                  ;; BEST is overloaded, so try the next one.
                  (release-build-slot slot)
-               (loop others))))
+                 (loop others)))))
         (()
          (values #f #f))))))
 
@@ -689,16 +691,18 @@ 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)))
+                (let* ((session (open-ssh-session machine))
-                       (uts (node-eval node '(uname))))
+                       (node    (make-node session))
+                       (uts     (node-eval node '(uname)))
+                       (load    (node-load node)))
+                  (disconnect! session)
                   (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+")))
+                          load)))
-                                        (machine-load machine)))))
               machines)))