[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Ludovic Courtès |
|
Date: |
Wed, 31 May 2023 10:23:16 -0400 (EDT) |
branch: master
commit c4743b54720e86b0e0b0295fb6d33977e4293644
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed May 31 15:30:54 2023 +0200
database: Use a connection pool.
With 'exec-query' from (squee) no longer blocking, we no longer need to
carry out 'exec-query' calls in a dedicated worker thread. However, it
is useful to have a pool of database connections at hand to allow for
concurrent queries.
Thanks to Christopher Baines for suggesting the use of a connection pool.
* src/cuirass/database.scm (%db-channel): Remove.
(%db-connection-pool, %db-connection-pool-size): New variables.
(with-database): Rewrite to use 'make-resource-pool' when in a fiber
context.
(current-db): New variable.
(with-db-worker-thread): Rewrite to use 'current-db' or
'with-resource-from-pool' when appropriate, and plain 'db-open'
otherwise.
* tests/common.scm (test-init-db!): Remove reference to '%db-channel'.
* tests/database.scm (with-fibers): New macro.
Use it throughout.
* configure.ac: Check whether Guile-Squee is recent enough.
---
configure.ac | 13 +-
src/cuirass/database.scm | 108 ++++++---
tests/common.scm | 5 +-
tests/database.scm | 604 +++++++++++++++++++++++++++--------------------
4 files changed, 426 insertions(+), 304 deletions(-)
diff --git a/configure.ac b/configure.ac
index 3bb8553..3bd829a 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,7 +1,7 @@
## Process this file with autoconf to produce a configure script.
# Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
-# Copyright © 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2017, 2018, 2020, 2023 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2017 Mathieu Othacehe <othacehe@gnu.org>
#
# This file is part of Cuirass.
@@ -68,6 +68,17 @@ GUILE_MODULE_REQUIRED([zlib])
# We depend on new Guile-Git errors.
GUILE_MODULE_REQUIRED_EXPORT([(git)], git-error-message)
+# We need a recent-enough Squee where 'exec-query' is non-blocking:
+#
https://notabug.org/cwebber/guile-squee/commit/67bd6c3679dcd9cf8f2837848ec9cb2b53186614
+AC_MSG_CHECKING([whether (squee) is recent enough])
+squee_file="$($GUILE -c '(display (search-path %load-path "squee.scm"))')"
+if grep -q current-read-waiter "$squee_file"; then
+ AC_MSG_RESULT([yes])
+else
+ AC_MSG_RESULT([no])
+ AC_MSG_ERROR([Guile-Squee is too old; please get a newer one from
https://notabug.org/cwebber/guile-squee/])
+fi
+
guix_localstatedir="$($GUILE -c '(import (guix config)) (display
%localstatedir)')"
AC_SUBST(guix_localstatedir)
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 877f4a0..0be7000 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -1,7 +1,7 @@
;;; database.scm -- store evaluation and build results
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017, 2020 Mathieu Othacehe <othacehe@gnu.org>
-;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2020, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
;;; Copyright © 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
@@ -32,6 +32,7 @@
#:use-module (cuirass utils)
#:use-module (guix channels)
#:use-module (squee)
+ #:use-module ((fibers scheduler) #:select (current-scheduler))
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 ftw)
@@ -128,7 +129,7 @@
%create-database?
%package-database
%package-schema-file
- %db-channel
+ %db-connection-pool ;internal
;; Macros.
exec-query/bind
with-database
@@ -257,44 +258,77 @@ parameters matches the number of arguments to bind."
(string-append %datadir "/" %package))
"/sql")))
-(define %db-channel
+(define %db-connection-pool
+ ;; Channel of the database connection pool.
(make-parameter #f))
+(define %db-connection-pool-size
+ ;; Size of the database connection pool.
+ 8)
+
(define-syntax-rule (with-database body ...)
- "Run BODY with %DB-CHANNEL being dynamically bound to a channel providing a
-worker thread that allows database operations to run without interfering with
-fibers."
- (parameterize ((%db-channel
- (make-worker-thread-channel
- (lambda ()
- (list (db-open)))
- #:parallelism
- (min (current-processor-count) 8))))
- body ...))
-
-(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."
- (let ((send-timeout 2)
- (receive-timeout 5)
- (caller-name (frame-procedure-name
- (stack-ref (make-stack #t) 1))))
- (call-with-worker-thread
- (%db-channel)
- (lambda (db) exp ...)
- #:send-timeout send-timeout
- #:send-timeout-proc
- (lambda ()
- (log-warning
- (format #f "No available database workers for ~a seconds."
- (number->string send-timeout))))
- #:receive-timeout receive-timeout
- #:receive-timeout-proc
- (lambda ()
- (log-warning
- (format #f "Database worker unresponsive for ~a seconds (~a)."
- (number->string receive-timeout)
- caller-name))))))
+ "Create a pool of database connection (if in a Fiber context) and evaluate
+BODY... in that context. Close all database connections when leaving BODY's
+dynamic extent."
+ ;; Create a pool of database connections. Every time we make a query, pick
+ ;; a connection from the pool and return it once we're done. This allows
+ ;; us to run several queries concurrently (we can only execute one query at
+ ;; a time on each connection) and to reduce the risk of having quick
+ ;; queries blocked by slower ones.
+ (let ((connections (if (current-scheduler) ;fiber context?
+ (unfold (cut > <> %db-connection-pool-size)
+ (lambda (i)
+ (db-open))
+ 1+
+ 1)
+ '())))
+ (define (close)
+ (for-each db-close connections))
+
+ (with-exception-handler (lambda (exception)
+ (close)
+ (raise-exception exception))
+ (lambda ()
+ (define thunk
+ (lambda () body ...))
+ (define result
+ (if (current-scheduler) ;fiber context?
+ (parameterize ((%db-connection-pool (make-resource-pool
connections)))
+ (thunk))
+ (thunk)))
+ (close)
+ result))))
+
+(define current-db
+ ;; Database connection currently being used or #f.
+ (make-parameter #f))
+
+(define-syntax-rule (with-db-worker-thread db exp ...) ;TODO: Rename.
+ "Evaluate EXP... with DB bound to a database connection. In a Fiber context,
+the database connection is taken from the current connection pool, waiting if
+none is available. In a non-Fiber context, a new connection is opened; it is
+closed once EXP... has been evaluated."
+ (let ((proc (lambda (db) exp ...)))
+ (cond ((current-db)
+ ;; Ruse CURRENT-DB. Reusing the same connection is necessary when
+ ;; making a transaction through a series of 'exec-query' calls.
+ (proc (current-db)))
+ ((and (current-scheduler) ;running from a fiber
+ (%db-connection-pool))
+ (with-resource-from-pool (%db-connection-pool) db
+ (parameterize ((current-db db))
+ (proc db))))
+ (else ;non-fiber context
+ (parameterize ((current-db (db-open)))
+ (with-exception-handler
+ (lambda (exception)
+ (db-close (current-db))
+ (raise-exception exception))
+ (lambda ()
+ (define result
+ (proc (current-db)))
+ (db-close (current-db))
+ result)))))))
(define-syntax-rule (with-transaction exp ...)
"Evalute EXP within an SQL transaction."
diff --git a/tests/common.scm b/tests/common.scm
index 3412c8b..3d1e5df 100644
--- a/tests/common.scm
+++ b/tests/common.scm
@@ -53,7 +53,4 @@
"Initialize the test database."
(%create-database? #t)
(%package-database (pg-tmp))
- (%db (db-open))
- (%db-channel (make-worker-thread-channel
- (lambda ()
- (list (%db))))))
+ (%db (db-open)))
diff --git a/tests/database.scm b/tests/database.scm
index 4d5abac..b77b448 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -32,6 +32,7 @@
((guix utils) #:select (call-with-temporary-output-file))
(rnrs io ports)
(squee)
+ (fibers)
(ice-9 match)
(srfi srfi-19)
(srfi srfi-64))
@@ -102,6 +103,21 @@
(systems '("a" "b"))
(last-seen 1)))
+(define-syntax-rule (with-fibers exp ...)
+ "Evaluate EXP... in a Fiber context with a database connection pool."
+ (let ((db (db-open)))
+ (define result
+ (run-fibers
+ (lambda ()
+ (parameterize ((%db-connection-pool
+ (make-resource-pool (list db))))
+ exp ...))
+ #:drain? #t
+ #:parallelism 1
+ #:hz 5))
+ (db-close db)
+ result))
+
(test-group-with-cleanup "database"
(test-assert "db-init"
(begin
@@ -111,11 +127,12 @@
(test-equal "db-add-or-update-specification"
"guix"
- (db-add-or-update-specification example-spec))
+ (with-fibers
+ (db-add-or-update-specification example-spec)))
(test-equal "db-add-or-update-specification 2"
'core
- (begin
+ (with-fibers
(db-add-or-update-specification
(specification
(inherit example-spec)
@@ -124,7 +141,7 @@
(db-get-specification "guix"))))
(test-assert "db-add-or-update-specification 3"
- (begin
+ (with-fibers
(db-add-or-update-specification
(specification
(inherit example-spec)
@@ -141,119 +158,137 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0,
0, 0, 0);")
(exec-query (%db) "SELECT * FROM Evaluations;")))
(test-assert "db-get-specification"
- (let* ((spec (db-get-specification "guix"))
- (channels (specification-channels spec))
- (build-outputs (specification-build-outputs spec)))
- (and (string=? (specification-name spec) "guix")
- (equal? (map channel-name channels) '(guix my-channel))
- (equal? (map build-output-job build-outputs) '("job")))))
+ (with-fibers
+ (let* ((spec (db-get-specification "guix"))
+ (channels (specification-channels spec))
+ (build-outputs (specification-build-outputs spec)))
+ (and (string=? (specification-name spec) "guix")
+ (equal? (map channel-name channels) '(guix my-channel))
+ (equal? (map build-output-job build-outputs) '("job"))))))
(test-equal "db-add-evaluation"
'(2 3)
- (list
- (db-add-evaluation "guix"
- (make-dummy-instances "fakesha1" "fakesha2"))
- (db-add-evaluation "guix"
- (make-dummy-instances "fakesha3" "fakesha4"))))
+ (with-fibers
+ (list (db-add-evaluation "guix"
+ (make-dummy-instances "fakesha1" "fakesha2"))
+ (db-add-evaluation "guix"
+ (make-dummy-instances "fakesha3" "fakesha4")))))
(test-equal "db-get-latest-checkout"
'("fakesha3" "fakesha4")
- (map (cut assq-ref <> #:commit)
- (list (db-get-latest-checkout "guix" 'guix 3)
- (db-get-latest-checkout "guix" 'my-channel 3))))
+ (with-fibers
+ (map (cut assq-ref <> #:commit)
+ (list (db-get-latest-checkout "guix" 'guix 3)
+ (db-get-latest-checkout "guix" 'my-channel 3)))))
(test-assert "db-set-evaluation-status"
- (db-set-evaluation-status 2 (evaluation-status started)))
+ (with-fibers
+ (db-set-evaluation-status 2 (evaluation-status started))))
(test-assert "db-set-evaluation-time"
- (db-set-evaluation-time 2))
+ (with-fibers
+ (db-set-evaluation-time 2)))
(test-assert "db-abort-pending-evaluations"
- (db-abort-pending-evaluations))
+ (with-fibers
+ (db-abort-pending-evaluations)))
(test-equal "db-add-build"
"/foo.drv"
- (let ((build (make-dummy-build "/foo.drv")))
- (db-add-build build)))
+ (with-fibers
+ (let ((build (make-dummy-build "/foo.drv")))
+ (db-add-build build))))
(test-equal "db-add-build duplicate"
"/foo.drv"
- (let ((build (make-dummy-build "/foo.drv")))
- (db-add-build build)))
+ (with-fibers
+ (let ((build (make-dummy-build "/foo.drv")))
+ (db-add-build build))))
(test-assert "db-add-build-product"
- (db-add-build-product `((#:build . 1)
- (#:type . "1")
- (#:file-size . 1)
- (#:checksum . "sum")
- (#:path . "path"))))
+ (with-fibers
+ (db-add-build-product `((#:build . 1)
+ (#:type . "1")
+ (#:file-size . 1)
+ (#:checksum . "sum")
+ (#:path . "path")))))
(test-equal "db-get-output"
'((#:derivation . "/foo.drv") (#:name . "foo"))
- (db-get-output "/foo.drv.output"))
+ (with-fibers
+ (db-get-output "/foo.drv.output")))
(test-equal "db-get-outputs"
'(("foo" (#:path . "/foo.drv.output")))
- (db-get-outputs "/foo.drv"))
+ (with-fibers
+ (db-get-outputs "/foo.drv")))
(test-assert "db-get-time-since-previous-eval"
- (db-get-time-since-previous-eval "guix"))
+ (with-fibers
+ (db-get-time-since-previous-eval "guix")))
(test-assert "db-register-builds"
- (let ((drv "/test.drv"))
- (db-register-builds `(((#:job-name . "test")
- (#:derivation . ,drv)
- (#:system . "x86_64-linux")
- (#:nix-name . "test")
- (#:log . "log")
- (#:outputs .
- (("foo" . ,(format #f "~a.output" drv))
- ("foo2" . ,(format #f "~a.output.2" drv))))))
- 2 (db-get-specification "guix"))))
+ (with-fibers
+ (let ((drv "/test.drv"))
+ (db-register-builds `(((#:job-name . "test")
+ (#:derivation . ,drv)
+ (#:system . "x86_64-linux")
+ (#:nix-name . "test")
+ (#:log . "log")
+ (#:outputs .
+ (("foo" . ,(format #f "~a.output" drv))
+ ("foo2" . ,(format #f "~a.output.2" drv))))))
+ 2 (db-get-specification "guix")))))
(test-assert "db-get-jobs"
- (match (db-get-jobs 2
- '((#:system . "x86_64-linux")))
- ((job)
- (string=? (assq-ref job #:name) "test"))))
+ (with-fibers
+ (match (db-get-jobs 2
+ '((#:system . "x86_64-linux")))
+ ((job)
+ (string=? (assq-ref job #:name) "test")))))
(test-assert "db-get-jobs names"
- (match (db-get-jobs 2
- '((names "test")))
- ((job)
- (string=? (assq-ref job #:name) "test"))))
+ (with-fibers
+ (match (db-get-jobs 2
+ '((names "test")))
+ ((job)
+ (string=? (assq-ref job #:name) "test")))))
(test-assert "db-register-builds same-outputs"
- (let ((drv "/test2.drv"))
- (db-add-evaluation "guix"
- (make-dummy-instances "fakesha5" "fakesha6"))
- (db-register-builds `(((#:job-name . "test")
- (#:derivation . ,drv)
- (#:system . "x86_64-linux")
- (#:nix-name . "test")
- (#:log . "log")
- (#:outputs .
- (("foo" . "/test.drv.output")
- ("foo2" . "/test.drv.output.2")))))
- 4 (db-get-specification "guix"))))
+ (with-fibers
+ (let ((drv "/test2.drv"))
+ (db-add-evaluation "guix"
+ (make-dummy-instances "fakesha5" "fakesha6"))
+ (db-register-builds `(((#:job-name . "test")
+ (#:derivation . ,drv)
+ (#:system . "x86_64-linux")
+ (#:nix-name . "test")
+ (#:log . "log")
+ (#:outputs .
+ (("foo" . "/test.drv.output")
+ ("foo2" . "/test.drv.output.2")))))
+ 4 (db-get-specification "guix")))))
(test-equal "db-get-previous-eval"
1
- (db-get-previous-eval 4))
+ (with-fibers
+ (db-get-previous-eval 4)))
(test-assert "db-get-next-eval"
- (not (db-get-next-eval 3)))
+ (with-fibers
+ (not (db-get-next-eval 3))))
(test-assert "db-get-jobs same-outputs"
- (match (db-get-jobs 4 '())
- ((job)
- (string=? (assq-ref (db-get-build
- (assq-ref job #:build))
- #:derivation)
- "/test.drv"))))
+ (with-fibers
+ (match (db-get-jobs 4 '())
+ ((job)
+ (string=? (assq-ref (db-get-build
+ (assq-ref job #:build))
+ #:derivation)
+ "/test.drv")))))
(test-assert "db-get-jobs-history"
- (begin
+ (with-fibers
(db-set-evaluation-status 4 (evaluation-status succeeded))
(match (db-get-jobs-history '("test")
#:spec "guix"
@@ -263,178 +298,205 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0,
0, 0, 0);")
(eq? (length (assq-ref eval #:jobs)) 1))))))
(test-assert "db-update-build-status!"
- (db-update-build-status! "/test.drv"
- (build-status failed)))
+ (with-fibers
+ (db-update-build-status! "/test.drv"
+ (build-status failed))))
(test-assert "db-update-build-worker!"
- (db-update-build-worker! "/test.drv" "worker"))
+ (with-fibers
+ (db-update-build-worker! "/test.drv" "worker")))
(test-equal "db-get-builds-by-search"
'(3 1 "test")
- (let ((build
- (match (db-get-builds-by-search
- '((nr . 1)
- (query . "status:failed test")))
- ((build) build))))
- (list
- (assoc-ref build #:id)
- (assoc-ref build #:status)
- (assoc-ref build #:job-name))))
+ (with-fibers
+ (let ((build
+ (match (db-get-builds-by-search
+ '((nr . 1)
+ (query . "status:failed test")))
+ ((build) build))))
+ (list
+ (assoc-ref build #:id)
+ (assoc-ref build #:status)
+ (assoc-ref build #:job-name)))))
(test-assert "db-get-builds"
- (let* ((build (match (db-get-builds `((order . build-id)
- (status . failed)))
- ((build) build)))
- (outputs (assq-ref build #:outputs)))
- (equal? outputs
- '(("foo" (#:path . "/test.drv.output"))
- ("foo2" (#:path . "/test.drv.output.2"))))))
+ (with-fibers
+ (let* ((build (match (db-get-builds `((order . build-id)
+ (status . failed)))
+ ((build) build)))
+ (outputs (assq-ref build #:outputs)))
+ (equal? outputs
+ '(("foo" (#:path . "/test.drv.output"))
+ ("foo2" (#:path . "/test.drv.output.2")))))))
(test-equal "db-get-builds job-name"
"/foo.drv"
- (let ((build (match (db-get-builds `((order . build-id)
- (job . "job")))
- ((build) build))))
- (assoc-ref build #:derivation)))
+ (with-fibers
+ (let ((build (match (db-get-builds `((order . build-id)
+ (job . "job")))
+ ((build) build))))
+ (assoc-ref build #:derivation))))
(test-equal "db-get-build"
"/foo.drv"
- (let ((build (db-get-build 1)))
- (assoc-ref build #:derivation)))
+ (with-fibers
+ (let ((build (db-get-build 1)))
+ (assoc-ref build #:derivation))))
(test-equal "db-get-build derivation"
1
- (let ((build (db-get-build "/foo.drv")))
- (assoc-ref build #:id)))
+ (with-fibers
+ (let ((build (db-get-build "/foo.drv")))
+ (assoc-ref build #:id))))
(test-equal "db-get-pending-derivations"
'("/foo.drv")
- (db-get-pending-derivations))
+ (with-fibers
+ (db-get-pending-derivations)))
(test-equal "db-get-checkouts"
'("fakesha1" "fakesha2")
- (begin
+ (with-fibers
(make-dummy-instances "fakesha1" "fakesha2")
(map (cut assq-ref <> #:commit) (db-get-checkouts 2))))
(test-equal "db-get-evaluation"
"guix"
- (let ((evaluation (db-get-evaluation 2)))
- (assq-ref evaluation #:specification)))
+ (with-fibers
+ (let ((evaluation (db-get-evaluation 2)))
+ (assq-ref evaluation #:specification))))
(test-equal "db-get-evaluations"
'("guix" "guix")
- (map (lambda (eval)
- (assq-ref eval #:specification))
- (db-get-evaluations 2)))
+ (with-fibers
+ (map (lambda (eval)
+ (assq-ref eval #:specification))
+ (db-get-evaluations 2))))
(test-equal "db-get-evaluations-build-summary"
'((0 0 0) (0 0 0) (0 1 1))
- (let ((summaries
- (db-get-evaluations-build-summary "guix" 3 #f #f)))
- (map (lambda (summary)
- (list
- (assq-ref summary #:succeeded)
- (assq-ref summary #:failed)
- (assq-ref summary #:scheduled)))
- summaries)))
+ (with-fibers
+ (let ((summaries
+ (db-get-evaluations-build-summary "guix" 3 #f #f)))
+ (map (lambda (summary)
+ (list
+ (assq-ref summary #:succeeded)
+ (assq-ref summary #:failed)
+ (assq-ref summary #:scheduled)))
+ summaries))))
(test-equal "db-get-evaluation-absolute-summary"
'(0 1 0)
- (let ((summary
- (db-get-evaluation-absolute-summary
- (db-get-latest-evaluation "guix"))))
- (list
- (assq-ref summary #:succeeded)
- (assq-ref summary #:failed)
- (assq-ref summary #:scheduled))))
+ (with-fibers
+ (let ((summary
+ (db-get-evaluation-absolute-summary
+ (db-get-latest-evaluation "guix"))))
+ (list
+ (assq-ref summary #:succeeded)
+ (assq-ref summary #:failed)
+ (assq-ref summary #:scheduled)))))
(test-equal "db-get-evaluations-absolute-summary"
'((0 1 0) (0 1 0))
- (let* ((evaluations
- (db-get-evaluations-build-summary "guix" 3 #f #f))
- (summaries
- (db-get-evaluations-absolute-summary evaluations)))
- (map (lambda (summary)
- (list
- (assq-ref summary #:succeeded)
- (assq-ref summary #:failed)
- (assq-ref summary #:scheduled)))
- summaries)))
+ (with-fibers
+ (let* ((evaluations
+ (db-get-evaluations-build-summary "guix" 3 #f #f))
+ (summaries
+ (db-get-evaluations-absolute-summary evaluations)))
+ (map (lambda (summary)
+ (list
+ (assq-ref summary #:succeeded)
+ (assq-ref summary #:failed)
+ (assq-ref summary #:scheduled)))
+ summaries))))
(test-equal "db-get-evaluations-id-min"
1
- (db-get-evaluations-id-min "guix"))
+ (with-fibers
+ (db-get-evaluations-id-min "guix")))
(test-equal "db-get-evaluations-id-min"
#f
- (db-get-evaluations-id-min "foo"))
+ (with-fibers
+ (db-get-evaluations-id-min "foo")))
(test-equal "db-get-evaluations-id-max"
4
- (db-get-evaluations-id-max "guix"))
+ (with-fibers
+ (db-get-evaluations-id-max "guix")))
(test-equal "db-get-evaluations-id-max"
#f
- (db-get-evaluations-id-max "foo"))
+ (with-fibers
+ (db-get-evaluations-id-max "foo")))
(test-equal "db-get-latest-evaluation"
4
- (db-get-latest-evaluation "guix"))
+ (with-fibers
+ (db-get-latest-evaluation "guix")))
(test-equal "db-get-latest-evaluations"
4
- (match (db-get-latest-evaluations)
- ((eval)
- (assq-ref (assq-ref eval #:evaluation) #:id))))
+ (with-fibers
+ (match (db-get-latest-evaluations)
+ ((eval)
+ (assq-ref (assq-ref eval #:evaluation) #:id)))))
(test-equal "db-get-latest-evaluations 2"
4
- (match (db-get-latest-evaluations #:status #f)
- ((eval)
- (assq-ref (assq-ref eval #:evaluation) #:id))))
+ (with-fibers
+ (match (db-get-latest-evaluations #:status #f)
+ ((eval)
+ (assq-ref (assq-ref eval #:evaluation) #:id)))))
(test-equal "db-get-evaluation-summary"
'(2 0 1 1)
- (let* ((summary (db-get-evaluation-summary 2))
- (total (assq-ref summary #:total))
- (succeeded (assq-ref summary #:succeeded))
- (failed (assq-ref summary #:failed))
- (scheduled (assq-ref summary #:scheduled)))
- (list total succeeded failed scheduled)))
+ (with-fibers
+ (let* ((summary (db-get-evaluation-summary 2))
+ (total (assq-ref summary #:total))
+ (succeeded (assq-ref summary #:succeeded))
+ (failed (assq-ref summary #:failed))
+ (scheduled (assq-ref summary #:scheduled)))
+ (list total succeeded failed scheduled))))
(test-equal "db-get-evaluation-summary empty"
'(0 0 0 0)
- (let* ((summary (db-get-evaluation-summary 3))
- (total (assq-ref summary #:total))
- (succeeded (assq-ref summary #:succeeded))
- (failed (assq-ref summary #:failed))
- (scheduled (assq-ref summary #:scheduled)))
- (list total succeeded failed scheduled)))
+ (with-fibers
+ (let* ((summary (db-get-evaluation-summary 3))
+ (total (assq-ref summary #:total))
+ (succeeded (assq-ref summary #:succeeded))
+ (failed (assq-ref summary #:failed))
+ (scheduled (assq-ref summary #:scheduled)))
+ (list total succeeded failed scheduled))))
(test-equal "db-get-builds-query-min"
'(1)
- (db-get-builds-query-min "spec:guix foo"))
+ (with-fibers
+ (db-get-builds-query-min "spec:guix foo")))
(test-equal "db-get-builds-query-max"
'(3)
- (db-get-builds-query-min "spec:guix status:failed test"))
+ (with-fibers
+ (db-get-builds-query-min "spec:guix status:failed test")))
(test-equal "db-get-builds-min"
3
- (match (db-get-builds-min 2 "failed")
- ((timestamp id)
- id)))
+ (with-fibers
+ (match (db-get-builds-min 2 "failed")
+ ((timestamp id)
+ id))))
(test-equal "db-get-builds-max"
1
- (match (db-get-builds-max 2 "pending")
- ((timestamp id)
- id)))
+ (with-fibers
+ (match (db-get-builds-max 2 "pending")
+ ((timestamp id)
+ id))))
(test-equal "db-get-evaluation-specification"
"guix"
- (db-get-evaluation-specification 2))
+ (with-fibers
+ (db-get-evaluation-specification 2)))
(test-equal "db-get-build-products"
`(((#:id . 1)
@@ -442,28 +504,32 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
(#:file-size . 1)
(#:checksum . "sum")
(#:path . "path")))
- (db-get-build-products 1))
+ (with-fibers
+ (db-get-build-products 1)))
(test-equal "db-get-build-product-path"
"path"
- (db-get-build-product-path 1))
+ (with-fibers
+ (db-get-build-product-path 1)))
(test-equal "db-add-or-update-worker"
1
- (begin
+ (with-fibers
(db-add-or-update-worker %dummy-worker)
(db-add-or-update-worker %dummy-worker)))
(test-equal "db-get-worker"
%dummy-worker
- (db-get-worker "worker"))
+ (with-fibers
+ (db-get-worker "worker")))
(test-equal "db-get-workers"
(list %dummy-worker)
- (db-get-workers))
+ (with-fibers
+ (db-get-workers)))
(test-assert "db-remove-unresponsive-workers"
- (begin
+ (with-fibers
(let ((drv "/foo.drv"))
(db-update-build-worker! drv "worker")
(db-update-build-status! drv (build-status started))
@@ -477,7 +543,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0,
0);")
(test-equal "db-clear-workers"
'()
- (begin
+ (with-fibers
(db-clear-workers)
(db-get-workers)))
@@ -486,34 +552,35 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
(build-status started)
(build-status succeeded)
"/foo2.log")
- (let* ((derivation (db-add-build
- (make-dummy-build "/foo2.drv" 2
- #:outputs '(("out" . "/foo")))))
- (get-status (lambda* (#:optional (key #:status))
- (assq-ref (db-get-build derivation) key))))
- (let ((status0 (get-status)))
- (db-update-build-status! "/foo2.drv" (build-status started)
- #:log-file "/foo2.log")
- (let ((status1 (get-status)))
- (db-update-build-status! "/foo2.drv" (build-status succeeded))
-
- ;; Second call shouldn't make any difference.
- (db-update-build-status! "/foo2.drv" (build-status succeeded))
-
- (let ((status2 (get-status))
- (start (get-status #:starttime))
- (end (get-status #:stoptime))
- (log (get-status #:log)))
- (and (> start 0) (>= end start)
- (list status0 status1 status2 log)))))))
+ (with-fibers
+ (let* ((derivation (db-add-build
+ (make-dummy-build "/foo2.drv" 2
+ #:outputs '(("out" . "/foo")))))
+ (get-status (lambda* (#:optional (key #:status))
+ (assq-ref (db-get-build derivation) key))))
+ (let ((status0 (get-status)))
+ (db-update-build-status! "/foo2.drv" (build-status started)
+ #:log-file "/foo2.log")
+ (let ((status1 (get-status)))
+ (db-update-build-status! "/foo2.drv" (build-status succeeded))
+
+ ;; Second call shouldn't make any difference.
+ (db-update-build-status! "/foo2.drv" (build-status succeeded))
+
+ (let ((status2 (get-status))
+ (start (get-status #:starttime))
+ (end (get-status #:stoptime))
+ (log (get-status #:log)))
+ (and (> start 0) (>= end start)
+ (list status0 status1 status2 log))))))))
(test-equal "db-get-builds"
- '(("/baa.drv" "/bar.drv" "/baz.drv") ;ascending order
- ("/baz.drv" "/bar.drv" "/baa.drv") ;descending order
- ("/baz.drv" "/bar.drv" "/baa.drv") ;ditto
- ("/baz.drv") ;nr = 1
- ("/bar.drv" "/baa.drv" "/baz.drv")) ;status+submission-time
- (begin
+ '(("/baa.drv" "/bar.drv" "/baz.drv") ;ascending order
+ ("/baz.drv" "/bar.drv" "/baa.drv") ;descending order
+ ("/baz.drv" "/bar.drv" "/baa.drv") ;ditto
+ ("/baz.drv") ;nr = 1
+ ("/bar.drv" "/baa.drv" "/baz.drv")) ;status+submission-time
+ (with-fibers
(exec-query (%db) "DELETE FROM Builds;")
(db-add-build (make-dummy-build "/baa.drv" 2
#:outputs `(("out" . "/baa"))))
@@ -534,7 +601,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0,
0);")
(test-equal "db-get-pending-derivations"
'("/bar.drv" "/foo.drv")
- (begin
+ (with-fibers
(exec-query (%db) "DELETE FROM Builds;")
(db-add-build (make-dummy-build "/foo.drv" 1
#:outputs `(("out" . "/foo"))))
@@ -543,7 +610,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0,
0);")
(sort (db-get-pending-derivations) string<?)))
(test-assert "db-get-build-percentages"
- (begin
+ (with-fibers
(let* ((ts (time-second (current-time time-utc)))
(old `((#:derivation . "/last.drv")
(#:eval-id . 2)
@@ -574,7 +641,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0,
0);")
(test-equal "db-update-build-status!"
(list #f 1)
- (begin
+ (with-fibers
(db-add-evaluation "guix"
(make-dummy-instances "fakesha5" "fakesha6"))
(db-add-build (make-dummy-build "/old-build.drv" 3
@@ -591,105 +658,113 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0,
0, 0, 0);")
(test-equal "db-get-builds weather"
(build-weather new-success)
- (begin
+ (with-fibers
(assq-ref (db-get-build "/new-build.drv") #:weather)))
(test-assert "mail notification"
- (retry
- (lambda ()
- (and (file-exists? tmp-mail)
- (let ((str (call-with-input-file tmp-mail
- get-string-all)))
- (string-contains str "Build job-1 on guix is fixed."))))
- #:times 5
- #:delay 1))
+ (with-fibers
+ (retry
+ (lambda ()
+ (and (file-exists? tmp-mail)
+ (let ((str (call-with-input-file tmp-mail
+ get-string-all)))
+ (string-contains str "Build job-1 on guix is fixed."))))
+ #:times 5
+ #:delay 1)))
(test-equal "db-get-builds weather"
(build-weather new-failure)
- (begin
+ (with-fibers
(db-update-build-status! "/old-build.drv" 0)
(db-update-build-status! "/new-build.drv" 1)
(assq-ref (db-get-build "/new-build.drv") #:weather)))
(test-assert "mail notification"
- (retry
- (lambda ()
- (and (file-exists? tmp-mail)
- (let ((str (call-with-input-file tmp-mail
- get-string-all)))
- (string-contains str "Build job-1 on guix is broken."))))
- #:times 5
- #:delay 1))
+ (with-fibers
+ (retry
+ (lambda ()
+ (and (file-exists? tmp-mail)
+ (let ((str (call-with-input-file tmp-mail
+ get-string-all)))
+ (string-contains str "Build job-1 on guix is broken."))))
+ #:times 5
+ #:delay 1)))
(test-equal "db-get-builds weather"
(build-weather still-succeeding)
- (begin
+ (with-fibers
(db-update-build-status! "/old-build.drv" 0)
(db-update-build-status! "/new-build.drv" 0)
(assq-ref (db-get-build "/new-build.drv") #:weather)))
(test-equal "db-get-builds weather"
(build-weather still-failing)
- (begin
+ (with-fibers
(db-update-build-status! "/old-build.drv" 1)
(db-update-build-status! "/new-build.drv" 1)
(assq-ref (db-get-build "/new-build.drv") #:weather)))
(test-assert "db-restart-build!"
- (let ((build (db-get-build "/new-build.drv")))
- (db-restart-build! (assq-ref build #:id))
- (eq? (assq-ref (db-get-build "/new-build.drv") #:status)
- (build-status scheduled))))
+ (with-fibers
+ (let ((build (db-get-build "/new-build.drv")))
+ (db-restart-build! (assq-ref build #:id))
+ (eq? (assq-ref (db-get-build "/new-build.drv") #:status)
+ (build-status scheduled)))))
(test-assert "db-restart-evaluation!"
- (let ((build (db-get-build "/old-build.drv")))
- (db-restart-evaluation! (assq-ref build #:eval-id))
- (eq? (assq-ref (db-get-build "/old-build.drv") #:status)
- (build-status scheduled))))
+ (with-fibers
+ (let ((build (db-get-build "/old-build.drv")))
+ (db-restart-evaluation! (assq-ref build #:eval-id))
+ (eq? (assq-ref (db-get-build "/old-build.drv") #:status)
+ (build-status scheduled)))))
(test-assert "db-retry-evaluation!"
- (begin
+ (with-fibers
(db-retry-evaluation! 4)
(null? (db-get-checkouts 4))))
(test-assert "db-cancel-pending-builds!"
- (let* ((drv "/old-build.drv")
- (build (db-get-build drv))
- (eval-id (assq-ref build #:eval-id)))
- (db-update-build-status! drv (build-status started))
- (db-cancel-pending-builds! eval-id)
- (eq? (assq-ref (db-get-build drv) #:status)
- (build-status canceled))))
+ (with-fibers
+ (let* ((drv "/old-build.drv")
+ (build (db-get-build drv))
+ (eval-id (assq-ref build #:eval-id)))
+ (db-update-build-status! drv (build-status started))
+ (db-cancel-pending-builds! eval-id)
+ (eq? (assq-ref (db-get-build drv) #:status)
+ (build-status canceled)))))
(test-assert "db-push-notification"
- (let ((build (db-get-build "/new-build.drv")))
- (db-push-notification
- (email
- (from "from")
- (to "to")
- (server (mailer)))
- (assq-ref build #:id))))
+ (with-fibers
+ (let ((build (db-get-build "/new-build.drv")))
+ (db-push-notification
+ (email
+ (from "from")
+ (to "to")
+ (server (mailer)))
+ (assq-ref build #:id)))))
(test-assert "db-pop-notification"
- (let ((build (db-get-build "/new-build.drv")))
- (match (db-pop-notification)
- ((notif . notif-build)
- (and (email? notif)
- (equal? build notif-build))))))
+ (with-fibers
+ (let ((build (db-get-build "/new-build.drv")))
+ (match (db-pop-notification)
+ ((notif . notif-build)
+ (and (email? notif)
+ (equal? build notif-build)))))))
(test-assert "set-build-successful!"
- (let* ((name "/foo5.drv")
- (build
- (make-dummy-build name #:outputs `(("out" . ,(getcwd)))))
- (drv (assq-ref build #:derivation)))
- (db-add-build build)
- (set-build-successful! drv)
- (match (assq-ref (db-get-build name) #:buildproducts)
- ((product)
- (equal? (assq-ref product #:path) (getcwd))))))
+ (with-fibers
+ (let* ((name "/foo5.drv")
+ (build
+ (make-dummy-build name #:outputs `(("out" . ,(getcwd)))))
+ (drv (assq-ref build #:derivation)))
+ (db-add-build build)
+ (set-build-successful! drv)
+ (match (assq-ref (db-get-build name) #:buildproducts)
+ ((product)
+ (equal? (assq-ref product #:path) (getcwd)))))))
(test-assert "db-worker-current-builds"
- (begin
+ (with-fibers
(let ((drv-1
(db-add-build (make-dummy-build "/build-1.drv")))
(drv-2
@@ -706,16 +781,17 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0,
0, 0);")
(test-equal "db-register-dashboard"
"guix"
- (let ((id (db-register-dashboard "guix" "emacs")))
- (assq-ref (db-get-dashboard id) #:specification)))
+ (with-fibers
+ (let ((id (db-register-dashboard "guix" "emacs")))
+ (assq-ref (db-get-dashboard id) #:specification))))
(test-assert "db-add-build-dependencies"
- (begin
+ (with-fibers
(db-add-build-dependencies "/build-1.drv"
(list "/build-2.drv"))))
(test-assert "db-get-build-dependencies"
- (begin
+ (with-fibers
(let* ((drv1 "/build-1.drv")
(drv2 "/build-2.drv")
(id1 (assq-ref (db-get-build drv1) #:id))
@@ -724,7 +800,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0,
0);")
((id) (eq? id id2))))))
(test-assert "db-get-builds no-dependencies"
- (begin
+ (with-fibers
(db-update-build-status! "/build-1.drv"
(build-status scheduled))
(db-update-build-status! "/build-2.drv"
@@ -734,7 +810,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0,
0);")
"/build-2.drv")))
(test-assert "dependencies trigger"
- (begin
+ (with-fibers
(let ((drv-1
(db-add-build (make-dummy-build "/build-dep-1.drv")))
(drv-2
@@ -776,3 +852,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0,
0);")
(false-if-exception (delete-file tmp-mail))
(db-close (%db))
#t)))
+
+;; Local Variables:
+;; eval: (put 'with-fibers 'scheme-indent-function 0)
+;; End
- master updated (4a8a4bc -> 425ede1), Ludovic Courtès, 2023/05/31
- [no subject],
Ludovic Courtès <=
- [no subject], Ludovic Courtès, 2023/05/31
- [no subject], Ludovic Courtès, 2023/05/31
- [no subject], Ludovic Courtès, 2023/05/31
- [no subject], Ludovic Courtès, 2023/05/31
- [no subject], Ludovic Courtès, 2023/05/31