Double check when to actually store builds as asked

This should ensure that the ignore-if-build-for-derivation-exists? and
ignore-if-build-for-output-exists? options work even if two builds are
submitted for the same derivation at the same time. Since one transaction
should commit first, then the other transaction will notice this, even if the
checks prior to the transaction have not shown another build.

1 files changed, 99 insertions, 82 deletions

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 24c4877..52dd50c 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -344,6 +344,17 @@
            (not (null? builds-for-output))))
        outputs)))
 
+  (define (check-whether-to-store-build)
+    (cond
+     ((and ignore-if-build-for-derivation-exists?
+           (build-for-derivation-exists?))
+      '((no-build-submitted . build-already-exists-for-this-derivation)))
+     ((and ignore-if-build-for-outputs-exists?
+           (call-with-delay-logging build-for-output-already-exists?))
+      '((no-build-submitted . build-already-exists-for-a-output)))
+     (else
+      'continue)))
+
   (define* (store-build derivation-name
                         uuid
                         priority
@@ -371,69 +382,71 @@
 
   (define (build-perform-datastore-changes derivations-lacking-builds)
     (lambda (_)
-      ;; Actually create a build, do this first so the derived priorities for
-      ;; the builds inserted below are informed by this build.
-      (store-build derivation-file
-                   build-id
-                   priority
-                   tags)
-
-      (for-each
-       (match-lambda
-         ((related-derivation . related-uuid)
-          ;; Double check at this point, within the transaction that no build
-          ;; exists for this related derivation.
-          ;;
-          ;; This stops duplicate related builds from being submitted when
-          ;; simultaneous submit build requests are being processed.
-          (unless (datastore-build-exists-for-derivation-outputs?
-                   datastore
-                   related-derivation)
-
-            (simple-format #t "submtiting ~A for related ~A\n"
-                           related-uuid
-                           related-derivation)
-            (call-with-delay-logging
-             store-build
-             #:args (list related-derivation
-                          related-uuid
-                          ;; Let the scheduler take care of
-                          ;; the prioritisation
-                          0
-                          tags
-                          ;; Since this build's priority isn't important, this
-                          ;; expensive part of inserting builds can be skipped
-                          #:skip-updating-other-build-derived-priorities #t)))))
-       derivations-lacking-builds)
-      #t))
+      ;; Check again now, since new builds could have been added since the
+      ;; checks were made before the start of the transaction.
+      (match (check-whether-to-store-build)
+        ('continue
+         ;; Actually create a build, do this first so the derived priorities
+         ;; for the builds inserted below are informed by this build.
+         (store-build derivation-file
+                      build-id
+                      priority
+                      tags)
+
+         (for-each
+          (match-lambda
+            ((related-derivation . related-uuid)
+             ;; Double check at this point, within the transaction that no build
+             ;; exists for this related derivation.
+             ;;
+             ;; This stops duplicate related builds from being submitted when
+             ;; simultaneous submit build requests are being processed.
+             (unless (datastore-build-exists-for-derivation-outputs?
+                      datastore
+                      related-derivation)
+
+               (simple-format #t "submtiting ~A for related ~A\n"
+                              related-uuid
+                              related-derivation)
+               (call-with-delay-logging
+                store-build
+                #:args (list related-derivation
+                             related-uuid
+                             ;; Let the scheduler take care of
+                             ;; the prioritisation
+                             0
+                             tags
+                             ;; Since this build's priority isn't important, this
+                             ;; expensive part of inserting builds can be skipped
+                             #:skip-updating-other-build-derived-priorities #t)))))
+          derivations-lacking-builds)
+
+         #t)
+        (stop-reason
+         stop-reason))))
 
   (call-with-duration-metric
    (build-coordinator-metrics-registry build-coordinator)
    "coordinator_submit_build_duration_seconds"
    (lambda ()
-     (if (and ignore-if-build-for-derivation-exists?
-              (build-for-derivation-exists?))
-         '((no-build-submitted . build-already-exists-for-this-derivation))
-         (if (and ignore-if-build-for-outputs-exists?
-                  (call-with-delay-logging build-for-output-already-exists?))
-             '((no-build-submitted . build-already-exists-for-a-output))
-             (begin
-               ;; Store the derivation first, so that listing related
-               ;; derivations with no builds works
-               (unless (datastore-find-derivation datastore derivation-file)
-                 (datastore-store-derivation
-                  datastore
-                  (call-with-delay-logging read-drv
-                                           #:threshold 10
-                                           #:args (list derivation-file))))
-
-               (let ((related-derivations-lacking-builds
-                      (if ensure-all-related-derivation-outputs-have-builds?
-                          (datastore-list-related-derivations-with-no-build-for-outputs
-                           datastore
-                           derivation-file)
-                          '())))
-                (datastore-call-with-transaction
+     (match (check-whether-to-store-build)
+       ('continue
+        ;; Store the derivation first, so that listing related derivations
+        ;; with no builds works
+        (unless (datastore-find-derivation datastore derivation-file)
+          (datastore-store-derivation
+           datastore
+           (call-with-delay-logging read-drv
+                                    #:threshold 10
+                                    #:args (list derivation-file))))
+
+        (let ((related-derivations-lacking-builds
+               (if ensure-all-related-derivation-outputs-have-builds?
+                   (datastore-list-related-derivations-with-no-build-for-outputs
+                    datastore
+                    derivation-file)
+                   '())))
+          (match (datastore-call-with-transaction
                   datastore
                   (build-perform-datastore-changes
                    ;; Do this here so it doesn't take time in the writer thread
@@ -445,31 +458,35 @@
                     related-derivations-lacking-builds))
                   #:duration-metric-name
                   "store_build")
-
-                (let ((builds-total-metric
-                       (metrics-registry-fetch-metric (slot-ref datastore
-                                                                'metrics-registry)
-                                                      "builds_total")))
-                  (metric-increment
-                   builds-total-metric
-                   #:label-values `((system . ,(datastore-find-derivation-system
-                                                datastore
-                                                derivation-file))))
-                  (for-each (lambda (drv-name)
-                              (metric-increment
-                               builds-total-metric
-                               #:label-values
-                               `((system . ,(datastore-find-derivation-system
+            (#t                         ; build submitted
+             (let ((builds-total-metric
+                    (metrics-registry-fetch-metric (slot-ref datastore
+                                                             'metrics-registry)
+                                                   "builds_total")))
+               (metric-increment
+                builds-total-metric
+                #:label-values `((system . ,(datastore-find-derivation-system
                                              datastore
-                                             drv-name)))))
-                            related-derivations-lacking-builds)))
-
-               (build-coordinator-prompt-hook-processing-for-event
-                build-coordinator
-                'build-submitted)
-               (trigger-build-allocation build-coordinator)
-
-               `((build-submitted . ,build-id))))))))
+                                             derivation-file))))
+               (for-each (lambda (drv-name)
+                           (metric-increment
+                            builds-total-metric
+                            #:label-values
+                            `((system . ,(datastore-find-derivation-system
+                                          datastore
+                                          drv-name)))))
+                         related-derivations-lacking-builds))
+
+             (build-coordinator-prompt-hook-processing-for-event
+              build-coordinator
+              'build-submitted)
+             (trigger-build-allocation build-coordinator)
+
+             `((build-submitted . ,build-id)))
+            (stop-condition
+             stop-condition))))
+       (stop-condition
+        stop-condition)))))
 
 (define (cancel-build build-coordinator uuid)
   (define datastore (build-coordinator-datastore build-coordinator))