Handle the system more explicitly when fetching builds

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

6 files changed, 106 insertions, 31 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index e7c17aa..f7459ad 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -292,7 +292,10 @@ port. Also, the port used can be changed by passing the --port option.\n"
        (if (authenticated? uuid request)
            (let* ((json-body (json-string->scm (utf8->string body)))
                   (count (assoc-ref json-body "count"))
-                  (builds (fetch-builds build-coordinator uuid count)))
+                  (systems (assoc-ref json-body "systems"))
+                  (builds (fetch-builds build-coordinator uuid
+                                        (vector->list systems)
+                                        count)))
              (render-json
               `((builds . ,(list->vector builds)))))
            (render-json
@@ -696,11 +699,13 @@ port. Also, the port used can be changed by passing the --port option.\n"
    #:succeed-on-access-denied-retry? #t))
 
 (define* (fetch-builds-for-agent coordinator-uri agent-uuid password
+                                 systems
                                  #:key (count 1))
   (vector->list
    (assoc-ref (coordinator-http-request
                coordinator-uri agent-uuid password
                (string-append "/agent/" agent-uuid "/fetch-builds")
-               #:body `((count . ,count))
+               #:body `((count               . ,count)
+                        (systems . ,(list->vector systems)))
                #:method 'POST)
               "builds")))
diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index 06518ed..a5a3f7a 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -36,12 +36,14 @@
   #:export (run-agent))
 
 (define (run-agent uuid coordinator-uri password
+                   systems
                    max-parallel-builds
                    derivation-substitute-urls
                    non-derivation-substitute-urls)
   (define (fetch-new-jobs count)
     (let ((received-builds
            (fetch-builds-for-agent coordinator-uri uuid password
+                                   systems
                                    #:count count)))
       (simple-format #t "requested ~A builds, received ~A\n"
                      count (length received-builds))
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 83f1e68..f76c783 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -321,7 +321,7 @@
 
   #t)
 
-(define (fetch-builds build-coordinator agent count)
+(define (fetch-builds build-coordinator agent systems count)
   (call-with-duration-metric
    (build-coordinator-metrics-registry build-coordinator)
    "guixbuildcoordinator_coordinator_fetch_builds_duration_seconds"
@@ -329,6 +329,7 @@
      (datastore-allocate-builds-to-agent
       (build-coordinator-datastore build-coordinator)
       agent
+      systems
       count))))
 
 (define (agent-details datastore agent-id)
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 2b39c51..0497bab 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -1286,20 +1286,24 @@ SELECT agent_id, COUNT(*) FROM allocated_builds GROUP BY agent_id")))
 (define-method (datastore-allocate-builds-to-agent
                 (datastore <sqlite-datastore>)
                 agent-id
+                systems
                 count)
   (define (fetch-build db)
     (let ((statement
            (sqlite-prepare
             db
             ;; This needs to guard against the plan being out of date
-            "
+            (simple-format #f "
 SELECT builds.uuid, builds.derivation_name
 FROM builds
 INNER JOIN build_allocation_plan
   ON builds.uuid = build_allocation_plan.build_id
+INNER JOIN derivations
+  ON builds.derivation_name = derivations.name
 WHERE build_allocation_plan.agent_id = :agent_id
   AND builds.processed = 0
   AND builds.uuid NOT IN (SELECT build_id FROM allocated_builds)
+  AND derivations.system IN (~A)
   AND NOT EXISTS (
     SELECT 1
     FROM derivation_outputs AS build_derivation_outputs
@@ -1315,8 +1319,12 @@ WHERE build_allocation_plan.agent_id = :agent_id
           allocated_builds_derivation_outputs.output
   )
 ORDER BY build_allocation_plan.ordering ASC
-LIMIT 1")))
-
+LIMIT 1"
+                           (string-join
+                            (map (lambda (system)
+                                   (string-append "'" system "'"))
+                                 systems)
+                            ",")))))
       (sqlite-bind-arguments
        statement
        #:agent_id agent-id)
diff --git a/scripts/guix-build-coordinator-agent.in b/scripts/guix-build-coordinator-agent.in
index 5c8549e..730d90f 100644
--- a/scripts/guix-build-coordinator-agent.in
+++ b/scripts/guix-build-coordinator-agent.in
@@ -24,6 +24,7 @@
 
 (use-modules (srfi srfi-1)
              (srfi srfi-37)
+             ((guix config) #:prefix guix-config:)
              (guix-build-coordinator agent))
 
 (define %options
@@ -62,12 +63,19 @@
                 (lambda (opt name arg result)
                   (alist-cons 'non-derivation-substitute-urls
                               (string-split arg #\space)
-                              result)))))
+                              result)))
+        (option '("system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'systems
+                              (cons arg
+                                    (or (assq-ref result 'system-and-target)
+                                        '()))
+                              (alist-delete 'systems result))))))
 
 (define %option-defaults
-  ;; Alist of default option values
   `((coordinator         . "http://localhost:8745")
-    (max-parallel-builds . 1)))
+    (max-parallel-builds . 1)
+    (systems             . (,guix-config:%system))))
 
 (define (parse-options options defaults args)
   (args-fold
@@ -87,6 +95,7 @@
   (run-agent (assq-ref opts 'uuid)
              (assq-ref opts 'coordinator)
              (assq-ref opts 'password)
+             (assq-ref opts 'systems)
              (assq-ref opts 'max-parallel-builds)
              (or (assq-ref opts 'derivation-substitute-urls)
                  (assq-ref opts 'substitute-urls))
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)