Split code for checking whether to store builds

To better separate out when a derivation is read, and when it's not. This
should ensure that derivations aren't being read inside the transaction to
submit builds.

1 files changed, 100 insertions, 94 deletions

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 618c4f9..1e10e43 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -620,39 +620,15 @@
         #:include-canceled? #f)
        0))
 
-  (define (build-for-output-already-exists?)
-    ;; Handle the derivation not existing in the database here, so that adding
-    ;; it to the database isn't required for this code to work
-    (let* ((system-from-database (datastore-find-derivation-system datastore
-                                                                   derivation-file))
-
-           (derivation-exists-in-database? (not (eq? #f system-from-database)))
-
-           (derivation
-            (if derivation-exists-in-database?
-                #f                      ; unnecessary to fetch derivation
-                ;; TODO Read the derivation in a separate thread
-                (with-fibers-port-timeouts
-                 (lambda ()
-                   (call-with-delay-logging read-drv
-                                            #:threshold 10
-                                            #:args (list derivation-file)))
-                 #:timeout 240)))
-
-           (system
-            (or system-from-database
-                (derivation-system derivation)))
-
-           (outputs
-            (if derivation-exists-in-database?
-                (datastore-find-derivation-outputs datastore
-                                                   derivation-file)
-                (map
-                 (match-lambda
-                   ((name . output)
-                    `((name . ,name)
-                      (output . ,(derivation-output-path output)))))
-                 (derivation-outputs derivation)))))
+  (define (build-for-output-already-exists/with-derivation? derivation)
+    (let ((system (derivation-system derivation))
+          (outputs
+           (map
+            (match-lambda
+              ((name . output)
+               `((name . ,name)
+                 (output . ,(derivation-output-path output)))))
+            (derivation-outputs derivation))))
       (any
        (lambda (output-details)
          (let ((builds-for-output
@@ -664,13 +640,40 @@
            (not (null? builds-for-output))))
        outputs)))
 
-  (define (check-whether-to-store-build)
+  (define (build-for-output-already-exists?)
+    (let ((system (datastore-find-derivation-system datastore
+                                                    derivation-file)))
+      (if (eq? #f system) ; derivation does not exist in database?
+          (build-for-output-already-exists/with-derivation?
+           (with-fibers-port-timeouts
+            (lambda ()
+              (call-with-delay-logging read-drv
+                                       #:threshold 10
+                                       #:args (list derivation-file)))
+            #:timeout 240))
+          (any
+           (lambda (output-details)
+             (let ((builds-for-output
+                    (datastore-list-builds-for-output-and-system
+                     datastore
+                     (assq-ref output-details 'output)
+                     system
+                     #:include-canceled? #f)))
+               (not (null? builds-for-output))))
+           (datastore-find-derivation-outputs datastore
+                                              derivation-file)))))
+
+  (define* (check-whether-to-store-build #:optional derivation)
     (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?))
+           (if derivation
+               (call-with-delay-logging
+                build-for-output-already-exists/with-derivation?
+                #:args (list derivation))
+               (call-with-delay-logging build-for-output-already-exists?)))
       '((no-build-submitted . build-already-exists-for-a-output)))
      (else
       'continue)))
@@ -700,11 +703,11 @@
     (or requested-uuid
         (random-v4-uuid)))
 
-  (define (build-perform-datastore-changes derivations-lacking-builds)
+  (define (build-perform-datastore-changes derivation derivations-lacking-builds)
     (lambda (_)
       ;; 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)
+      (match (check-whether-to-store-build derivation)
         ('continue
          ;; Actually create a build, do this first so the derived priorities
          ;; for the builds inserted below are informed by this build.
@@ -766,65 +769,68 @@
 
      (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
-           ;; TODO Read the derivation in a separate thread
-           (with-fibers-port-timeouts
-            (lambda ()
-              (call-with-delay-logging read-drv
-                                       #:threshold 10
-                                       #:args (list derivation-file)))
-            #:timeout 30)))
-
-        (let ((related-derivations-lacking-builds
-               (if ensure-all-related-derivation-outputs-have-builds?
-                   (datastore-list-related-derivations-with-no-build-for-outputs
+        (let ((drv
+               ;; If the dervation is missing from the database, read it and
+               ;; enter it in to the database, so that listing related
+               ;; derivations with no builds works
+               (if (datastore-find-derivation datastore derivation-file)
+                   #f
+                   (with-fibers-port-timeouts
+                    (lambda ()
+                      (call-with-delay-logging read-drv
+                                               #:threshold 10
+                                               #:args (list derivation-file)))
+                    #:timeout 30))))
+          (when drv
+            (datastore-store-derivation datastore drv))
+
+          (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
-                    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
-                   (map
-                    (lambda (drv)
-                      ;; Generate the UUID's outside the transaction to save
-                      ;; time too.
-                      (cons drv (random-v4-uuid)))
-                    related-derivations-lacking-builds))
-                  #:duration-metric-name
-                  "store_build")
-            (#t                         ; build submitted
-             (build-coordinator-prompt-hook-processing-for-event
-              build-coordinator
-              'build-submitted)
-
-             (build-coordinator-send-event
-              build-coordinator
-              'build-submitted
-              `((id          . ,build-id)
-                (derivation  . ,derivation-file)
-                (priority    . ,priority)
-                (tags
-                 . ,(list->vector
+                    (build-perform-datastore-changes
+                     drv
+                     ;; Do this here so it doesn't take time in the writer thread
                      (map
-                      (match-lambda
-                        ((key . value)
-                         `((key   . ,key)
-                           (value . ,value))))
-                      (if (vector? tags)
-                          (vector->list tags)
-                          tags))))
-                (defer_until . ,defer-until)))
-
-             (trigger-build-allocation build-coordinator)
-
-             `((build-submitted . ,build-id)))
-            (stop-condition
-             stop-condition))))
+                      (lambda (related-drv)
+                        ;; Generate the UUID's outside the transaction to save
+                        ;; time too.
+                        (cons related-drv (random-v4-uuid)))
+                      related-derivations-lacking-builds))
+                    #:duration-metric-name
+                    "store_build")
+              (#t                         ; build submitted
+               (build-coordinator-prompt-hook-processing-for-event
+                build-coordinator
+                'build-submitted)
+
+               (build-coordinator-send-event
+                build-coordinator
+                'build-submitted
+                `((id          . ,build-id)
+                  (derivation  . ,derivation-file)
+                  (priority    . ,priority)
+                  (tags
+                   . ,(list->vector
+                       (map
+                        (match-lambda
+                          ((key . value)
+                           `((key   . ,key)
+                             (value . ,value))))
+                        (if (vector? tags)
+                            (vector->list tags)
+                            tags))))
+                  (defer_until . ,defer-until)))
+
+               (trigger-build-allocation build-coordinator)
+
+               `((build-submitted . ,build-id)))
+              (stop-condition
+               stop-condition)))))
        (stop-condition
         stop-condition)))))