offload: Allow testing machines that match a regexp.

* guix/scripts/offload.scm (check-machine-availability): Add 'pred'
parameter and honor it.
(guix-offload): for the "test" sub-command, accept an extra 'regexp'
parameter.  Pass a second argument to 'check-machine-availability'.

1 files changed, 16 insertions, 9 deletions

diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index f56220ff69..c98cf8c534 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -708,16 +708,18 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
           (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."
+(define (check-machine-availability machine-file pred)
+  "Check that each machine matching PRED in MACHINE-FILE is usable as a build
+machine."
   (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 (delete-duplicates (build-machines machine-file)
-                                     build-machine=?)))
+  (let ((machines (filter pred
+                          (delete-duplicates (build-machines machine-file)
+                                             build-machine=?))))
     (info (_ "testing ~a build machines defined in '~a'...~%")
           (length machines) machine-file)
     (let* ((names    (map build-machine-name machines))
@@ -781,11 +783,16 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
              (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)))))
+       (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)))
+                       (_      (leave (_ "wrong number of arguments~%"))))))
+         (check-machine-availability (or file %machine-file) pred))))
     (("--version")
      (show-version-and-exit "guix offload"))
     (("--help")