Switch the build-allocator thread to not use a channel

The put-message operation blocks, which doesn't work for triggering the
allocation process.

2 files changed, 19 insertions, 14 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index f1aac7d..b2bc9a5 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -72,15 +72,13 @@ if there was no request body."
 
 (define (http-agent-messaging-start-server port host secret-key-base
                                            datastore hooks)
-  (define build-allocator-channel
-    (make-build-allocator-channel datastore))
+  (define trigger-build-allocation
+    (make-build-allocator-thread datastore))
 
   (define hook-channel
     (make-hook-channel datastore hooks))
 
-  (define (trigger-build-allocation)
-    (put-message build-allocator-channel #t))
-
+  (trigger-build-allocation)
   (call-with-error-handling
    (lambda ()
      (run-server
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index c0e7cb1..90801f9 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -34,7 +34,7 @@
             new-agent-password
             fetch-builds
             agent-details
-            make-build-allocator-channel
+            make-build-allocator-thread
             make-hook-channel
 
             build-output-file-location
@@ -91,15 +91,22 @@
    (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)))))
+(define (make-build-allocator-thread datastore)
+  (define mtx (make-mutex))
+  (define v (make-condition-variable))
+
+  (define (trigger-build-allocation)
+    (signal-condition-variable v))
+
+  (call-with-new-thread
+   (lambda ()
+     (while #t
+       (with-mutex mtx
+         (wait-condition-variable v mtx)
+         (allocate-builds datastore)))))
+
+  trigger-build-allocation)
 
-    channel))
 
 (define (make-hook-channel datastore hooks)
   (let ((channel (make-channel)))