Improve build allocation

Move some of the code around, and trigger allocating builds via a thread if an
agent fails to setup for a build and when a build succeeds/fails.

This is important, as some setup failures can be handled by the build
allocator, for example a build finishing may unblock other builds waiting for
outputs it generates.

3 files changed, 97 insertions, 40 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 0837aaa..23c119c 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -33,6 +33,7 @@
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (web uri)
+  #:use-module (fibers channels)
   #:use-module (guix lzlib)
   #:use-module (guix base64)
   #:use-module (guix serialization)
@@ -71,6 +72,12 @@ if there was no request body."
 
 (define (http-agent-messaging-start-server port host secret-key-base
                                            datastore)
+  (define build-allocator-channel
+    (make-build-allocator-channel datastore))
+
+  (define (trigger-build-allocation)
+    (put-message build-allocator-channel #t))
+
   (call-with-error-handling
    (lambda ()
      (run-server
@@ -86,7 +93,8 @@ if there was no request body."
                                   (uri-path (request-uri request))))
                            body
                            secret-key-base
-                           datastore)))
+                           datastore
+                           trigger-build-allocation)))
       'http
       (list #:host host
             #:port port)))
@@ -122,7 +130,8 @@ port. Also, the port used can be changed by passing the --port option.\n"
                     method-and-path-components
                     body
                     secret-key-base
-                    datastore)
+                    datastore
+                    trigger-build-allocation)
   (define (authenticated? uuid request)
     (let* ((authorization-base64
             (match (assq-ref (request-headers request)
@@ -176,6 +185,9 @@ port. Also, the port used can be changed by passing the --port option.\n"
              (begin
                (handle-build-result datastore agent-id-for-build uuid
                                     (json-string->scm (utf8->string body)))
+               ;; Trigger build allocation, as the result of this build could
+               ;; change the allocation
+               (trigger-build-allocation)
                (render-json
                 "message received"))
              (render-json
@@ -189,6 +201,9 @@ port. Also, the port used can be changed by passing the --port option.\n"
                (handle-setup-failure-report
                 datastore agent-id-for-build uuid
                 (json-string->scm (utf8->string body)))
+               ;; Trigger build allocation, so that the allocator can handle
+               ;; this setup failure
+               (trigger-build-allocation)
                (render-json
                 "message received"))
              (render-json
diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
new file mode 100644
index 0000000..1ba1ead
--- /dev/null
+++ b/guix-build-coordinator/build-allocator.scm
@@ -0,0 +1,63 @@
+;;; Guix Build Coordinator
+;;;
+;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of the guix-build-coordinator.
+;;;
+;;; The Guix Build Coordinator is free software; you can redistribute
+;;; it and/or modify it under the terms of the GNU General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; The Guix Build Coordinator is distributed in the hope that it will
+;;; be useful, but WITHOUT ANY WARRANTY; without even the implied
+;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+;;; See the GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with the guix-data-service.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-build-coordinator build-allocator)
+  #:use-module (srfi srfi-1)
+  #:use-module (guix-build-coordinator datastore)
+  #:use-module (guix-build-coordinator coordinator)
+  #:export (basic-build-allocation-strategy))
+
+(define (basic-build-allocation-strategy datastore)
+  (let ((agents (datastore-list-agents datastore))
+        (builds (datastore-list-unprocessed-builds datastore))
+        (setup-failures
+         (datastore-fetch-setup-failures datastore)))
+
+    (define (filter-builds-for-agent agent-id)
+      (lambda (build)
+        (let* ((build-id (assq-ref build 'uuid))
+               (setup-failures-for-build
+                (or (assoc-ref setup-failures build-id)
+                    '())))
+          (if (any (lambda (setup-failure)
+                     (string=? (assq-ref setup-failure 'agent-id)
+                               agent-id))
+                   setup-failures-for-build)
+              ;; Don't allocated builds to agents where the setup has failed
+              ;; in the past
+              #f
+              #t))))
+
+    (append-map
+     (lambda (agent-id)
+       (let ((builds-for-agent
+              (filter (filter-builds-for-agent agent-id)
+                      builds)))
+         (map (lambda (build-id ordering)
+                (list build-id
+                      agent-id
+                      ordering))
+              (map (lambda (build)
+                     (assq-ref build 'uuid))
+                   builds-for-agent)
+              (iota (length builds-for-agent)))))
+     (map (lambda (agent)
+            (assq-ref agent 'uuid))
+          agents))))
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 82f983c..ece04a3 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -21,16 +21,20 @@
 (define-module (guix-build-coordinator coordinator)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 threads)
   #:use-module (gcrypt random)
+  #:use-module (fibers channels)
   #:use-module (guix derivations)
   #:use-module (guix-build-coordinator utils)
   #:use-module (guix-build-coordinator config)
   #:use-module (guix-build-coordinator datastore)
+  #:use-module (guix-build-coordinator build-allocator)
   #:export (submit-build
             new-agent
             new-agent-password
             fetch-builds
             agent-details
+            make-build-allocator-channel
 
             build-output-file-location
             handle-build-result
@@ -81,46 +85,21 @@
     password))
 
 (define (allocate-builds datastore)
-  (let ((agents (datastore-list-agents datastore))
-        (builds (datastore-list-unprocessed-builds datastore))
-        (setup-failures
-         (datastore-fetch-setup-failures datastore)))
-
-    (define (filter-builds-for-agent agent-id)
-      (lambda (build)
-        (let* ((build-id (assq-ref build 'uuid))
-               (setup-failures-for-build
-                (or (assoc-ref setup-failures build-id)
-                    '())))
-          (if (any (lambda (setup-failure)
-                     (string=? (assq-ref setup-failure 'agent-id)
-                               agent-id))
-                   setup-failures-for-build)
-              ;; Don't allocated builds to agents where the setup has failed
-              ;; in the past
-              #f
-              #t))))
-
-    (datastore-replace-build-allocation-plan
-     datastore
-     (append-map
-      (lambda (agent-id)
-        (let ((builds-for-agent
-               (filter (filter-builds-for-agent agent-id)
-                       builds)))
-          (map (lambda (build-id ordering)
-                 (list build-id
-                       agent-id
-                       ordering))
-               (map (lambda (build)
-                      (assq-ref build 'uuid))
-                    builds-for-agent)
-               (iota (length builds-for-agent)))))
-      (map (lambda (agent)
-             (assq-ref agent 'uuid))
-           agents))))
+  (datastore-replace-build-allocation-plan
+   datastore
+   (basic-build-allocation-strategy datastore))
   #t)
 
+(define (make-build-allocator-channel datastore)
+  (let ((channel (make-channel)))
+    (call-with-new-thread
+     (lambda ()
+       (let loop ((message (get-message channel)))
+         (allocate-builds datastore)
+         (loop (get-message channel)))))
+
+    channel))
+
 (define (fetch-builds datastore agent)
   (let ((builds (datastore-list-allocation-plan-builds
                  datastore