Trigger build allocations when necessary for deferred builds

1 files changed, 25 insertions, 0 deletions

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 06b5a40..b345498 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -226,6 +226,8 @@
             (datastore-spawn-fibers
              (build-coordinator-datastore build-coordinator))
 
+            (spawn-fiber-to-watch-for-deferred-builds build-coordinator)
+
             ;; Start the agent messaging server
             (match (uri-scheme agent-communication-uri)
               ('http
@@ -496,6 +498,29 @@
 
   trigger-build-allocation)
 
+(define (spawn-fiber-to-watch-for-deferred-builds coordinator)
+  (spawn-fiber
+   (lambda ()
+     (while #t
+       (sleep 60)                       ; 1 minute
+       (with-exception-handler
+           (lambda (exn)
+             (simple-format (current-error-port)
+                            "exception when watching for deferred builds: ~A\n"
+                            exn))
+         (lambda ()
+           (let ((first-deferred-build
+                  (datastore-find-first-unallocated-deferred-build
+                   (build-coordinator-datastore coordinator))))
+             (when (and first-deferred-build
+                        (time<=? (date->time-utc
+                                  (assq-ref first-deferred-build 'deferred-until))
+                                 (current-time)))
+               (simple-format #t "guix-build-coordinator: triggering build allocation for deferred build: ~A\n" (assq-ref first-deferred-build 'uuid))
+               (trigger-build-allocation coordinator))))
+         #:unwind? #t)))
+   #:parallel? #t))
+
 (define (start-hook-processing-threads build-coordinator)
   (define wait-timeout-seconds (* 60 5))