From e34d773faf7309d4273fe204149845999d4ed8a7 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 24 Jan 2020 19:04:21 +0000
Subject: Adjust make-worker-thread-channel to take an initializer.

While this is a generic method, and initializer function will give the
flexibility required to create multiple worker threads for performing SQLite
queries, each with it's own database connection (as a result of calling the
initializer once for each thread). Without this change, they'd all have to use
the same connection, which would not work.

* src/cuirass/utils.scm (make-worker-thread-channel): Change procedure to take
an initializer, rather than arguments directly.
* src/cuirass/database.scm (with-database): Adjust to call
make-worker-thread-channel with an initializer.
* tests/database.scm (db-init): Change to use make-worker-thread-channel
initializer.
* tests/http.scm (db-init): Change to use make-worker-thread-channel
initializer.
---
 src/cuirass/database.scm | 25 +++++++------------------
 src/cuirass/utils.scm    | 19 ++++++++++---------
 tests/database.scm       |  4 +++-
 tests/http.scm           |  4 +++-
 4 files changed, 23 insertions(+), 29 deletions(-)

diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 2468804..c82e306 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -434,24 +434,13 @@ WHERE id = " eval-id ";")
                     (#:in_progress . #f)))))
 
 (define-syntax-rule (with-database body ...)
-  "Run BODY with %DB-CHANNEL being dynamically bound to a channel implementing
-a critical section that allows database operations to be serialized."
-  ;; XXX: We don't install an unwind handler to play well with delimited
-  ;; continuations and fibers.  But as a consequence, we leak DB when BODY
-  ;; raises an exception.
-  (let ((db (db-open)))
-    (unwind-protect
-     ;; Process database queries sequentially in a thread.  We need this
-     ;; because otherwise we would need to use the SQLite multithreading
-     ;; feature for which it is required to wait until the database is
-     ;; available, and the waiting would happen in non-cooperative and
-     ;; non-resumable code that blocks the fibers scheduler.  Now the database
-     ;; access blocks on PUT-MESSAGE, which allows the scheduler to schedule
-     ;; another fiber.  Also, creating one new handle for each request would
-     ;; be costly and may defeat statement caching.
-     (parameterize ((%db-channel (make-worker-thread-channel db)))
-       body ...)
-     (db-close db))))
+  "Run BODY with %DB-CHANNEL being dynamically bound to a channel providing a
+worker thread that allows database operations to run without intefering with
+fibers."
+  (parameterize ((%db-channel (make-worker-thread-channel
+                               (lambda ()
+                                 (list (db-open))))))
+    body ...))
 
 (define* (read-quoted-string #:optional (port (current-input-port)))
   "Read all of the characters out of PORT and return them as a SQL quoted
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 514899e..dfed4a9 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -99,19 +99,20 @@ delimited continuations and fibers."
 (define %worker-thread-args
   (make-parameter #f))
 
-(define (make-worker-thread-channel . args)
+(define (make-worker-thread-channel initializer)
   "Return a channel used to offload work to a dedicated thread.  ARGS are the
 arguments of the worker thread procedure."
   (parameterize (((@@ (fibers internal) current-fiber) #f))
     (let ((channel (make-channel)))
-      (call-with-new-thread
-       (lambda ()
-         (parameterize ((%worker-thread-args args))
-           (let loop ()
-             (match (get-message channel)
-               (((? channel? reply) . (? procedure? proc))
-                (put-message reply (apply proc args))))
-             (loop)))))
+      (let ((args (initializer)))
+        (call-with-new-thread
+         (lambda ()
+           (parameterize ((%worker-thread-args args))
+             (let loop ()
+               (match (get-message channel)
+                 (((? channel? reply) . (? procedure? proc))
+                  (put-message reply (apply proc args))))
+               (loop))))))
       channel)))
 
 (define (call-with-worker-thread channel proc)
diff --git a/tests/database.scm b/tests/database.scm
index 271f166..6098465 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -87,7 +87,9 @@
   (test-assert "db-init"
     (begin
       (%db (db-init database-name))
-      (%db-channel (make-worker-thread-channel (%db)))
+      (%db-channel (make-worker-thread-channel
+                    (lambda ()
+                      (list (%db)))))
       #t))
 
   (test-assert "sqlite-exec"
diff --git a/tests/http.scm b/tests/http.scm
index 337a775..d20a3c3 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -108,7 +108,9 @@
   (test-assert "db-init"
     (begin
       (%db (db-init database-name))
-      (%db-channel (make-worker-thread-channel (%db)))
+      (%db-channel (make-worker-thread-channel
+                    (lambda ()
+                      (list (%db)))))
       #t))
 
   (test-assert "cuirass-run"
-- 
cgit v1.2.3