Trigger build allocations when necessary for deferred builds

3 files changed, 65 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))
 
diff --git a/guix-build-coordinator/datastore.scm b/guix-build-coordinator/datastore.scm
index c977ff0..24b9bbb 100644
--- a/guix-build-coordinator/datastore.scm
+++ b/guix-build-coordinator/datastore.scm
@@ -53,6 +53,7 @@
 (re-export datastore-count-builds-for-derivation)
 (re-export datastore-list-processed-builds)
 (re-export datastore-list-unprocessed-builds)
+(re-export datastore-find-first-unallocated-deferred-build)
 (re-export datastore-fetch-build-ids-and-propagated-priorities-for-unprocessed-builds)
 (re-export datastore-insert-unprocessed-hook-event)
 (re-export datastore-count-unprocessed-hook-events)
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index d7def51..72b91ae 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -67,6 +67,7 @@
             datastore-replace-agent-tags
             datastore-list-processed-builds
             datastore-list-unprocessed-builds
+            datastore-find-first-unallocated-deferred-build
             datastore-fetch-build-ids-and-propagated-priorities-for-unprocessed-builds
             datastore-insert-unprocessed-hook-event
             datastore-count-unprocessed-hook-events
@@ -1869,6 +1870,44 @@ ORDER BY priority DESC"
 
          builds)))))
 
+(define-method (datastore-find-first-unallocated-deferred-build
+                (datastore <sqlite-datastore>))
+  (call-with-worker-thread
+   (slot-ref datastore 'worker-reader-thread-channel)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT uuid, derivation_name, priority, created_at, deferred_until
+FROM builds
+WHERE processed = 0
+  AND canceled = 0
+  AND deferred_until IS NOT NULL
+  AND uuid NOT IN (SELECT build_id FROM build_allocation_plan)
+ORDER BY deferred_until ASC
+LIMIT 1"
+             #:cache? #t)))
+
+       (let ((result
+              (match (sqlite-step statement)
+                (#(uuid derivation_name priority created_at deferred_until)
+                 `((uuid            . ,uuid)
+                   (derivation-name . ,derivation_name)
+                   (priority        . ,priority)
+                   (created-at      . ,(if (string? created_at)
+                                           (string->date created_at
+                                                         "~Y-~m-~d ~H:~M:~S")
+                                           #f))
+                   (deferred-until . ,(if (string? deferred_until)
+                                          (string->date deferred_until
+                                                        "~Y-~m-~d ~H:~M:~S")
+                                          #f))))
+                (#f #f))))
+         (sqlite-reset statement)
+
+         result)))))
+
 (define-method (datastore-fetch-build-ids-and-propagated-priorities-for-unprocessed-builds
                 (datastore <sqlite-datastore>)
                 created-after)