Add a hook to handle missing inputs

That submits new build jobs to build these missing inputs if appropriate.

This means that you can tell the coordinator to build something, and it will
automatically attempt to build the dependencies if they're missing.

1 files changed, 69 insertions, 26 deletions

diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
index 1ba1ead..d8ec595 100644
--- a/guix-build-coordinator/build-allocator.scm
+++ b/guix-build-coordinator/build-allocator.scm
@@ -25,39 +25,82 @@
   #:export (basic-build-allocation-strategy))
 
 (define (basic-build-allocation-strategy datastore)
+  (define (log . args)
+    (when #f
+      (simple-format #t "allocator: ~A\n"
+                     (string-join (map (lambda (arg)
+                                         (simple-format #f "~A" arg))
+                                       args)
+                                  " "))))
+
   (let ((agents (datastore-list-agents datastore))
         (builds (datastore-list-unprocessed-builds datastore))
         (setup-failures
          (datastore-fetch-setup-failures datastore)))
 
     (define (filter-builds-for-agent agent-id)
+      (define (output-has-successful-build? output)
+        (log "considering missing input:" output)
+        (any (lambda (output-build)
+               (let ((build-successful?
+                      (string=? (assq-ref output-build 'result)
+                                "success")))
+                 (when build-successful?
+                   (log "found successful build:" (assq-ref output-build 'uuid)))
+
+                 build-successful?))
+             (datastore-list-builds-for-output datastore output)))
+
+      (define (relevant-setup-failure? setup-failure)
+        (log "setup failure:" setup-failure)
+        (let ((failure-reason
+               (assq-ref setup-failure 'failure-reason)))
+          (cond
+           ((string=? failure-reason "missing_inputs")
+            (not
+             (every output-has-successful-build?
+                    (datastore-list-setup-failure-missing-inputs
+                     datastore
+                     (assq-ref setup-failure 'id)))))
+           ((string=? failure-reason "could_not_delete_outputs")
+            ;; This problem might go away, but just don't try the same agent
+            ;; again for now.
+            (string=? (assq-ref setup-failure 'agent-id)
+                      agent-id))
+           (else
+            (error "Unknown setup failure " failure-reason)))))
+
       (lambda (build)
+        (log "build:" (assq-ref build 'uuid))
         (let* ((build-id (assq-ref build 'uuid))
                (setup-failures-for-build
                 (or (assoc-ref setup-failures build-id)
-                    '())))
-          (if (any (lambda (setup-failure)
-                     (string=? (assq-ref setup-failure 'agent-id)
-                               agent-id))
-                   setup-failures-for-build)
-              ;; Don't allocated builds to agents where the setup has failed
-              ;; in the past
-              #f
-              #t))))
-
-    (append-map
-     (lambda (agent-id)
-       (let ((builds-for-agent
-              (filter (filter-builds-for-agent agent-id)
-                      builds)))
-         (map (lambda (build-id ordering)
-                (list build-id
-                      agent-id
-                      ordering))
-              (map (lambda (build)
-                     (assq-ref build 'uuid))
-                   builds-for-agent)
-              (iota (length builds-for-agent)))))
-     (map (lambda (agent)
-            (assq-ref agent 'uuid))
-          agents))))
+                    '()))
+               (relevant-setup-failures
+                (filter relevant-setup-failure?
+                        setup-failures-for-build)))
+          (log "relevant setup failures:" relevant-setup-failures)
+          (if (null? relevant-setup-failures)
+              #t
+              #f))))
+
+    (let ((result
+           (append-map
+            (lambda (agent-id)
+              (log "considering builds for" agent-id)
+              (let ((builds-for-agent
+                     (filter (filter-builds-for-agent agent-id)
+                             builds)))
+                (map (lambda (build-id ordering)
+                       (list build-id
+                             agent-id
+                             ordering))
+                     (map (lambda (build)
+                            (assq-ref build 'uuid))
+                          builds-for-agent)
+                     (iota (length builds-for-agent)))))
+            (map (lambda (agent)
+                   (assq-ref agent 'uuid))
+                 agents))))
+      (log "finished")
+      result)))