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.

11 files changed, 103 insertions, 21 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))))
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 7bb0593..da63025 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -26,6 +26,7 @@
 (setvbuf (current-error-port) 'line)
 
 (use-modules (srfi srfi-1)
+             (srfi srfi-19)
              (srfi srfi-37)
              (ice-9 match)
              (web uri)
@@ -116,7 +117,12 @@
                                       ((key value) (cons key value)))
                                     (or (assq-ref result 'tags)
                                         '()))
-                              (alist-delete 'tags result))))))
+                              (alist-delete 'tags result))))
+        (option '("defer-until") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'defer-until
+                              (string->date arg "~Y-~m-~d ~H:~M:~S")
+                              result)))))
 
 (define %build-option-defaults
   `((priority                                          . 0)
@@ -508,7 +514,8 @@ tags:
                 (assq-ref opts 'ignore-if-build-for-outputs-exists)
                 (assq-ref opts
                           'ensure-all-related-derivation-outputs-have-builds)
-                (assq-ref opts 'tags))))
+                (assq-ref opts 'tags)
+                #:defer-until (assq-ref opts 'defer-until))))
           (let ((no-build-submitted-response
                  (assoc-ref response "no-build-submitted")))
             (if no-build-submitted-response
diff --git a/sqitch/pg/deploy/add_builds_deferred_until.sql b/sqitch/pg/deploy/add_builds_deferred_until.sql
new file mode 100644
index 0000000..aa318e0
--- /dev/null
+++ b/sqitch/pg/deploy/add_builds_deferred_until.sql
@@ -0,0 +1,7 @@
+-- Deploy guix-build-coordinator:add_builds_deferred_until to pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/pg/revert/add_builds_deferred_until.sql b/sqitch/pg/revert/add_builds_deferred_until.sql
new file mode 100644
index 0000000..a7b4af3
--- /dev/null
+++ b/sqitch/pg/revert/add_builds_deferred_until.sql
@@ -0,0 +1,7 @@
+-- Revert guix-build-coordinator:add_builds_deferred_until from pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/pg/verify/add_builds_deferred_until.sql b/sqitch/pg/verify/add_builds_deferred_until.sql
new file mode 100644
index 0000000..b6cce04
--- /dev/null
+++ b/sqitch/pg/verify/add_builds_deferred_until.sql
@@ -0,0 +1,7 @@
+-- Verify guix-build-coordinator:add_builds_deferred_until on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;
diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan
index 42ef7ad..2240cc1 100644
--- a/sqitch/sqitch.plan
+++ b/sqitch/sqitch.plan
@@ -24,3 +24,4 @@ add_fixed_output_to_derivations 2020-07-18T14:49:51Z Christopher Baines <mail@cb
 add_unbuilt_outputs_table 2020-11-06T18:58:08Z Christopher Baines <mail@cbaines.net> # Add unbuilt_outputs
 support_build_cancelation 2020-12-11T18:25:42Z Christopher Baines <mail@cbaines.net> # Add builds.canceled
 add_build_tags_build_id_idx 2020-12-21T13:20:54Z Christopher Baines <mail@cbaines.net> # Add an index on build_tags.build_id
+add_builds_deferred_until 2020-12-26T19:26:32Z Christopher Baines <mail@cbaines.net> # Add builds.deferred_until
diff --git a/sqitch/sqlite/deploy/add_builds_deferred_until.sql b/sqitch/sqlite/deploy/add_builds_deferred_until.sql
new file mode 100644
index 0000000..db57b53
--- /dev/null
+++ b/sqitch/sqlite/deploy/add_builds_deferred_until.sql
@@ -0,0 +1,7 @@
+-- Deploy guix-build-coordinator:add_builds_deferred_until to sqlite
+
+BEGIN;
+
+ALTER TABLE builds ADD COLUMN deferred_until TEXT;
+
+COMMIT;
diff --git a/sqitch/sqlite/revert/add_builds_deferred_until.sql b/sqitch/sqlite/revert/add_builds_deferred_until.sql
new file mode 100644
index 0000000..ef41b03
--- /dev/null
+++ b/sqitch/sqlite/revert/add_builds_deferred_until.sql
@@ -0,0 +1,7 @@
+-- Revert guix-build-coordinator:add_builds_deferred_until from sqlite
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/sqlite/verify/add_builds_deferred_until.sql b/sqitch/sqlite/verify/add_builds_deferred_until.sql
new file mode 100644
index 0000000..7e367da
--- /dev/null
+++ b/sqitch/sqlite/verify/add_builds_deferred_until.sql
@@ -0,0 +1,7 @@
+-- Verify guix-build-coordinator:add_builds_deferred_until on sqlite
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;