Register all new outputs in one worker.

Make sure that all registration queries are done from within a single database
worker. Otherwise, when builds from multiple evaluations are registered at
the same time, some contention occurs communicating with workers.

* src/cuirass/base.scm (new-outputs?, build-packages): Move build registration
to ...
* src/cuirass/database.scm (db-register-builds): ... this new procedure.
(with-db-worker-thread-no-timeout): New procedure. Use it in
"db-register-builds" to avoid timeout messages.

2 files changed, 57 insertions, 44 deletions

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index d672177..ad15ef9 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -686,53 +686,11 @@ by PRODUCT-SPECS."
                                           (#:path . ,product))))))
             product-specs))
 
-(define (new-outputs? outputs)
-  "Return #t if OUTPUTS contains at least one unregistered output and #f
-otherwise."
-  (let ((new-outputs
-         (filter-map (match-lambda
-                       ((name . path)
-                        (let ((drv (db-get-output path)))
-                          (and (not drv) path))))
-                     outputs)))
-    (not (null? new-outputs))))
-
 (define (build-packages store jobs eval-id)
   "Build JOBS and return a list of Build results."
-  (define (register job)
-    (let* ((name     (assq-ref job #:job-name))
-           (drv      (assq-ref job #:derivation))
-           (job-name (assq-ref job #:job-name))
-           (system   (assq-ref job #:system))
-           (nix-name (assq-ref job #:nix-name))
-           ;; XXX: How to keep logs from several attempts?
-           (log      (log-file store drv))
-           (outputs  (filter-map (lambda (res)
-                                   (match res
-                                     ((name . path)
-                                      `(,name . ,path))))
-                                 (derivation-path->output-paths drv)))
-           (cur-time (time-second (current-time time-utc))))
-      (and (new-outputs? outputs)
-           (let ((build `((#:derivation . ,drv)
-                          (#:eval-id . ,eval-id)
-                          (#:job-name . ,job-name)
-                          (#:system . ,system)
-                          (#:nix-name . ,nix-name)
-
-                          ;; XXX: We'd leave LOG to #f (i.e., NULL) but that
-                          ;; currently violates the non-NULL constraint.
-                          (#:log . ,(or log ""))
-
-                          (#:status . ,(build-status scheduled))
-                          (#:outputs . ,outputs)
-                          (#:timestamp . ,cur-time)
-                          (#:starttime . 0)
-                          (#:stoptime . 0))))
-             (db-add-build build)))))
-
   (define derivations
-    (with-time-logging "registration" (filter-map register jobs)))
+    (with-time-logging "registration"
+                       (db-register-builds store jobs eval-id)))
 
   (log-message "evaluation ~a registered ~a new derivations"
                eval-id (length derivations))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index c67a234..4de94f4 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -22,6 +22,8 @@
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (cuirass database)
+  #:use-module (guix derivations)
+  #:use-module (guix store)
   #:use-module (cuirass logging)
   #:use-module (cuirass config)
   #:use-module (cuirass utils)
@@ -58,6 +60,7 @@
             build-status
             db-add-build
             db-add-build-product
+            db-register-builds
             db-update-build-status!
             db-get-output
             db-get-inputs
@@ -204,6 +207,14 @@ connection."
         (format #f "Database worker unresponsive for ~a seconds."
                 (number->string timeout)))))))
 
+(define-syntax-rule (with-db-worker-thread-no-timeout db exp ...)
+  "This is similar to WITH-DB-WORKER-THREAD but it does not setup a timeout.
+This should be used with care as blocking too long in EXP can lead to workers
+starvation."
+  (call-with-worker-thread
+   (%db-channel)
+   (lambda (db) exp ...)))
+
 (define (read-sql-file file-name)
   "Return a list of string containing SQL instructions from FILE-NAME."
   (call-with-input-file file-name
@@ -632,6 +643,50 @@ path) VALUES ("
                  (assq-ref product #:path) ");")
     (last-insert-rowid db)))
 
+(define (db-register-builds store jobs eval-id)
+  (define (new-outputs? outputs)
+    (let ((new-outputs
+           (filter-map (match-lambda
+                         ((name . path)
+                          (let ((drv (db-get-output path)))
+                            (and (not drv) path))))
+                       outputs)))
+      (not (null? new-outputs))))
+
+  (define (register job)
+    (let* ((name     (assq-ref job #:job-name))
+           (drv      (assq-ref job #:derivation))
+           (job-name (assq-ref job #:job-name))
+           (system   (assq-ref job #:system))
+           (nix-name (assq-ref job #:nix-name))
+           ;; XXX: How to keep logs from several attempts?
+           (log      (log-file store drv))
+           (outputs  (filter-map (lambda (res)
+                                   (match res
+                                     ((name . path)
+                                      `(,name . ,path))))
+                                 (derivation-path->output-paths drv)))
+           (cur-time (time-second (current-time time-utc))))
+      (and (new-outputs? outputs)
+           (let ((build `((#:derivation . ,drv)
+                          (#:eval-id . ,eval-id)
+                          (#:job-name . ,job-name)
+                          (#:system . ,system)
+                          (#:nix-name . ,nix-name)
+
+                          ;; XXX: We'd leave LOG to #f (i.e., NULL) but that
+                          ;; currently violates the non-NULL constraint.
+                          (#:log . ,(or log ""))
+
+                          (#:status . ,(build-status scheduled))
+                          (#:outputs . ,outputs)
+                          (#:timestamp . ,cur-time)
+                          (#:starttime . 0)
+                          (#:stoptime . 0))))
+             (db-add-build build)))))
+
+  (with-db-worker-thread-no-timeout db (filter-map register jobs)))
+
 (define* (db-update-build-status! drv status #:key log-file)
   "Update the database so that DRV's status is STATUS.  This also updates the
 'starttime' or 'stoptime' fields.  If LOG-FILE is true, record it as the build