Use the writer worker for all write queries.

* .dir-locals.el: Add "with-queue-writer-worker".
* bin/cuirass.in: Modify "with-queue-writer-worker" scope to include the
web-server operations.
* src/cuirass/database.scm (with-db-writer-worker-thread): Export it.
(with-db-writer-worker-thread/force): New macro.
(db-add-input, db-add-checkout, db-add-specification, db-remove-specification,
db-add-evaluation, db-abort-pending-evaluations, db-set-evaluation-status,
db-set-evaluation-time, db-add-output, db-add-build-product, db-add-event,
db-delete-events-with-ids-<=-to): Use "with-db-writer-worker-thread" or
"with-db-writer-worker-thread/force" instead of "with-db-worker-thread".
* src/cuirass/metrics.scm (db-update-metrics): Ditto.
* tests/database.scm ("db-init"): Set "%db-writer-channel".
* tests/http.scm ("db-init"): Ditto.
* tests/metrics.scm ("db-init"): Ditto.

7 files changed, 67 insertions, 50 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
index 0e5705d..0423a7e 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -13,6 +13,7 @@
   (eval put 'test-error 'scheme-indent-function 1)
   (eval put 'make-parameter 'scheme-indent-function 1)
   (eval put 'with-database 'scheme-indent-function 0)
+  (eval put 'with-queue-writer-worker 'scheme-indent-function 0)
   (eval put 'with-db-worker-thread 'scheme-indent-function 1)
   (eval put 'with-db-writer-worker-thread 'scheme-indent-function 1))
  (texinfo-mode
diff --git a/bin/cuirass.in b/bin/cuirass.in
index 23d8c68..aef4a65 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -140,38 +140,40 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
           (run-fibers
            (lambda ()
              (with-database
-                 (and specfile
-                      (let ((new-specs (save-module-excursion
-                                        (lambda ()
-                                          (set-current-module (make-user-module '()))
-                                          (primitive-load specfile)))))
-                        (for-each db-add-specification new-specs)))
-
-                 (when queries-file
-                   (log-message "Enable SQL query logging.")
-                   (db-log-queries queries-file))
-
-                 (if one-shot?
-                     (process-specs (db-get-specifications))
-                     (let ((exit-channel (make-channel)))
-                       (start-watchdog)
-                       (if (option-ref opts 'web #f)
-                           (begin
-                             (spawn-fiber
-                              (essential-task
-                               'web exit-channel
-                               (lambda ()
-                                 (run-cuirass-server #:host host #:port port)))
-                              #:parallel? #t)
-
-                             (spawn-fiber
-                              (essential-task
-                               'monitor exit-channel
-                               (lambda ()
-                                 (while #t
-                                   (log-monitoring-stats)
-                                   (sleep 600))))))
-                           (with-queue-writer-worker
+               (with-queue-writer-worker
+                (and specfile
+                     (let ((new-specs (save-module-excursion
+                                       (lambda ()
+                                         (set-current-module (make-user-module '()))
+                                         (primitive-load specfile)))))
+                       (for-each db-add-specification new-specs)))
+
+                (when queries-file
+                  (log-message "Enable SQL query logging.")
+                  (db-log-queries queries-file))
+
+                (if one-shot?
+                    (process-specs (db-get-specifications))
+                    (let ((exit-channel (make-channel)))
+                      (start-watchdog)
+                      (if (option-ref opts 'web #f)
+                          (begin
+                            (spawn-fiber
+                             (essential-task
+                              'web exit-channel
+                              (lambda ()
+                                (run-cuirass-server #:host host #:port port)))
+                             #:parallel? #t)
+
+                            (spawn-fiber
+                             (essential-task
+                              'monitor exit-channel
+                              (lambda ()
+                                (while #t
+                                  (log-monitoring-stats)
+                                  (sleep 600))))))
+
+                          (begin
                             (clear-build-queue)
 
                             ;; If Cuirass was stopped during an evaluation,
@@ -216,7 +218,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
                                 (while #t
                                   (log-monitoring-stats)
                                   (sleep 600)))))))
-                       (primitive-exit (get-message exit-channel))))))
+                      (primitive-exit (get-message exit-channel)))))))
 
            ;; Most of our code is I/O so preemption doesn't matter much (it
            ;; could help while we're doing SQL requests, for instance, but it
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index c566b50..31e65f6 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -97,6 +97,8 @@
             %record-events?
             ;; Macros.
             with-db-worker-thread
+            with-db-writer-worker-thread
+            with-db-writer-worker-thread/force
             with-database
             with-queue-writer-worker))
 
@@ -201,8 +203,8 @@ specified."
 
 (define-syntax-rule (with-db-worker-thread db exp ...)
   "Evaluate EXP... in the critical section corresponding to %DB-CHANNEL.
-DB is bound to the argument of that critical section: the database
-connection."
+DB is bound to the argument of that critical section: the database connection.
+This must only be used for reading queries, i.e SELECT queries."
   (let ((send-timeout 2)
         (receive-timeout 5)
         (caller-name (frame-procedure-name
@@ -227,7 +229,10 @@ connection."
 (define-syntax with-db-writer-worker-thread
   (syntax-rules ()
     "Similar to WITH-DB-WORKER-THREAD but evaluates EXP in a database worker
-dedicated to writing.  EXP evaluation is queued unless #:force? is set."
+dedicated to writing.  EXP evaluation is deferred and will only be run once
+the worker evaluation queue in full.  To force an immediate evaluation the
+#:FORCE? option or the alias below may be used.  This macro is reserved for
+writing queries, i.e CREATE, DELETE, DROP, INSERT, or UPDATE queries."
     ((_ db #:force? force exp ...)
      (call-with-worker-thread
       (%db-writer-channel)
@@ -236,6 +241,12 @@ dedicated to writing.  EXP evaluation is queued unless #:force? is set."
     ((_ db exp ...)
      (with-db-writer-worker-thread db #:force? #f exp ...))))
 
+(define-syntax with-db-writer-worker-thread/force
+  (syntax-rules ()
+    "Alias for WITH-DB-WRITER-WORKER-THREAD with FORCE? option set."
+    ((_ db exp ...)
+     (with-db-writer-worker-thread db #:force? #t exp ...))))
+
 (define (read-sql-file file-name)
   "Return a list of string containing SQL instructions from FILE-NAME."
   (call-with-input-file file-name
@@ -382,7 +393,7 @@ of the list, and returns #f when there is no result."
     (() #f)))
 
 (define (db-add-input spec-name input)
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread/force db
     (sqlite-exec db "\
 INSERT OR IGNORE INTO Inputs (specification, name, url, load_path, branch, \
 tag, revision, no_compile_p) VALUES ("
@@ -398,7 +409,7 @@ tag, revision, no_compile_p) VALUES ("
 (define (db-add-checkout spec-name eval-id checkout)
   "Insert CHECKOUT associated with SPEC-NAME and EVAL-ID.  If a checkout with
 the same revision already exists for SPEC-NAME, return #f."
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread/force db
     (catch-sqlite-error
      (sqlite-exec db "\
 INSERT INTO Checkouts (specification, revision, evaluation, input,
@@ -419,7 +430,7 @@ directory, timestamp) VALUES ("
 (define (db-add-specification spec)
   "Store SPEC in database the database.  SPEC inputs are stored in the INPUTS
 table."
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread/force db
     (sqlite-exec db "\
 INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \
 package_path_inputs, proc_input, proc_file, proc, proc_args, \
@@ -441,7 +452,7 @@ build_outputs) \
 
 (define (db-remove-specification name)
   "Remove the specification matching NAME from the database and its inputs."
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread/force db
     (sqlite-exec db "BEGIN TRANSACTION;")
     (sqlite-exec db "\
 DELETE FROM Inputs WHERE specification=" name ";")
@@ -519,7 +530,7 @@ Otherwise, return #f."
   (define now
     (or timestamp (time-second (current-time time-utc))))
 
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread/force db
     (sqlite-exec db "BEGIN TRANSACTION;")
     (sqlite-exec db "INSERT INTO Evaluations (specification, status,
 timestamp, checkouttime, evaltime)
@@ -541,13 +552,13 @@ now "," checkouttime "," evaltime ");")
                  eval-id)))))
 
 (define (db-abort-pending-evaluations)
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread/force db
     (sqlite-exec db "UPDATE Evaluations SET status =
 " (evaluation-status aborted) " WHERE status = "
 (evaluation-status started))))
 
 (define (db-set-evaluation-status eval-id status)
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread/force db
     (sqlite-exec db "UPDATE Evaluations SET status =
 " status " WHERE id = " eval-id ";")))
 
@@ -555,7 +566,7 @@ now "," checkouttime "," evaltime ");")
   (define now
     (time-second (current-time time-utc)))
 
-  (with-db-worker-thread
+  (with-db-writer-worker-thread/force
    db
    (sqlite-exec db "UPDATE Evaluations SET evaltime = " now
                 "WHERE id = " eval-id ";")))
@@ -625,7 +636,7 @@ string."
 (define (db-add-output derivation output)
   "Insert OUTPUT associated with DERIVATION.  If an output with the same path
 already exists, return #f."
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread/force db
     (catch-sqlite-error
      (match output
        ((name . path)
@@ -642,7 +653,7 @@ INSERT INTO Outputs (derivation, name, path) VALUES ("
 (define (db-add-build build)
   "Store BUILD in database the database only if one of its outputs is new.
 Return #f otherwise.  BUILD outputs are stored in the OUTPUTS table."
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread/force db
     (sqlite-exec db "
 INSERT INTO Builds (derivation, evaluation, job_name, system, nix_name, log,
 status, timestamp, starttime, stoptime)
@@ -674,7 +685,7 @@ VALUES ("
 
 (define (db-add-build-product product)
   "Insert PRODUCT into BuildProducts table."
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread/force db
     (sqlite-exec db "\
 INSERT OR IGNORE INTO BuildProducts (build, type, file_size, checksum,
 path) VALUES ("
@@ -1065,7 +1076,7 @@ ORDER BY ~a;"
 
 (define (db-add-event type timestamp details)
   (when (%record-events?)
-    (with-db-worker-thread db
+    (with-db-writer-worker-thread db
       (sqlite-exec db "\
 INSERT INTO Events (type, timestamp, event_json) VALUES ("
                    (symbol->string type) ", "
@@ -1115,7 +1126,7 @@ LIMIT :nr;")
                        events))))))))
 
 (define (db-delete-events-with-ids-<=-to id)
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread db
     (sqlite-exec
      db
      "DELETE FROM Events WHERE id <= " id ";")))
diff --git a/src/cuirass/metrics.scm b/src/cuirass/metrics.scm
index f244c01..cd6a066 100644
--- a/src/cuirass/metrics.scm
+++ b/src/cuirass/metrics.scm
@@ -328,7 +328,7 @@ timestamp) VALUES ("
 
 (define (db-update-metrics)
   "Compute and update all available metrics in database."
-  (with-db-worker-thread db
+  (with-db-writer-worker-thread/force db
     ;; We can not update all evaluations metrics for performance reasons.
     ;; Limit to the evaluations that were added during the past three days.
     (let ((specifications
diff --git a/tests/database.scm b/tests/database.scm
index a5083ca..73b347c 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -93,6 +93,7 @@
       (%db-channel (make-worker-thread-channel
                     (lambda ()
                       (list (%db)))))
+      (%db-writer-channel (%db-channel))
       #t))
 
   (test-assert "sqlite-exec"
diff --git a/tests/http.scm b/tests/http.scm
index 23bfce6..e0ab840 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -114,6 +114,7 @@
       (%db-channel (make-worker-thread-channel
                     (lambda ()
                       (list (%db)))))
+      (%db-writer-channel (%db-channel))
       #t))
 
   (test-assert "cuirass-run"
diff --git a/tests/metrics.scm b/tests/metrics.scm
index 48ee53a..b957d88 100644
--- a/tests/metrics.scm
+++ b/tests/metrics.scm
@@ -53,6 +53,7 @@
       (%db-channel (make-worker-thread-channel
                     (lambda ()
                       (list (%db)))))
+      (%db-writer-channel (%db-channel))
       #t))
 
   (test-assert "sqlite-exec"