From df2d13621f4b2ace33a460746e704115b7b1541e Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Thu, 15 Oct 2020 09:53:53 +0200
Subject: [PATCH] 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.
---
.dir-locals.el | 1 +
bin/cuirass.in | 68 +++++++++++++++++++++-------------------
src/cuirass/database.scm | 43 +++++++++++++++----------
src/cuirass/metrics.scm | 2 +-
tests/database.scm | 1 +
tests/http.scm | 1 +
tests/metrics.scm | 1 +
7 files changed, 67 insertions(+), 50 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index 0e5705d1..0423a7e0 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 23d8c685..aef4a650 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 c566b50d..31e65f6e 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 f244c01e..cd6a0663 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 a5083caf..73b347cc 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 23bfce6d..e0ab8407 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 48ee53ab..b957d88d 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"
--
GitLab