From c72d2a172fafa591da3b73274ed70723d5fbf360 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Wed, 17 Feb 2021 09:12:50 +0000
Subject: Add a hook for determining whether agents should submit outputs

This should make it possible to check properly whether the outputs are needed,
instead of just assuming they are not if there's been a successful build.
---
 scripts/guix-build-coordinator.in | 101 +++++++++++++++-----------------------
 1 file changed, 40 insertions(+), 61 deletions(-)

(limited to 'scripts/guix-build-coordinator.in')

diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index e6ebc01..3992c6f 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -280,67 +280,46 @@
     (remove-tags  . ())))
 
 (define %service-options
-  (list (option '("pid-file") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'pid-file
-                              arg
-                              result)))
-        (option '("agent-communication") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'agent-communication
-                              (string->uri arg)
-                              (alist-delete 'agent-communication result))))
-        (option '("client-communication") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'client-communication
-                              (string->uri arg)
-                              (alist-delete 'client-communication result))))
-        (option '("allocation-strategy") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons
-                   'allocation-strategy
-                   (or (assoc-ref
-                        `(("basic" . ,basic-build-allocation-strategy)
-                          ("derivation-ordered"
-                           . ,derivation-ordered-build-allocation-strategy))
-                        arg)
-                       (begin
-                         (simple-format
-                          (current-error-port)
-                          "error: ~A is not a known allocation strategy\n"
-                          arg)
-                         (exit 1)))
-                   result)))
-        (option '("build-submitted-hook") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'build-submitted-hook
-                              (read/eval arg)
-                              (alist-delete 'build-submitted-hook result))))
-        (option '("build-canceled-hook") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'build-canceled-hook
-                              (read/eval arg)
-                              (alist-delete 'build-canceled-hook result))))
-        (option '("build-started-hook") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'build-started-hook
-                              (read/eval arg)
-                              (alist-delete 'build-started-hook result))))
-        (option '("build-success-hook") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'build-success-hook
-                              (read/eval arg)
-                              (alist-delete 'build-success-hook result))))
-        (option '("build-failure-hook") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'build-failure-hook
-                              (read/eval arg)
-                              (alist-delete 'build-failure-hook result))))
-        (option '("build-missing-inputs-hook") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'build-missing-inputs-hook
-                              (read/eval arg)
-                              (alist-delete 'build-missing-inputs-hook result))))))
+  (append
+   (list (option '("pid-file") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'pid-file
+                               arg
+                               result)))
+         (option '("agent-communication") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'agent-communication
+                               (string->uri arg)
+                               (alist-delete 'agent-communication result))))
+         (option '("client-communication") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'client-communication
+                               (string->uri arg)
+                               (alist-delete 'client-communication result))))
+         (option '("allocation-strategy") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons
+                    'allocation-strategy
+                    (or (assoc-ref
+                         `(("basic" . ,basic-build-allocation-strategy)
+                           ("derivation-ordered"
+                            . ,derivation-ordered-build-allocation-strategy))
+                         arg)
+                        (begin
+                          (simple-format
+                           (current-error-port)
+                           "error: ~A is not a known allocation strategy\n"
+                           arg)
+                          (exit 1)))
+                    result))))
+   (map (lambda (hook)
+          (option (list (simple-format #f "~A-hook" hook)) #t #f
+                  (lambda (opt name arg result)
+                    (alist-cons (symbol-append hook '-hook)
+                                (read/eval arg)
+                                (alist-delete (symbol-append hook '-hook)
+                                              result)))))
+        %known-hooks)))
 
 (define %service-option-defaults
   ;; Alist of default option values
-- 
cgit v1.2.3