From dad8a92770658d800920d534076f5475d52b9131 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sat, 23 Apr 2022 22:55:17 +0100
Subject: Guard against inserting unnecessary related builds

---
 guix-build-coordinator/coordinator.scm      | 37 ++++++++++++++++++-----------
 guix-build-coordinator/datastore.scm        |  1 +
 guix-build-coordinator/datastore/sqlite.scm | 37 +++++++++++++++++++++++++++++
 3 files changed, 61 insertions(+), 14 deletions(-)

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index e2bdf04..443b90e 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -366,20 +366,29 @@
       (for-each
        (match-lambda
          ((related-derivation . related-uuid)
-          (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))))
+          ;; 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))
 
diff --git a/guix-build-coordinator/datastore.scm b/guix-build-coordinator/datastore.scm
index 6bd6944..4aa2981 100644
--- a/guix-build-coordinator/datastore.scm
+++ b/guix-build-coordinator/datastore.scm
@@ -39,6 +39,7 @@
 (re-export datastore-fetch-setup-failures)
 (re-export datastore-list-unbuilt-derivation-outputs)
 (re-export datastore-list-build-outputs)
+(re-export datastore-build-exists-for-derivation-outputs?)
 (re-export datastore-list-related-derivations-with-no-build-for-outputs)
 (re-export datastore-list-failed-builds-with-blocking-count)
 (re-export datastore-list-builds-for-derivation-recursive-inputs)
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 9ea2845..bbd9c28 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -22,6 +22,7 @@
             datastore-update
             datastore-call-with-transaction
             datastore-store-derivation
+            datastore-build-exists-for-derivation-outputs?
             datastore-list-related-derivations-with-no-build-for-outputs
             datastore-list-failed-builds-with-blocking-count
             datastore-list-builds-for-derivation-recursive-inputs
@@ -783,6 +784,42 @@ INSERT INTO agent_tags (agent_id, tag_id) VALUES (:agent_id, :tag_id)"
 
   #t)
 
+(define-method (datastore-build-exists-for-derivation-outputs?
+                (datastore <sqlite-datastore>)
+                derivation)
+  (call-with-worker-thread
+   (slot-ref datastore 'worker-reader-thread-channel)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT 1
+FROM derivation_outputs
+INNER JOIN derivation_outputs AS all_derivation_outputs
+  ON all_derivation_outputs.output_id = derivation_outputs.output_id
+INNER JOIN derivations
+  ON derivations.id = all_derivation_outputs.derivation_id
+INNER JOIN builds
+  ON builds.derivation_id = derivations.id
+WHERE derivation_outputs.derivation_id = :derivation_id
+  AND (SELECT system_id FROM derivations WHERE id = :derivation_id) =
+      derivations.system_id
+  AND builds.canceled = 0
+"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:derivation_id (db-find-derivation-id db derivation))
+
+       (let ((result (sqlite-step statement)))
+         (sqlite-reset statement)
+
+         (if result
+             #t
+             #f))))))
+
 (define-method (datastore-list-related-derivations-with-no-build-for-outputs
                 (datastore <sqlite-datastore>)
                 derivation)
-- 
cgit v1.2.3