database: Serialize all database accesses in a thread.

Fixes <https://bugs.gnu.org/32234>.

* bin/cuirass.in (main): Keep only one WITH-DATABASE call around all fibers.
Remove all DB arguments.
* src/cuirass/base.scm (evaluate, update-build-statuses!, spawn-builds,
handle-build-event, build-packages): Remove all DB arguments.
(clear-build-queue, cancel-old-builds): Wrap in WITH-DB-CRITICAL-SECTION,
remove all DB arguments.
(restart-builds): Remove the NON-BLOCKING call, remove all DB arguments.
(process-specs): Remove all DB arguments, remove the WITH-DATABASE call.
* src/cuirass/database.scm (%db-channel): New parameter.
(with-db-critical-section): New macro.
(db-add-input, db-add-specification, db-get-inputs, db-get-specifications,
db-add-evaluation, db-add-build, db-update-build-status!, db-get-outputs,
db-get-builds, db-get-build, db-get-pending-derivations, db-get-stamp,
db-add-stamp, db-get-evaluations, db-get-evaluations-build-summary,
db-get-evaluations-id-min, db-get-evaluations-id-max, db-get-builds-min,
db-get-builds-max): Wrap in WITH-DB-CRITICAL-SECTION, remove all DB arguments.
(with-database): Wrap BODY in PARAMETERIZE form that sets %DB-CHANNEL to the
channel returned by MAKE-CRITICAL-SECTION.
* src/cuirass/http.scm (handle-build-request, handle-builds-request): Remove
all DB arguments.
(url-handler): Remove all DB arguments, remove the DB-CHANNEL state, remove
the WITH-CRITICAL-SECTION calls.
(run-cuirass-server): Remove the DB arguments, remove the
MAKE-CRITICAL-SECTION call.
* src/cuirass/utils.scm (make-critical-section): Replace SPAWN-FIBER with
CALL-WITH-NEW-THREAD.  Wrap body in PARAMETERIZE form that clears
CURRENT-FIBER.
* tests/database.scm (with-temporary-database, "db-add-specification",
"db-add-build", "db-update-build-status!", "db-get-builds",
"db-get-pending-derivations"): Remove the DB arguments.
("db-init"): Set the %DB-CHANNEL parameter to the channel returned by
MAKE-CRITICAL-SECTION, and return #t.
("database"): Set %DB-CHANNEL to #f during cleanup.
* tests/http.scm ("db-init"): Set the %DB-CHANNEL parameter to the channel
returned by MAKE-CRITICAL-SECTION, and return #t.
("cuirass-run", "fill-db"): Remove the DB arguments.
("http"): Set %DB-CHANNEL to #f during cleanup.

8 files changed, 491 insertions, 457 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
index 9a065ae..465aa58 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -12,7 +12,8 @@
   (eval put 'call-with-time 'scheme-indent-function 1)
   (eval put 'test-error 'scheme-indent-function 1)
   (eval put 'make-parameter 'scheme-indent-function 1)
-  (eval put 'with-database 'scheme-indent-function 1)
+  (eval put 'with-database 'scheme-indent-function 0)
+  (eval put 'with-db-critical-section 'scheme-indent-function 1)
   (eval . (put 'with-critical-section 'scheme-indent-function 2)))
  (texinfo-mode
   (indent-tabs-mode)
diff --git a/bin/cuirass.in b/bin/cuirass.in
index 11eb975..d30f788 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -115,19 +115,19 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
           (log-message "running Fibers on ~a kernel threads" threads)
           (run-fibers
            (lambda ()
-             (with-database db
+             (with-database
                (and specfile
                     (let ((new-specs (save-module-excursion
                                       (lambda ()
                                         (set-current-module (make-user-module '()))
                                         (primitive-load specfile)))))
-                      (for-each (lambda (spec) (db-add-specification db spec))
+                      (for-each (lambda (spec) (db-add-specification spec))
                                 new-specs)))
                (if one-shot?
-                   (process-specs db (db-get-specifications db))
+                   (process-specs (db-get-specifications))
                    (let ((exit-channel (make-channel)))
 
-                     (clear-build-queue db)
+                     (clear-build-queue)
 
                      ;; First off, restart builds that had not completed or
                      ;; were not even started on a previous run.
@@ -135,25 +135,22 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
                       (essential-task
                        'restart-builds exit-channel
                        (lambda ()
-                         (with-database db
-                           (restart-builds db)))))
+                         (restart-builds))))
 
                      (spawn-fiber
                       (essential-task
                        'build exit-channel
                        (lambda ()
-                         (with-database db
-                           (while #t
-                             (process-specs db (db-get-specifications db))
-                             (log-message "next evaluation in ~a seconds" interval)
-                             (sleep interval))))))
+                         (while #t
+                           (process-specs (db-get-specifications))
+                           (log-message "next evaluation in ~a seconds" interval)
+                           (sleep interval)))))
 
                      (spawn-fiber
                       (essential-task
                        'web-server exit-channel
                        (lambda ()
-                         (with-database db
-                           (run-cuirass-server db #:host host #:port port))))
+                         (run-cuirass-server #:host host #:port port)))
                       #:parallel? #t)
 
                      (spawn-fiber
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index ab1ad31..1ec122c 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -248,7 +248,7 @@ fibers."
                    (logior (@ (fibers epoll) EPOLLERR)
                            (@ (fibers epoll) EPOLLHUP)))))
 
-(define (evaluate store db spec checkouts commits)
+(define (evaluate store spec checkouts commits)
   "Evaluate and build package derivations defined in SPEC, using CHECKOUTS.
 Return a list of jobs."
   (define (augment-job job eval-id)
@@ -277,8 +277,8 @@ Return a list of jobs."
       (('evaluation jobs)
        (let* ((spec-name (assq-ref spec #:name))
               (eval-id (db-add-evaluation
-                        db `((#:specification . ,spec-name)
-                             (#:commits . ,commits)))))
+                        `((#:specification . ,spec-name)
+                          (#:commits . ,commits)))))
          (log-message "created evaluation ~a for '~a'" eval-id spec-name)
          (map (lambda (job)
                 (augment-job job eval-id))
@@ -368,7 +368,7 @@ Essentially this procedure inverts the inversion-of-control that
   ;; Our shuffling algorithm is simple: we sort by .drv file name.  :-)
   (sort drv string<?))
 
-(define (update-build-statuses! store db lst)
+(define (update-build-statuses! store lst)
   "Update the build status of the derivations listed in LST, which have just
 been passed to 'build-derivations' (meaning that we can assume that, if their
 outputs are invalid, that they failed to build.)"
@@ -376,8 +376,8 @@ outputs are invalid, that they failed to build.)"
     (match (derivation-path->output-paths drv)
       (((_ . outputs) ...)
        (if (any (cut valid-path? store <>) outputs)
-           (db-update-build-status! db drv (build-status succeeded))
-           (db-update-build-status! db drv (build-status failed))))))
+           (db-update-build-status! drv (build-status succeeded))
+           (db-update-build-status! drv (build-status failed))))))
 
   (for-each update! lst))
 
@@ -393,10 +393,11 @@ and returns the values RESULTS."
        (print-exception (current-error-port) frame key args)
        (apply values results)))))
 
-(define* (spawn-builds store db drv
+(define* (spawn-builds store drv
                        #:key (max-batch-size 200))
-  "Build the derivations listed in DRV, updating DB as builds complete.
-Derivations are submitted in batches of at most MAX-BATCH-SIZE items."
+  "Build the derivations listed in DRV, updating the database as builds
+complete.  Derivations are submitted in batches of at most MAX-BATCH-SIZE
+items."
   ;; XXX: We want to pass 'build-derivations' as many derivations at once so
   ;; we benefit from as much parallelism as possible (we must be using
   ;; #:keep-going? #t).
@@ -444,7 +445,7 @@ Derivations are submitted in batches of at most MAX-BATCH-SIZE items."
                                    ;; from PORT and eventually close it.
                                    (catch #t
                                      (lambda ()
-                                       (handle-build-event db event))
+                                       (handle-build-event event))
                                      (exception-reporter state)))
                                  #t)
               (close-port port)
@@ -455,14 +456,14 @@ Derivations are submitted in batches of at most MAX-BATCH-SIZE items."
           ;; derivations were built "behind our back", in which case
           ;; 'build-derivations' doesn't actually do anything and
           ;; 'handle-build-event' doesn't see any event.  Because of that,
-          ;; adjust DB here.
-          (update-build-statuses! store db batch)
+          ;; adjust the database here.
+          (update-build-statuses! store batch)
 
           (loop rest (max (- count max-batch-size) 0))))))
 
-(define* (handle-build-event db event)
+(define* (handle-build-event event)
   "Handle EVENT, a build event sexp as produced by 'build-event-output-port',
-updating DB accordingly."
+updating the database accordingly."
   (define (valid? file)
     ;; FIXME: Sometimes we might get bogus events due to the interleaving of
     ;; build messages.  This procedure prevents us from propagating the bogus
@@ -475,7 +476,7 @@ updating DB accordingly."
      (if (valid? drv)
          (begin
            (log-message "build started: '~a'" drv)
-           (db-update-build-status! db drv (build-status started)))
+           (db-update-build-status! drv (build-status started)))
          (log-message "bogus build-started event for '~a'" drv)))
     (('build-remote drv host _ ...)
      (log-message "'~a' offloaded to '~a'" drv host))
@@ -483,13 +484,13 @@ updating DB accordingly."
      (if (valid? drv)
          (begin
            (log-message "build succeeded: '~a'" drv)
-           (db-update-build-status! db drv (build-status succeeded)))
+           (db-update-build-status! drv (build-status succeeded)))
          (log-message "bogus build-succeeded event for '~a'" drv)))
     (('build-failed drv _ ...)
      (if (valid? drv)
          (begin
            (log-message "build failed: '~a'" drv)
-           (db-update-build-status! db drv (build-status failed)))
+           (db-update-build-status! drv (build-status failed)))
          (log-message "bogus build-failed event for '~a'" drv)))
     (('substituter-started item _ ...)
      (log-message "substituter started: '~a'" item))
@@ -503,42 +504,42 @@ updating DB accordingly."
   (string=? (assq-ref build1 #:derivation)
             (assq-ref build2 #:derivation)))
 
-(define (clear-build-queue db)
-  "Reset the status of builds in DB that are marked as \"started\".  This
-procedure is meant to be called at startup."
+(define (clear-build-queue)
+  "Reset the status of builds in the database that are marked as \"started\".
+This procedure is meant to be called at startup."
   (log-message "marking stale builds as \"scheduled\"...")
-  (sqlite-exec db "UPDATE Builds SET status = -2 WHERE status = -1;"))
+  (with-db-critical-section db
+    (sqlite-exec db "UPDATE Builds SET status = -2 WHERE status = -1;")))
 
-(define (cancel-old-builds db age)
+(define (cancel-old-builds age)
   "Cancel builds older than AGE seconds."
   (log-message "canceling builds older than ~a seconds..." age)
-  (sqlite-exec db
-               "UPDATE Builds SET status = 4 WHERE status = -2 AND timestamp < "
-               (- (time-second (current-time time-utc)) age)
-               ";"))
-
-(define (restart-builds db)
-  "Restart builds whose status in DB is \"pending\" (scheduled or started)."
+  (with-db-critical-section db
+    (sqlite-exec
+     db "UPDATE Builds SET status = 4 WHERE status = -2 AND timestamp < "
+     (- (time-second (current-time time-utc)) age) ";")))
+
+(define (restart-builds)
+  "Restart builds whose status in the database is \"pending\" (scheduled or
+started)."
   (with-store store
-    ;; Note: On a big database, 'db-get-pending-derivations' can take a couple
-    ;; of minutes, hence 'non-blocking'.
     (log-message "retrieving list of pending builds...")
     (let*-values (((valid stale)
                    (partition (cut valid-path? store <>)
-                              (non-blocking (db-get-pending-derivations db)))))
+                              (db-get-pending-derivations))))
       ;; We cannot restart builds listed in STALE, so mark them as canceled.
       (log-message "canceling ~a stale builds" (length stale))
       (for-each (lambda (drv)
-                  (db-update-build-status! db drv (build-status canceled)))
+                  (db-update-build-status! drv (build-status canceled)))
                 stale)
 
       ;; Those in VALID can be restarted.  If some of them were built in the
       ;; meantime behind our back, that's fine: 'spawn-builds' will DTRT.
       (log-message "restarting ~a pending builds" (length valid))
-      (spawn-builds store db valid)
+      (spawn-builds store valid)
       (log-message "done with restarted builds"))))
 
-(define (build-packages store db jobs)
+(define (build-packages store jobs)
   "Build JOBS and return a list of Build results."
   (define (register job)
     (let* ((name     (assq-ref job #:job-name))
@@ -570,14 +571,14 @@ procedure is meant to be called at startup."
                      (#:timestamp . ,cur-time)
                      (#:starttime . 0)
                      (#:stoptime . 0))))
-        (db-add-build db build))))
+        (db-add-build build))))
 
   (define derivations
     (filter-map register jobs))
 
-  (spawn-builds store db derivations)
+  (spawn-builds store derivations)
 
-  (let* ((results (filter-map (cut db-get-build db <>) derivations))
+  (let* ((results (filter-map (cut db-get-build <>) derivations))
          (status (map (cut assq-ref <> #:status) results))
          (success (count (lambda (status)
                            (= status (build-status succeeded)))
@@ -651,11 +652,11 @@ procedure is meant to be called at startup."
            checkout)
          results)))
 
-(define (process-specs db jobspecs)
-  "Evaluate and build JOBSPECS and store results in DB."
+(define (process-specs jobspecs)
+  "Evaluate and build JOBSPECS and store results in the database."
   (define (process spec)
     (with-store store
-      (let* ((stamp (db-get-stamp db spec))
+      (let* ((stamp (db-get-stamp spec))
              (name (assoc-ref spec #:name))
              (checkouts (fetch-inputs spec))
              (commits (map (cut assq-ref <> #:commit) checkouts))
@@ -663,7 +664,7 @@ procedure is meant to be called at startup."
         (unless (equal? commits-str stamp)
           ;; Immediately mark SPEC's INPUTS as being processed so we don't
           ;; spawn a concurrent evaluation of that same commit.
-          (db-add-stamp db spec commits-str)
+          (db-add-stamp spec commits-str)
           (compile-checkouts spec (filter compile? checkouts))
           (spawn-fiber
            (lambda ()
@@ -674,11 +675,10 @@ procedure is meant to be called at startup."
                (log-message "evaluating spec '~a': stamp ~s different from ~s"
                             name commits-str stamp)
                (with-store store
-                 (with-database db
-                   (let ((jobs (evaluate store db spec checkouts commits)))
-                     (log-message "building ~a jobs for '~a'"
-                                  (length jobs) name)
-                     (build-packages store db jobs)))))))
+                 (let ((jobs (evaluate store spec checkouts commits)))
+                   (log-message "building ~a jobs for '~a'"
+                                (length jobs) name)
+                   (build-packages store jobs))))))
 
           ;; 'spawn-fiber' returns zero values but we need one.
           *unspecified*))))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 138da22..912039e 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -59,7 +59,9 @@
             ;; Parameters.
             %package-database
             %package-schema-file
+            %db-channel
             ;; Macros.
+            with-db-critical-section
             with-database))
 
 (define (%sqlite-exec db sql . args)
@@ -139,6 +141,16 @@ question marks matches the number of arguments to bind."
                                      (string-append %datadir "/" %package))
                                  "/sql")))
 
+(define %db-channel
+  (make-parameter #f))
+
+(define-syntax-rule (with-db-critical-section 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."
+  (call-with-critical-section (%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
@@ -238,92 +250,111 @@ database object."
   (vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
               0))
 
-(define (db-add-input db spec-name input)
-  (sqlite-exec db "\
+(define (db-add-input spec-name input)
+  (with-db-critical-section db
+    (sqlite-exec db "\
 INSERT OR IGNORE INTO Inputs (specification, name, url, load_path, branch, \
 tag, revision, no_compile_p) VALUES ("
-               spec-name ", "
-               (assq-ref input #:name) ", "
-               (assq-ref input #:url) ", "
-               (assq-ref input #:load-path) ", "
-               (assq-ref input #:branch) ", "
-               (assq-ref input #:tag) ", "
-               (assq-ref input #:commit) ", "
-               (if (assq-ref input #:no-compile?) 1 0) ");")
-  (last-insert-rowid db))
-
-(define (db-add-specification db spec)
-  "Store SPEC in database DB. SPEC inputs are stored in the INPUTS table."
-  (sqlite-exec db "\
+                 spec-name ", "
+                 (assq-ref input #:name) ", "
+                 (assq-ref input #:url) ", "
+                 (assq-ref input #:load-path) ", "
+                 (assq-ref input #:branch) ", "
+                 (assq-ref input #:tag) ", "
+                 (assq-ref input #:commit) ", "
+                 (if (assq-ref input #:no-compile?) 1 0) ");")
+    (last-insert-rowid db)))
+
+(define (db-add-specification spec)
+  "Store SPEC in database the database.  SPEC inputs are stored in the INPUTS
+table."
+  (with-db-critical-section db
+    (sqlite-exec db "\
 INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \
 package_path_inputs, proc_input, proc_file, proc, proc_args) \
   VALUES ("
-               (assq-ref spec #:name) ", "
-               (assq-ref spec #:load-path-inputs) ", "
-               (assq-ref spec #:package-path-inputs)", "
-               (assq-ref spec #:proc-input) ", "
-               (assq-ref spec #:proc-file) ", "
-               (symbol->string (assq-ref spec #:proc)) ", "
-               (assq-ref spec #:proc-args) ");")
-  (let ((spec-id (last-insert-rowid db)))
-    (for-each (lambda (input)
-                (db-add-input db (assq-ref spec #:name) input))
-              (assq-ref spec #:inputs))
-    spec-id))
-
-(define (db-get-inputs db spec-name)
-  (let loop ((rows (sqlite-exec db "SELECT * FROM Inputs WHERE specification="
-                                spec-name ";"))
-             (inputs '()))
-    (match rows
-      (() inputs)
-      ((#(specification name url load-path branch tag revision no-compile-p)
-        . rest)
-       (loop rest
-             (cons `((#:name . ,name)
-                     (#:url . ,url)
-                     (#:load-path . ,load-path)
-                     (#:branch . ,branch)
-                     (#:tag . ,tag)
-                     (#:commit . ,revision)
-                     (#:no-compile? . ,(positive? no-compile-p)))
-                   inputs))))))
-
-(define (db-get-specifications db)
-  (let loop ((rows  (sqlite-exec db "SELECT * FROM Specifications;"))
-             (specs '()))
-    (match rows
-      (() specs)
-      ((#(name load-path-inputs package-path-inputs proc-input proc-file proc
-               proc-args)
-        . rest)
-       (loop rest
-             (cons `((#:name . ,name)
-                     (#:load-path-inputs .
-                      ,(with-input-from-string load-path-inputs read))
-                     (#:package-path-inputs .
-                      ,(with-input-from-string package-path-inputs read))
-                     (#:proc-input . ,proc-input)
-                     (#:proc-file . ,proc-file)
-                     (#:proc . ,(with-input-from-string proc read))
-                     (#:proc-args . ,(with-input-from-string proc-args read))
-                     (#:inputs . ,(db-get-inputs db name)))
-                   specs))))))
-
-(define (db-add-evaluation db eval)
-  (sqlite-exec db "\
+                 (assq-ref spec #:name) ", "
+                 (assq-ref spec #:load-path-inputs) ", "
+                 (assq-ref spec #:package-path-inputs) ", "
+                 (assq-ref spec #:proc-input) ", "
+                 (assq-ref spec #:proc-file) ", "
+                 (symbol->string (assq-ref spec #:proc)) ", "
+                 (assq-ref spec #:proc-args) ");")
+    (let ((spec-id (last-insert-rowid db)))
+      (for-each (lambda (input)
+                  (db-add-input (assq-ref spec #:name) input))
+                (assq-ref spec #:inputs))
+      spec-id)))
+
+(define (db-get-inputs spec-name)
+  (with-db-critical-section db
+    (let loop ((rows (sqlite-exec
+                      db "SELECT * FROM Inputs WHERE specification="
+                      spec-name ";"))
+               (inputs '()))
+      (match rows
+        (() inputs)
+        ((#(specification name url load-path branch tag revision no-compile-p)
+           . rest)
+         (loop rest
+               (cons `((#:name . ,name)
+                       (#:url . ,url)
+                       (#:load-path . ,load-path)
+                       (#:branch . ,branch)
+                       (#:tag . ,tag)
+                       (#:commit . ,revision)
+                       (#:no-compile? . ,(positive? no-compile-p)))
+                     inputs)))))))
+
+(define (db-get-specifications)
+  (with-db-critical-section db
+    (let loop ((rows  (sqlite-exec db "SELECT * FROM Specifications;"))
+               (specs '()))
+      (match rows
+        (() specs)
+        ((#(name load-path-inputs package-path-inputs proc-input proc-file proc
+                 proc-args)
+           . rest)
+         (loop rest
+               (cons `((#:name . ,name)
+                       (#:load-path-inputs .
+                                           ,(with-input-from-string load-path-inputs read))
+                       (#:package-path-inputs .
+                                              ,(with-input-from-string package-path-inputs read))
+                       (#:proc-input . ,proc-input)
+                       (#:proc-file . ,proc-file)
+                       (#:proc . ,(with-input-from-string proc read))
+                       (#:proc-args . ,(with-input-from-string proc-args read))
+                       (#:inputs . ,(db-get-inputs name)))
+                     specs)))))))
+
+(define (db-add-evaluation eval)
+  (with-db-critical-section db
+    (sqlite-exec db "\
 INSERT INTO Evaluations (specification, commits) VALUES ("
-               (assq-ref eval #:specification) ", "
-               (string-join (assq-ref eval #:commits)) ");")
-  (last-insert-rowid db))
+                 (assq-ref eval #:specification) ", "
+                 (string-join (assq-ref eval #:commits)) ");")
+    (last-insert-rowid db)))
 
-(define-syntax-rule (with-database db body ...)
-  "Run BODY with a connection to the database which is bound to DB in BODY."
+(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 body ... (db-close db))))
+    (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-critical-section db)))
+       body ...)
+     (db-close db))))
 
 (define* (read-quoted-string #:optional (port (current-input-port)))
   "Read all of the characters out of PORT and return them as a SQL quoted
@@ -353,79 +384,84 @@ string."
   (failed-other      3)
   (canceled          4))
 
-(define (db-add-build db build)
-  "Store BUILD in database DB. BUILD eventual outputs are stored
-in the OUTPUTS table."
-  (catch 'sqlite-error
-    (lambda ()
-      (sqlite-exec db "
+(define (db-add-build build)
+  "Store BUILD in database the database.  BUILD eventual outputs are stored in
+the OUTPUTS table."
+  (with-db-critical-section db
+    (catch 'sqlite-error
+      (lambda ()
+        (sqlite-exec db "
 INSERT INTO Builds (derivation, evaluation, job_name, system, nix_name, log,
 status, timestamp, starttime, stoptime)
 VALUES ("
-                   (assq-ref build #:derivation) ", "
-                   (assq-ref build #:eval-id) ", "
-                   (assq-ref build #:job-name) ", "
-                   (assq-ref build #:system) ", "
-                   (assq-ref build #:nix-name) ", "
-                   (assq-ref build #:log) ", "
-                   (or (assq-ref build #:status)
-                       (build-status scheduled)) ", "
-                   (or (assq-ref build #:timestamp) 0) ", "
-                   (or (assq-ref build #:starttime) 0) ", "
-                   (or (assq-ref build #:stoptime) 0) ");")
-      (let ((derivation (assq-ref build #:derivation)))
-        (for-each (lambda (output)
-                    (match output
-                      ((name . path)
-                       (sqlite-exec db "\
+                     (assq-ref build #:derivation) ", "
+                     (assq-ref build #:eval-id) ", "
+                     (assq-ref build #:job-name) ", "
+                     (assq-ref build #:system) ", "
+                     (assq-ref build #:nix-name) ", "
+                     (assq-ref build #:log) ", "
+                     (or (assq-ref build #:status)
+                         (build-status scheduled)) ", "
+                     (or (assq-ref build #:timestamp) 0) ", "
+                     (or (assq-ref build #:starttime) 0) ", "
+                     (or (assq-ref build #:stoptime) 0) ");")
+        (let ((derivation (assq-ref build #:derivation)))
+          (for-each (lambda (output)
+                      (match output
+                        ((name . path)
+                         (sqlite-exec db "\
 INSERT INTO Outputs (derivation, name, path) VALUES ("
-                                    derivation ", " name ", " path ");"))))
-                  (assq-ref build #:outputs))
-        derivation))
-    (lambda (key who code message . rest)
-      ;; If we get a unique-constraint-failed error, that means we have
-      ;; already inserted the same build.  That happens when several jobs
-      ;; produce the same derivation, and we can ignore it.
-      (if (= code SQLITE_CONSTRAINT_PRIMARYKEY)
-          #f
-          (apply throw key who code rest)))))
-
-(define* (db-update-build-status! db drv status #:key log-file)
-  "Update DB so that DRV's status is STATUS.  This also updates the
+                                      derivation ", " name ", " path ");"))))
+                    (assq-ref build #:outputs))
+          derivation))
+      (lambda (key who code message . rest)
+        ;; If we get a unique-constraint-failed error, that means we have
+        ;; already inserted the same build.  That happens when several jobs
+        ;; produce the same derivation, and we can ignore it.
+        (if (= code SQLITE_CONSTRAINT_PRIMARYKEY)
+            #f
+            (apply throw key who code rest))))))
+
+(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
 log file for DRV."
   (define now
     (time-second (current-time time-utc)))
 
-  (if (= status (build-status started))
-      (sqlite-exec db "UPDATE Builds SET starttime=" now ", status="
-                   status "WHERE derivation=" drv ";")
-
-      ;; Update only if we're switching to a different status; otherwise leave
-      ;; things unchanged.  This ensures that 'stoptime' remains valid and
-      ;; doesn't change every time we mark DRV as 'succeeded' several times in
-      ;; a row, for instance.
-      (if log-file
-          (sqlite-exec db "UPDATE Builds SET stoptime=" now
-                       ", status=" status ", log=" log-file
-                       "WHERE derivation=" drv "AND status != " status ";")
-          (sqlite-exec db "UPDATE Builds SET stoptime=" now
-                       ", status=" status
-                       "WHERE derivation=" drv " AND status != " status ";"))))
-
-(define (db-get-outputs db derivation)
-  "Retrieve the OUTPUTS of the build identified by DERIVATION in DB database."
-  (let loop ((rows
-              (sqlite-exec db "SELECT name, path FROM Outputs
+  (with-db-critical-section db
+    (if (= status (build-status started))
+        (sqlite-exec db "UPDATE Builds SET starttime=" now ", status="
+                     status "WHERE derivation=" drv ";")
+
+        ;; Update only if we're switching to a different status; otherwise
+        ;; leave things unchanged.  This ensures that 'stoptime' remains valid
+        ;; and doesn't change every time we mark DRV as 'succeeded' several
+        ;; times in a row, for instance.
+        (if log-file
+            (sqlite-exec db "UPDATE Builds SET stoptime=" now
+                         ", status=" status ", log=" log-file
+                         "WHERE derivation=" drv "AND status != " status ";")
+            (sqlite-exec db "UPDATE Builds SET stoptime=" now
+                         ", status=" status
+                         "WHERE derivation=" drv " AND status != " status
+                         ";")))))
+
+(define (db-get-outputs derivation)
+  "Retrieve the OUTPUTS of the build identified by DERIVATION in the
+database."
+  (with-db-critical-section db
+    (let loop ((rows
+                (sqlite-exec db "SELECT name, path FROM Outputs
 WHERE derivation =" derivation ";"))
-             (outputs '()))
-    (match rows
-      (() outputs)
-      ((#(name path)
-        . rest)
-       (loop rest
-             (cons `(,name . ((#:path . ,path)))
-                   outputs))))))
+               (outputs '()))
+      (match rows
+        (() outputs)
+        ((#(name path)
+           . rest)
+         (loop rest
+               (cons `(,name . ((#:path . ,path)))
+                     outputs)))))))
 
 (define (filters->order filters)
   (match (assq 'order filters)
@@ -440,12 +476,13 @@ WHERE derivation =" derivation ";"))
     (('order . 'status+submission-time) "status DESC, timestamp DESC")
     (_ "rowid DESC")))
 
-(define (db-get-builds db filters)
-  "Retrieve all builds in database DB which are matched by given FILTERS.
+(define (db-get-builds filters)
+  "Retrieve all builds in the database which are matched by given FILTERS.
 FILTERS is an assoc list whose possible keys are 'derivation | 'id | 'jobset |
 'job | 'system | 'nr | 'order | 'status | 'evaluation."
-  (let* ((order (filters->order filters))
-         (stmt-text (format #f "SELECT * FROM (
+  (with-db-critical-section db
+    (let* ((order (filters->order filters))
+           (stmt-text (format #f "SELECT * FROM (
 SELECT Builds.derivation, Builds.rowid, Builds.timestamp, Builds.starttime,
 Builds.stoptime, Builds.log, Builds.status, Builds.job_name, Builds.system,
 Builds.nix_name, Specifications.name
@@ -475,93 +512,99 @@ CASE WHEN :borderlowtime IS NULL
 END DESC
 LIMIT :nr)
 ORDER BY ~a, rowid ASC;" order))
-         (stmt (sqlite-prepare db stmt-text #:cache? #t)))
-    (sqlite-bind-arguments
-     stmt
-     #:derivation (assq-ref filters 'derivation)
-     #:id (assq-ref filters 'id)
-     #:jobset (assq-ref filters 'jobset)
-     #:job (assq-ref filters 'job)
-     #:evaluation (assq-ref filters 'evaluation)
-     #:system (assq-ref filters 'system)
-     #:status (and=> (assq-ref filters 'status) object->string)
-     #:borderlowid (assq-ref filters 'border-low-id)
-     #:borderhighid (assq-ref filters 'border-high-id)
-     #:borderlowtime (assq-ref filters 'border-low-time)
-     #:borderhightime (assq-ref filters 'border-high-time)
-     #:nr (match (assq-ref filters 'nr)
-            (#f -1)
-            (x x)))
-    (sqlite-reset stmt)
-    (let loop ((rows (sqlite-fold-right cons '() stmt))
-               (builds '()))
-      (match rows
-        (() (reverse builds))
-        ((#(derivation id timestamp starttime stoptime log status job-name
-                       system nix-name specification) . rest)
-         (loop rest
-               (cons `((#:derivation . ,derivation)
-                       (#:id . ,id)
-                       (#:timestamp . ,timestamp)
-                       (#:starttime . ,starttime)
-                       (#:stoptime . ,stoptime)
-                       (#:log . ,log)
-                       (#:status . ,status)
-                       (#:job-name . ,job-name)
-                       (#:system . ,system)
-                       (#:nix-name . ,nix-name)
-                       (#:specification . ,specification)
-                       (#:outputs . ,(db-get-outputs db derivation)))
-                     builds)))))))
-
-(define (db-get-build db derivation-or-id)
-  "Retrieve a build in database DB which corresponds to DERIVATION-OR-ID."
-  (let ((key (if (number? derivation-or-id) 'id 'derivation)))
-    (match (db-get-builds db `((,key . ,derivation-or-id)))
-      ((build)
-       build)
-      (() #f))))
-
-(define (db-get-pending-derivations db)
+           (stmt (sqlite-prepare db stmt-text #:cache? #t)))
+      (sqlite-bind-arguments
+       stmt
+       #:derivation (assq-ref filters 'derivation)
+       #:id (assq-ref filters 'id)
+       #:jobset (assq-ref filters 'jobset)
+       #:job (assq-ref filters 'job)
+       #:evaluation (assq-ref filters 'evaluation)
+       #:system (assq-ref filters 'system)
+       #:status (and=> (assq-ref filters 'status) object->string)
+       #:borderlowid (assq-ref filters 'border-low-id)
+       #:borderhighid (assq-ref filters 'border-high-id)
+       #:borderlowtime (assq-ref filters 'border-low-time)
+       #:borderhightime (assq-ref filters 'border-high-time)
+       #:nr (match (assq-ref filters 'nr)
+              (#f -1)
+              (x x)))
+      (sqlite-reset stmt)
+      (let loop ((rows (sqlite-fold-right cons '() stmt))
+                 (builds '()))
+        (match rows
+          (() (reverse builds))
+          ((#(derivation id timestamp starttime stoptime log status job-name
+                         system nix-name specification) . rest)
+           (loop rest
+                 (cons `((#:derivation . ,derivation)
+                         (#:id . ,id)
+                         (#:timestamp . ,timestamp)
+                         (#:starttime . ,starttime)
+                         (#:stoptime . ,stoptime)
+                         (#:log . ,log)
+                         (#:status . ,status)
+                         (#:job-name . ,job-name)
+                         (#:system . ,system)
+                         (#:nix-name . ,nix-name)
+                         (#:specification . ,specification)
+                         (#:outputs . ,(db-get-outputs derivation)))
+                       builds))))))))
+
+(define (db-get-build derivation-or-id)
+  "Retrieve a build in the database which corresponds to DERIVATION-OR-ID."
+  (with-db-critical-section db
+    (let ((key (if (number? derivation-or-id) 'id 'derivation)))
+      (match (db-get-builds `((,key . ,derivation-or-id)))
+        ((build)
+         build)
+        (() #f)))))
+
+(define (db-get-pending-derivations)
   "Return the list of derivation file names corresponding to pending builds in
-DB.  The returned list is guaranteed to not have any duplicates."
-  (map (match-lambda (#(drv) drv))
-       (sqlite-exec db "
-SELECT derivation FROM Builds WHERE Builds.status < 0;")))
-
-(define (db-get-stamp db spec)
-  "Return a stamp corresponding to specification SPEC in database DB."
-  (let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification="
-                          (assq-ref spec #:name) ";")))
-    (match res
-      (() #f)
-      ((#(spec stamp)) stamp))))
-
-(define (db-add-stamp db spec stamp)
-  "Associate STAMP to specification SPEC in database DB."
-  (if (db-get-stamp db spec)
-      (sqlite-exec db "UPDATE Stamps SET stamp=" stamp
-                   "WHERE specification=" (assq-ref spec #:name) ";")
-      (sqlite-exec db "\
+the database.  The returned list is guaranteed to not have any duplicates."
+  (with-db-critical-section db
+    (map (match-lambda (#(drv) drv))
+         (sqlite-exec db "
+SELECT derivation FROM Builds WHERE Builds.status < 0;"))))
+
+(define (db-get-stamp spec)
+  "Return a stamp corresponding to specification SPEC in the database."
+  (with-db-critical-section db
+    (let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification="
+                            (assq-ref spec #:name) ";")))
+      (match res
+        (() #f)
+        ((#(spec stamp)) stamp)))))
+
+(define (db-add-stamp spec stamp)
+  "Associate STAMP to specification SPEC in the database."
+  (with-db-critical-section db
+    (if (db-get-stamp spec)
+        (sqlite-exec db "UPDATE Stamps SET stamp=" stamp
+                     "WHERE specification=" (assq-ref spec #:name) ";")
+        (sqlite-exec db "\
 INSERT INTO Stamps (specification, stamp) VALUES ("
-                   (assq-ref spec #:name) ", " stamp ");")))
+                     (assq-ref spec #:name) ", " stamp ");"))))
 
-(define (db-get-evaluations db limit)
-  (let loop ((rows  (sqlite-exec db "SELECT id, specification, commits
+(define (db-get-evaluations limit)
+  (with-db-critical-section db
+    (let loop ((rows  (sqlite-exec db "SELECT id, specification, commits
 FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
-             (evaluations '()))
-    (match rows
-      (() (reverse evaluations))
-      ((#(id specification commits)
-        . rest)
-       (loop rest
-             (cons `((#:id . ,id)
-                     (#:specification . ,specification)
-                     (#:commits . ,(string-tokenize commits)))
-                   evaluations))))))
-
-(define (db-get-evaluations-build-summary db spec limit border-low border-high)
-  (let loop ((rows (sqlite-exec db "
+               (evaluations '()))
+      (match rows
+        (() (reverse evaluations))
+        ((#(id specification commits)
+           . rest)
+         (loop rest
+               (cons `((#:id . ,id)
+                       (#:specification . ,specification)
+                       (#:commits . ,(string-tokenize commits)))
+                     evaluations)))))))
+
+(define (db-get-evaluations-build-summary spec limit border-low border-high)
+  (with-db-critical-section db
+    (let loop ((rows (sqlite-exec db "
 SELECT E.id, E.commits, B.succeeded, B.failed, B.scheduled
 FROM
 (SELECT id, commits
@@ -578,50 +621,54 @@ FROM Builds
 GROUP BY evaluation) B
 ON B.evaluation=E.id
 ORDER BY E.id ASC;"))
-             (evaluations '()))
-    (match rows
-      (() evaluations)
-      ((#(id commits succeeded failed scheduled) . rest)
-       (loop rest
-             (cons `((#:id . ,id)
-                     (#:commits . ,commits)
-                     (#:succeeded . ,(or succeeded 0))
-                     (#:failed . ,(or failed 0))
-                     (#:scheduled . ,(or scheduled 0)))
-                   evaluations))))))
-
-(define (db-get-evaluations-id-min db spec)
+               (evaluations '()))
+      (match rows
+        (() evaluations)
+        ((#(id commits succeeded failed scheduled) . rest)
+         (loop rest
+               (cons `((#:id . ,id)
+                       (#:commits . ,commits)
+                       (#:succeeded . ,(or succeeded 0))
+                       (#:failed . ,(or failed 0))
+                       (#:scheduled . ,(or scheduled 0)))
+                     evaluations)))))))
+
+(define (db-get-evaluations-id-min spec)
   "Return the min id of evaluations for the given specification SPEC."
-  (let ((rows (sqlite-exec db "
+  (with-db-critical-section db
+    (let ((rows (sqlite-exec db "
 SELECT MIN(id) FROM Evaluations
 WHERE specification=" spec)))
-    (vector-ref (car rows) 0)))
+      (vector-ref (car rows) 0))))
 
-(define (db-get-evaluations-id-max db spec)
+(define (db-get-evaluations-id-max spec)
   "Return the max id of evaluations for the given specification SPEC."
-  (let ((rows (sqlite-exec db "
+  (with-db-critical-section db
+    (let ((rows (sqlite-exec db "
 SELECT MAX(id) FROM Evaluations
 WHERE specification=" spec)))
-    (vector-ref (car rows) 0)))
+      (vector-ref (car rows) 0))))
 
-(define (db-get-builds-min db eval)
+(define (db-get-builds-min eval)
   "Return the min build (stoptime, id) pair for
    the given evaluation EVAL."
-  (let ((rows (sqlite-exec db "
+  (with-db-critical-section db
+    (let ((rows (sqlite-exec db "
 SELECT stoptime, MIN(rowid) FROM
 (SELECT rowid, stoptime FROM Builds
 WHERE evaluation=" eval " AND
 stoptime = (SELECT MIN(stoptime)
 FROM Builds WHERE evaluation=" eval "))")))
-    (vector->list (car rows))))
+      (vector->list (car rows)))))
 
-(define (db-get-builds-max db eval)
+(define (db-get-builds-max eval)
   "Return the max build (stoptime, id) pair for
    the given evaluation EVAL."
-  (let ((rows (sqlite-exec db "
+  (with-db-critical-section db
+    (let ((rows (sqlite-exec db "
 SELECT stoptime, MAX(rowid) FROM
 (SELECT rowid, stoptime FROM Builds
 WHERE evaluation=" eval " AND
 stoptime = (SELECT MAX(stoptime)
 FROM Builds WHERE evaluation=" eval "))")))
-    (vector->list (car rows))))
+      (vector->list (car rows)))))
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 16bbda0..d70517b 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -103,17 +103,17 @@
     (#:releasename . #nil)
     (#:buildinputs_builds . #nil)))
 
-(define (handle-build-request db build-id)
-  "Retrieve build identified by BUILD-ID over DB and convert it
-  to hydra format. Return #f is not build was found."
-  (let ((build (db-get-build db build-id)))
+(define (handle-build-request build-id)
+  "Retrieve build identified by BUILD-ID over the database and convert it to
+hydra format. Return #f is not build was found."
+  (let ((build (db-get-build build-id)))
     (and=> build build->hydra-build)))
 
-(define (handle-builds-request db filters)
-  "Retrieve all builds matched by FILTERS in DB and convert them
-  to Hydra format."
+(define (handle-builds-request filters)
+  "Retrieve all builds matched by FILTERS in the database and convert them to
+Hydra format."
   (let ((builds (with-time-logging "builds request"
-                                   (db-get-builds db filters))))
+                                   (db-get-builds filters))))
     (map build->hydra-build builds)))
 
 (define (request-parameters request)
@@ -146,10 +146,10 @@
 (define (request-path-components request)
   (split-and-decode-uri-path (uri-path (request-uri request))))
 
-(define (url-handler request body db-channel)
+(define (url-handler request body)
 
-  (define* (respond response #:key body (db-channel db-channel))
-    (values response body db-channel))
+  (define* (respond response #:key body)
+    (values response body #f))
 
   (define-syntax-rule (respond-json body ...)
     (respond '((content-type . (application/json)))
@@ -213,19 +213,14 @@
              (request-path-components request)
              'method-not-allowed)
     (((or "jobsets" "specifications") . rest)
-     (respond-json (object->json-string
-                    (with-critical-section db-channel (db)
-                      (db-get-specifications db)))))
+     (respond-json (object->json-string (db-get-specifications))))
     (("build" build-id)
-     (let ((hydra-build
-            (with-critical-section db-channel (db)
-              (handle-build-request db (string->number build-id)))))
+     (let ((hydra-build (handle-build-request (string->number build-id))))
        (if hydra-build
            (respond-json (object->json-string hydra-build))
            (respond-build-not-found build-id))))
     (("build" build-id "log" "raw")
-     (let ((build (with-critical-section db-channel (db)
-                    (db-get-build db (string->number build-id)))))
+     (let ((build (db-get-build (string->number build-id))))
        (if build
            (match (assq-ref build #:outputs)
              (((_ (#:path . (? string? output))) _ ...)
@@ -250,9 +245,7 @@
             ;; 'nr parameter is mandatory to limit query size.
             (nr (assq-ref params 'nr)))
        (if nr
-           (respond-json (object->json-string
-                          (with-critical-section db-channel (db)
-                            (db-get-evaluations db nr))))
+           (respond-json (object->json-string (db-get-evaluations nr)))
            (respond-json-with-error 500 "Parameter not defined!"))))
     (("api" "latestbuilds")
      (let* ((params (request-parameters request))
@@ -262,10 +255,9 @@
            ;; Limit results to builds that are "done".
            (respond-json
             (object->json-string
-             (with-critical-section db-channel (db)
-               (handle-builds-request db `((status . done)
-                                           ,@params
-                                           (order . finish-time))))))
+             (handle-builds-request `((status . done)
+                                      ,@params
+                                      (order . finish-time)))))
            (respond-json-with-error 500 "Parameter not defined!"))))
     (("api" "queue")
      (let* ((params (request-parameters request))
@@ -276,77 +268,65 @@
             (object->json-string
              ;; Use the 'status+submission-time' order so that builds in
              ;; 'running' state appear before builds in 'scheduled' state.
-             (with-critical-section db-channel (db)
-               (handle-builds-request db `((status . pending)
-                                           ,@params
-                                           (order . status+submission-time))))))
+             (handle-builds-request `((status . pending)
+                                      ,@params
+                                      (order . status+submission-time)))))
            (respond-json-with-error 500 "Parameter not defined!"))))
     ('()
      (respond-html (html-page
                     "Cuirass"
-                    (specifications-table
-                     (with-critical-section db-channel (db)
-                       (db-get-specifications db))))))
+                    (specifications-table (db-get-specifications)))))
 
     (("jobset" name)
      (respond-html
-      (with-critical-section db-channel (db)
-        (let* ((evaluation-id-max (db-get-evaluations-id-max db name))
-               (evaluation-id-min (db-get-evaluations-id-min db name))
-               (params (request-parameters request))
-               (border-high (assq-ref params 'border-high))
-               (border-low (assq-ref params 'border-low))
-               (evaluations (db-get-evaluations-build-summary db
-                                                              name
-                                                              %page-size
-                                                              border-low
-                                                              border-high)))
-          (html-page name (evaluation-info-table name
-                                                 evaluations
-                                                 evaluation-id-min
-                                                 evaluation-id-max))))))
+      (let* ((evaluation-id-max (db-get-evaluations-id-max name))
+             (evaluation-id-min (db-get-evaluations-id-min name))
+             (params (request-parameters request))
+             (border-high (assq-ref params 'border-high))
+             (border-low (assq-ref params 'border-low))
+             (evaluations (db-get-evaluations-build-summary name
+                                                            %page-size
+                                                            border-low
+                                                            border-high)))
+        (html-page name (evaluation-info-table name
+                                               evaluations
+                                               evaluation-id-min
+                                               evaluation-id-max)))))
 
     (("eval" id)
      (respond-html
-      (with-critical-section db-channel (db)
-        (let* ((builds-id-max (db-get-builds-max db id))
-               (builds-id-min (db-get-builds-min db id))
-               (params (request-parameters request))
-               (border-high-time (assq-ref params 'border-high-time))
-               (border-low-time (assq-ref params 'border-low-time))
-               (border-high-id (assq-ref params 'border-high-id))
-               (border-low-id (assq-ref params 'border-low-id)))
-          (html-page
-           "Evaluation"
-           (build-eval-table
-            (handle-builds-request db `((evaluation . ,id)
-                                        (nr . ,%page-size)
-                                        (order . finish-time+build-id)
-                                        (border-high-time . ,border-high-time)
-                                        (border-low-time . ,border-low-time)
-                                        (border-high-id . ,border-high-id)
-                                        (border-low-id . ,border-low-id)))
-            builds-id-min
-            builds-id-max))))))
+      (let* ((builds-id-max (db-get-builds-max id))
+             (builds-id-min (db-get-builds-min id))
+             (params (request-parameters request))
+             (border-high-time (assq-ref params 'border-high-time))
+             (border-low-time (assq-ref params 'border-low-time))
+             (border-high-id (assq-ref params 'border-high-id))
+             (border-low-id (assq-ref params 'border-low-id)))
+        (html-page
+         "Evaluation"
+         (build-eval-table
+          (handle-builds-request `((evaluation . ,id)
+                                   (nr . ,%page-size)
+                                   (order . finish-time+build-id)
+                                   (border-high-time . ,border-high-time)
+                                   (border-low-time . ,border-low-time)
+                                   (border-high-id . ,border-high-id)
+                                   (border-low-id . ,border-low-id)))
+          builds-id-min
+          builds-id-max)))))
 
     (("static" path ...)
      (respond-static-file path))
     ('method-not-allowed
      ;; 405 "Method Not Allowed"
-     (values (build-response #:code 405) #f db-channel))
+     (values (build-response #:code 405) #f #f))
     (_
      (respond-not-found (uri->string (request-uri request))))))
 
-(define* (run-cuirass-server db #:key (host "localhost") (port 8080))
+(define* (run-cuirass-server #:key (host "localhost") (port 8080))
   (let* ((host-info  (gethostbyname host))
          (address    (inet-ntop (hostent:addrtype host-info)
-                                (car (hostent:addr-list host-info))))
-
-         ;; Spawn a fiber to process database queries sequentially.  We need
-         ;; this because guile-sqlite3 handles are not thread-safe (caching in
-         ;; particular), and creating one new handle for each request would be
-         ;; costly and may defeat statement caching.
-         (db-channel (make-critical-section db)))
+                                (car (hostent:addr-list host-info)))))
     (log-message "listening on ~A:~A" address port)
 
     ;; Here we use our own web backend, call 'fiberized'.  We cannot use the
@@ -371,7 +351,7 @@
           (spawn-fiber
            (lambda ()
              (let-values (((response body state)
-                           (handle-request (cut url-handler <> <> db-channel)
+                           (handle-request (cut url-handler <> <>)
                                            request body '())))
                (write-client impl server client response body)))))
         (loop)))))
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 6083890..48e797c 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -103,17 +103,18 @@ then be passed to 'join-critical-section', which will ensure sequential
 ordering.  ARGS are the arguments of the critical section.
 
 Critical sections are implemented by passing the procedure to execute to a
-dedicated fiber."
-  (let ((channel (make-channel)))
-    (spawn-fiber
-     (lambda ()
-       (parameterize ((%critical-section-args args))
-         (let loop ()
-           (match (get-message channel)
-             (((? channel? reply) . (? procedure? proc))
-              (put-message reply (apply proc args))))
-           (loop)))))
-    channel))
+dedicated thread."
+  (parameterize (((@@ (fibers internal) current-fiber) #f))
+    (let ((channel (make-channel)))
+      (call-with-new-thread
+       (lambda ()
+         (parameterize ((%critical-section-args args))
+           (let loop ()
+             (match (get-message channel)
+               (((? channel? reply) . (? procedure? proc))
+                (put-message reply (apply proc args))))
+             (loop)))))
+      channel)))
 
 (define (call-with-critical-section channel proc)
   "Send PROC to the critical section through CHANNEL.  Return the result of
diff --git a/tests/database.scm b/tests/database.scm
index af518bd..cdc7872 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -21,6 +21,7 @@
 
 (use-modules (cuirass database)
              ((guix utils) #:select (call-with-temporary-output-file))
+             (cuirass utils)
              (srfi srfi-64))
 
 (define example-spec
@@ -61,12 +62,12 @@
     (#:log . "log")
     (#:outputs . (("foo" . "/foo")))))
 
-(define-syntax-rule (with-temporary-database db body ...)
+(define-syntax-rule (with-temporary-database body ...)
   (call-with-temporary-output-file
    (lambda (file port)
      (parameterize ((%package-database file))
        (db-init file)
-       (with-database db
+       (with-database
          body ...)))))
 
 (define %db
@@ -79,7 +80,10 @@
 
 (test-group-with-cleanup "database"
   (test-assert "db-init"
-    (%db (db-init database-name)))
+    (begin
+      (%db (db-init database-name))
+      (%db-channel (make-critical-section (%db)))
+      #t))
 
   (test-assert "sqlite-exec"
     (begin
@@ -94,41 +98,40 @@ INSERT INTO Evaluations (specification, commits) VALUES (3, 3);")
   (test-equal "db-add-specification"
     example-spec
     (begin
-      (db-add-specification (%db) example-spec)
-      (car (db-get-specifications (%db)))))
+      (db-add-specification example-spec)
+      (car (db-get-specifications))))
 
   (test-equal "db-add-build"
     #f
     (let ((build (make-dummy-build "/foo.drv")))
-      (db-add-build (%db) build)
+      (db-add-build build)
 
       ;; Should return #f when adding a build whose derivation is already
       ;; there, see <https://bugs.gnu.org/28094>.
-      (db-add-build (%db) build)))
+      (db-add-build build)))
 
   (test-equal "db-update-build-status!"
     (list (build-status scheduled)
           (build-status started)
           (build-status succeeded)
           "/foo.drv.log")
-    (with-temporary-database db
+    (with-temporary-database
       (let* ((derivation (db-add-build
-                          db
                           (make-dummy-build "/foo.drv" 1
                                             #:outputs '(("out" . "/foo")))))
              (get-status (lambda* (#:optional (key #:status))
-                           (assq-ref (db-get-build db derivation) key))))
-        (db-add-evaluation db (make-dummy-eval))
-        (db-add-specification db example-spec)
+                           (assq-ref (db-get-build derivation) key))))
+        (db-add-evaluation (make-dummy-eval))
+        (db-add-specification example-spec)
 
         (let ((status0 (get-status)))
-          (db-update-build-status! db "/foo.drv" (build-status started))
+          (db-update-build-status! "/foo.drv" (build-status started))
           (let ((status1 (get-status)))
-            (db-update-build-status! db "/foo.drv" (build-status succeeded)
+            (db-update-build-status! "/foo.drv" (build-status succeeded)
                                      #:log-file "/foo.drv.log")
 
             ;; Second call shouldn't make any difference.
-            (db-update-build-status! db "/foo.drv" (build-status succeeded)
+            (db-update-build-status! "/foo.drv" (build-status succeeded)
                                      #:log-file "/foo.drv.log")
 
             (let ((status2 (get-status))
@@ -144,61 +147,61 @@ INSERT INTO Evaluations (specification, commits) VALUES (3, 3);")
       ((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto
       ((3 "/baz.drv"))                               ;nr = 1
       ((2 "/bar.drv") (1 "/foo.drv") (3 "/baz.drv"))) ;status+submission-time
-    (with-temporary-database db
+    (with-temporary-database
       ;; Populate the 'Builds'', 'Evaluations', and
       ;; 'Specifications' tables in a consistent way, as expected by the
       ;; 'db-get-builds' query.
-      (db-add-build db (make-dummy-build "/foo.drv" 1
-                                         #:outputs `(("out" . "/foo"))))
-      (db-add-build db (make-dummy-build "/bar.drv" 2
-                                         #:outputs `(("out" . "/bar"))))
-      (db-add-build db (make-dummy-build "/baz.drv" 3
-                                         #:outputs `(("out" . "/baz"))))
-      (db-add-evaluation db (make-dummy-eval))
-      (db-add-evaluation db (make-dummy-eval))
-      (db-add-evaluation db (make-dummy-eval))
-      (db-add-specification db example-spec)
-
-      (db-update-build-status! db "/bar.drv" (build-status started)
+      (db-add-build (make-dummy-build "/foo.drv" 1
+                                      #:outputs `(("out" . "/foo"))))
+      (db-add-build (make-dummy-build "/bar.drv" 2
+                                      #:outputs `(("out" . "/bar"))))
+      (db-add-build (make-dummy-build "/baz.drv" 3
+                                      #:outputs `(("out" . "/baz"))))
+      (db-add-evaluation (make-dummy-eval))
+      (db-add-evaluation (make-dummy-eval))
+      (db-add-evaluation (make-dummy-eval))
+      (db-add-specification example-spec)
+
+      (db-update-build-status! "/bar.drv" (build-status started)
                                #:log-file "/bar.drv.log")
 
       (let ((summarize (lambda (alist)
                          (list (assq-ref alist #:id)
                                (assq-ref alist #:derivation)))))
-        (vector (map summarize (db-get-builds db '((nr . 3)
-                                                   (order . build-id))))
-                (map summarize (db-get-builds db '()))
-                (map summarize (db-get-builds db '((jobset . "guix"))))
-                (map summarize (db-get-builds db '((nr . 1))))
+        (vector (map summarize (db-get-builds '((nr . 3) (order . build-id))))
+                (map summarize (db-get-builds '()))
+                (map summarize (db-get-builds '((jobset . "guix"))))
+                (map summarize (db-get-builds '((nr . 1))))
                 (map summarize
-                     (db-get-builds
-                      db '((order . status+submission-time))))))))
+                     (db-get-builds '((order . status+submission-time))))))))
 
   (test-equal "db-get-pending-derivations"
     '("/bar.drv" "/foo.drv")
-    (with-temporary-database db
+    (with-temporary-database
       ;; Populate the 'Builds', 'Evaluations', and
       ;; 'Specifications' tables.  Here, two builds map to the same derivation
       ;; but the result of 'db-get-pending-derivations' must not contain any
       ;; duplicate.
-      (db-add-build db (make-dummy-build "/foo.drv" 1
-                                         #:outputs `(("out" . "/foo"))))
-      (db-add-build db (make-dummy-build "/bar.drv" 2
-                                         #:outputs `(("out" . "/bar"))))
-      (db-add-build db (make-dummy-build "/foo.drv" 3
-                                         #:outputs `(("out" . "/foo"))))
-      (db-add-evaluation db (make-dummy-eval))
-      (db-add-evaluation db (make-dummy-eval))
-      (db-add-evaluation db (make-dummy-eval))
-      (db-add-specification db example-spec)
-
-      (sort (db-get-pending-derivations db) string<?)))
+      (db-add-build (make-dummy-build "/foo.drv" 1
+                                      #:outputs `(("out" . "/foo"))))
+      (db-add-build (make-dummy-build "/bar.drv" 2
+                                      #:outputs `(("out" . "/bar"))))
+      (db-add-build (make-dummy-build "/foo.drv" 3
+                                      #:outputs `(("out" . "/foo"))))
+      (db-add-evaluation (make-dummy-eval))
+      (db-add-evaluation (make-dummy-eval))
+      (db-add-evaluation (make-dummy-eval))
+      (db-add-specification example-spec)
+
+      (sort (db-get-pending-derivations) string<?)))
 
   (test-assert "db-close"
     (db-close (%db)))
 
-  (delete-file database-name))
+  (begin
+    (%db-channel #f)
+    (delete-file database-name)))
 
 ;;; Local Variables:
-;;; eval: (put 'with-temporary-database 'scheme-indent-function 1)
+;;; eval: (put 'with-temporary-database 'scheme-indent-function 0)
 ;;; End:
diff --git a/tests/http.scm b/tests/http.scm
index a9fc3ef..38e4175 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -125,14 +125,17 @@
        json->scm)))
 
   (test-assert "db-init"
-    (%db (db-init database-name)))
+    (begin
+      (%db (db-init database-name))
+      (%db-channel (make-critical-section (%db)))
+      #t))
 
   (test-assert "cuirass-run"
     (call-with-new-thread
      (lambda ()
        (run-fibers
         (lambda ()
-          (run-cuirass-server (%db) #:port 6688))
+          (run-cuirass-server #:port 6688))
         #:drain? #t))))
 
   (test-assert "wait-server"
@@ -184,11 +187,11 @@
            (evaluation2
             '((#:specification . "guix")
               (#:commits . ("fakesha2" "fakesha3")))))
-      (db-add-build (%db) build1)
-      (db-add-build (%db) build2)
-      (db-add-specification (%db) specification)
-      (db-add-evaluation (%db) evaluation1)
-      (db-add-evaluation (%db) evaluation2)))
+      (db-add-build build1)
+      (db-add-build build2)
+      (db-add-specification specification)
+      (db-add-evaluation evaluation1)
+      (db-add-evaluation evaluation2)))
 
   (test-assert "/build/1"
     (hash-table=?
@@ -275,4 +278,6 @@
   (test-assert "db-close"
     (db-close (%db)))
 
-  (delete-file database-name))
+  (begin
+    (%db-channel #f)
+    (delete-file database-name)))