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.

2 files changed, 66 insertions, 58 deletions

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)))