Handle the system more explicitly when fetching builds

Also support fetching builds for specific systems from the Guix Data Service.

1 files changed, 72 insertions, 22 deletions

diff --git a/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in b/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in
index 0690244..664c442 100644
--- a/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in
+++ b/scripts/guix-build-coordinator-queue-builds-from-guix-data-service.in
@@ -24,6 +24,7 @@
 
 (use-modules (srfi srfi-1)
              (srfi srfi-11)
+             (srfi srfi-37)
              (ice-9 match)
              (ice-9 textual-ports)
              (rnrs bytevectors)
@@ -155,30 +156,79 @@
    #:times 6
    #:delay 30))
 
-(define (submit-builds-for-revision commit)
+(define (submit-builds-for-revision commit systems-and-targets)
   (simple-format #t "looking at revision ~A\n" commit)
-  (for-each (lambda (derivation)
-              (submit-build derivation #:priority 1000))
-            (channel-instance-derivations-for-commit commit "x86_64-linux"))
-
-  (let ((unprocessed-package-derivations
-         (filter (lambda (derivation)
-                   (not (hash-ref processed-derivations-hash derivation)))
-                 (package-derivations-for-commit commit
-                                                 #:system "x86_64-linux"
-                                                 #:target "none"))))
-
-    (for-each submit-build unprocessed-package-derivations)
-    (record-derivations-as-processed unprocessed-package-derivations)))
+  (for-each
+   (match-lambda
+     ((system . target)
+      (for-each (lambda (derivation)
+                  (submit-build derivation #:priority 1000))
+                (channel-instance-derivations-for-commit commit system))
+
+      (let ((unprocessed-package-derivations
+             (filter (lambda (derivation)
+                       (not (hash-ref processed-derivations-hash derivation)))
+                     (package-derivations-for-commit commit
+                                                     #:system system
+                                                     #:target target))))
+
+        (for-each submit-build unprocessed-package-derivations)
+        (record-derivations-as-processed unprocessed-package-derivations))))
+   systems-and-targets))
+
+(define %options
+  (list (option '("system") #t #f
+                (lambda (opt name arg result)
+                  (peek "ARG" arg)
+                  (alist-cons 'systems-and-targets
+                              `((,arg . "none")
+                                ,@(or (assq-ref result 'systems-and-targets) '()))
+                              (alist-delete 'systems-and-targets result))))
+        (option '("system-and-target") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'systems-and-targets
+                              (match (string-split arg #\=)
+                                ((system target)
+                                 `((,system . ,target)
+                                   ,@(or (assq-ref result 'systems-and-targets) '()))))
+                              (alist-delete 'systems-and-targets result))))))
+
+(define %option-defaults
+  '())
+
+(define (parse-options options defaults args)
+  (args-fold
+   args options
+   (lambda (opt name arg result)
+     (error "unrecognized option" name))
+   (lambda (arg result)
+     (alist-cons
+      'arguments
+      (cons arg
+            (or (assoc-ref result 'arguments)
+                '()))
+      (alist-delete 'arguments result)))
+   defaults))
 
 (define (main)
-  (while #t
-    (for-each (lambda (commit)
-                (submit-builds-for-revision commit)
-                (record-revision-as-processed commit))
-              (unseen-revisions))
-
-    (simple-format #t "waiting before checking for new revisions...\n")
-    (sleep 60)))
+  (let* ((opts (parse-options %options
+                              %option-defaults
+                              (cdr (program-arguments))))
+         (systems-and-targets
+          (assq-ref opts 'systems-and-targets)))
+
+    (unless (peek systems-and-targets)
+      (simple-format (current-error-port)
+                     "error: you must specify at least one system to fetch builds for\n")
+      (exit 1))
+
+    (while #t
+      (for-each (lambda (commit)
+                  (submit-builds-for-revision commit systems-and-targets)
+                  (record-revision-as-processed commit))
+                (unseen-revisions))
+
+      (simple-format #t "waiting before checking for new revisions...\n")
+      (sleep 60))))
 
 (main)