Implement deferring builds

This isn't intended as some time based scheduling, but more as a way to slow
down builds by deferring processing them until some point in the future.

I'm intending to use this to test fixed output derivations. I can look up all
the derivations I want to test, then defer the builds to run spread out across
some period. This feature saves having to submit the builds gradually.

3 files changed, 51 insertions, 19 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index ff6f9f5..0a2aef4 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -21,6 +21,7 @@
 (define-module (guix-build-coordinator client-communication)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 exceptions)
@@ -322,6 +323,11 @@
                                (cons (assoc-ref tag "key")
                                      (assoc-ref tag "value")))
                              (vector->list (assoc-ref body "tags"))))
+                         '())
+                   ,@(or (and=> (assoc-ref body "defer-until")
+                                (lambda (date)
+                                  `(#:defer-until
+                                    ,(string->date date "~Y-~m-~d ~H:~M:~S"))))
                          '())))))
            (render-json submit-build-result))))
       (_
@@ -390,16 +396,18 @@
          (json-string->scm (utf8->string body))
          response))))
 
-(define (send-submit-build-request
-         coordinator-uri
-         derivation-file-name
-         substitute-urls
-         requested-uuid
-         priority
-         ignore-if-build-for-derivation-exists?
-         ignore-if-build-for-outputs-exists?
-         ensure-all-related-derivation-outputs-have-builds?
-         tags)
+(define* (send-submit-build-request
+          coordinator-uri
+          derivation-file-name
+          substitute-urls
+          requested-uuid
+          priority
+          ignore-if-build-for-derivation-exists?
+          ignore-if-build-for-outputs-exists?
+          ensure-all-related-derivation-outputs-have-builds?
+          tags
+          #:key
+          defer-until)
   (send-request coordinator-uri
                 'POST
                 "/builds"
@@ -424,7 +432,11 @@
                                            ((key . value)
                                             `((key   . ,key)
                                               (value . ,value))))
-                                         tags))))))))
+                                         tags)))))
+                  ,@(if defer-until
+                        `((defer-until . ,(date->string defer-until "~1 ~3")))
+                        '()))))
+
 
 (define (send-cancel-build-request
          coordinator-uri
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index beb2d84..dfa00ca 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -256,7 +256,8 @@
                        (ignore-if-build-for-derivation-exists? #f)
                        (ignore-if-build-for-outputs-exists? #f)
                        (ensure-all-related-derivation-outputs-have-builds? #f)
-                       (tags '()))
+                       (tags '())
+                       defer-until)
   (define datastore (build-coordinator-datastore build-coordinator))
 
   (define (build-for-derivation-exists?)
@@ -287,7 +288,8 @@
     (datastore-insert-build datastore
                             uuid
                             derivation-name
-                            priority)
+                            priority
+                            defer-until)
     (datastore-insert-unprocessed-hook-event datastore
                                              "build-submitted"
                                              (list uuid))
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 2988de3..fac7bbf 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -1,6 +1,7 @@
 (define-module (guix-build-coordinator datastore sqlite)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (ice-9 threads)
@@ -289,9 +290,11 @@
               (or (metrics-registry-fetch-metric registry metric-name)
                   (make-histogram-metric registry
                                          metric-name)))
-             (start-time (current-time)))
+             (start-time (get-internal-real-time)))
         (let ((result (thunk)))
-          (metric-observe metric (- (current-time) start-time))
+          (metric-observe metric
+                          (/ (- (get-internal-real-time) start-time)
+                             internal-time-units-per-second))
           result))
       (thunk)))
 
@@ -1675,6 +1678,11 @@ SELECT uuid, derivation_name, priority
 FROM builds
 WHERE processed = 0
   AND canceled = 0
+  AND (
+    deferred_until IS NULL
+    OR
+    deferred_until < datetime('now')
+  )
 ORDER BY priority DESC"
              #:cache? #t)))
 
@@ -1708,6 +1716,11 @@ SELECT uuid
 FROM builds
 WHERE processed = 0
   AND canceled = 0
+  AND (
+    deferred_until IS NULL
+    OR
+    deferred_until < datetime('now')
+  )
 "
              (if created-after
                  (simple-format
@@ -2856,7 +2869,8 @@ INSERT INTO derivation_outputs (derivation_name, name, output) VALUES "
 
 (define-method (datastore-insert-build
                 (datastore <sqlite-datastore>)
-                uuid derivation-name priority)
+                uuid derivation-name priority
+                defer-until)
   (call-with-worker-thread
    (slot-ref datastore 'worker-writer-thread-channel)
    (lambda (db)
@@ -2864,15 +2878,19 @@ INSERT INTO derivation_outputs (derivation_name, name, output) VALUES "
             (sqlite-prepare
              db
              "
-INSERT INTO builds (uuid, derivation_name, priority, created_at)
-VALUES (:uuid, :derivation_name, :priority, datetime('now'))"
+INSERT INTO builds (uuid, derivation_name, priority, created_at, deferred_until)
+VALUES (:uuid, :derivation_name, :priority, datetime('now'), :deferred_until)"
              #:cache? #t)))
 
        (sqlite-bind-arguments
         statement
         #:uuid uuid
         #:derivation_name derivation-name
-        #:priority priority)
+        #:priority priority
+        #:deferred_until
+        (and=> defer-until
+               (lambda (date)
+                 (date->string date "~1 ~3"))))
 
        (sqlite-step statement)
        (sqlite-reset statement))))