Make the build failure retry hook more flexible

Now a procedure can be passed in, which should return arguments for the builds
to submit.

I'm looking at using this to spread retries across a range of machines for
example, by specifying different tags for each of the retries.

1 files changed, 30 insertions, 12 deletions

diff --git a/guix-build-coordinator/hooks.scm b/guix-build-coordinator/hooks.scm
index 263d783..7577891 100644
--- a/guix-build-coordinator/hooks.scm
+++ b/guix-build-coordinator/hooks.scm
@@ -27,6 +27,7 @@
   #:use-module (zlib)
   #:use-module (guix pki)
   #:use-module (guix config)
+  #:use-module ((guix utils) #:select (default-keyword-arguments))
   #:use-module (guix build utils)
   #:use-module (guix-build-coordinator config)
   #:use-module (guix-build-coordinator utils)
@@ -238,7 +239,8 @@
                   build-id)
    (current-error-port)))
 
-(define* (build-failure-retry-hook #:key (retries 2))
+(define* (build-failure-retry-hook #:key
+                                   (retries 2))
   (lambda (build-coordinator build-id)
     (define datastore
       (build-coordinator-datastore build-coordinator))
@@ -248,25 +250,41 @@
            (all-builds-for-derivation-count (datastore-count-builds-for-derivation
                                              datastore
                                              derivation-name
-                                             #:include-canceled? #f)))
-      (when (= 1 all-builds-for-derivation-count)
+                                             #:include-canceled? #f))
+           (retries-list
+            (if (procedure? retries)
+                (retries #:build-details build-details
+                         #:derivation-details (datastore-find-derivation
+                                               datastore
+                                               derivation-name)
+                         #:builds-for-derivation-count
+                         all-builds-for-derivation-count)
+                (if (= 1 all-builds-for-derivation-count)
+                    '()
+                    (make-list retries '())))))
+      (unless (null? retries-list)
         (display
          (simple-format #f "~A: submitting ~A retries for\n  ~A\n"
-                        build-id retries derivation-name))
+                        build-id (length retries-list) derivation-name))
         (for-each
-         (lambda (retry)
+         (lambda (retry-arguments index)
            (let ((details
-                  (submit-build build-coordinator derivation-name
-                                #:priority (assq-ref build-details 'priority)
-                                #:tags (datastore-fetch-build-tags
-                                        datastore
-                                        build-id))))
+                  (apply submit-build
+                         build-coordinator derivation-name
+                         (default-keyword-arguments
+                           retry-arguments
+                           (list
+                            #:priority (assq-ref build-details 'priority)
+                            #:tags (datastore-fetch-build-tags
+                                    datastore
+                                    build-id))))))
              (display
               (simple-format #f "~A: submitted retry ~A as ~A\n"
                              build-id
-                             (+ 1 retry)
+                             index
                              (assq-ref details 'build-submitted)))))
-         (iota retries))))))
+         retries-list
+         (iota (length retries-list) 1))))))
 
 (define* (build-recompress-log-file-hook #:key
                                          recompress-to