From 4612a3a70f1e70afa4e0ce00e8cb1a7848dddf58 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Lassieur?= Date: Sun, 5 Aug 2018 13:14:44 +0200 Subject: database: Serialize all database accesses in a thread. Fixes . * 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. --- tests/database.scm | 103 +++++++++++++++++++++++++++-------------------------- tests/http.scm | 21 ++++++----- 2 files changed, 66 insertions(+), 58 deletions(-) (limited to 'tests') 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 . - (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) stringscm))) (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))) -- cgit v1.2.3