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.

1 files changed, 40 insertions, 61 deletions

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