From 000664f467ad6aa734965ab72a739b641198c5de Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sat, 25 Apr 2020 15:06:38 +0100
Subject: Add options suited for providing substitutes

Allow specifying build priority, although the allocator currently doesn't use
this. Add --defer-allocation to allow inserting lots of builds without
spending time re-computing the allocation for each one. Add
--ensure-all-related-derivations-have-builds to make it easy to have a
derivation, and all related derivations built at least once. Add
--ignore-if-build-for-derivation-exists to make it easy to avoid building
derivations again if that isn't the intention.
---
 scripts/guix-build-coordinator.in | 58 +++++++++++++++++++++++++++++++++++----
 1 file changed, 52 insertions(+), 6 deletions(-)

(limited to 'scripts')

diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 50dda71..9d73ccc 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -64,6 +64,31 @@
           ("" #f)
           (_ #t)))))
 
+(define %build-options
+  (list (option '("priority") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'priority
+                              (string->number arg)
+                              result)))
+        (option '("ignore-if-build-for-derivation-exists") #f #f
+                (lambda (opt name _ result)
+                  (alist-cons 'ignore-if-build-for-derivation-exists #t result)))
+        (option '("ensure-all-related-derivations-have-builds") #f #f
+                (lambda (opt name _ result)
+                  (alist-cons 'ensure-all-related-derivations-have-builds
+                              #t
+                              result)))
+        (option '("defer-allocation") #f #f
+                (lambda (opt name _ result)
+                  (alist-cons 'defer-allocation #t result)))))
+
+
+(define %build-option-defaults
+  `((priority                                   . 0)
+    (ignore-if-build-for-derivation-exists      . #f)
+    (ensure-all-related-derivations-have-builds . #f)
+    (defer-allocation                           . #f)))
+
 (define %service-options
   (list (option '("pid-file") #t #f
                 (lambda (opt name arg result)
@@ -135,16 +160,37 @@
 
 (match (cdr (program-arguments))
   (("build" rest ...)
-   (let ((opts (parse-options %base-options %base-option-defaults rest)))
+   (let ((opts (parse-options (append %build-options
+                                      %base-options)
+                              (append %build-option-defaults
+                                      %base-option-defaults)
+                              rest)))
 
      (match (assq-ref opts 'arguments)
        ((derivation-file)
+        (let ((datastore
+               (database-uri->datastore
+                (assq-ref opts 'database))))
+
+          (when (assq-ref opts 'ignore-if-build-for-derivation-exists)
+            (let ((builds-for-derivation
+                   (datastore-list-builds-for-derivation datastore
+                                                         derivation-file)))
+              (unless (null? builds-for-derivation)
+                (simple-format #t "there are already ~A builds for ~A, skipping\n"
+                               (length builds-for-derivation)
+                               derivation-file)
+                (exit 0))))
 
-        (let ((uuid (submit-build
-                     (database-uri->datastore
-                      (assq-ref opts 'database))
-                     derivation-file)))
-          (simple-format #t "build submitted as ~A\n" uuid))))))
+          (let ((uuid (submit-build
+                       datastore
+                       derivation-file
+                       #:priority (assq-ref opts 'priority)
+                       #:defer-allocation? (assq-ref opts 'defer-allocation)
+                       #:ensure-all-related-derivations-have-builds?
+                       (assq-ref
+                        opts 'ensure-all-related-derivations-have-builds))))
+            (simple-format #t "build submitted as ~A\n" uuid)))))))
   (("agent" "new" rest ...)
    (let ((opts (parse-options (append %agent-options
                                       %base-options)
-- 
cgit v1.2.3