[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Wed, 6 Jan 2021 15:06:42 -0500 (EST) |
branch: wip-offload
commit 54367378ca9e00b4e0147f6d0dcf1981574a47d6
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Tue Jan 5 10:20:34 2021 +0100
Switch to PostegreSQL.
---
.dir-locals.el | 3 -
Makefile.am | 26 +-
README | 78 ++-
bin/cuirass.in | 171 +++--
build-aux/guix.scm | 6 +-
configure.ac | 2 +-
doc/cuirass.texi | 14 +-
src/cuirass/base.scm | 3 +-
src/cuirass/database.scm | 1567 +++++++++++++++++++++------------------------
src/cuirass/http.scm | 4 +-
src/cuirass/metrics.scm | 279 ++++----
src/cuirass/templates.scm | 2 +
src/cuirass/utils.scm | 74 +--
src/schema.sql | 64 +-
src/sql/upgrade-1.sql | 75 ---
src/sql/upgrade-10.sql | 12 -
src/sql/upgrade-11.sql | 11 -
src/sql/upgrade-12.sql | 7 -
src/sql/upgrade-13.sql | 5 -
src/sql/upgrade-14.sql | 5 -
src/sql/upgrade-15.sql | 7 -
src/sql/upgrade-16.sql | 5 -
src/sql/upgrade-17.sql | 5 -
src/sql/upgrade-18.sql | 10 -
src/sql/upgrade-19.sql | 11 -
src/sql/upgrade-2.sql | 49 --
src/sql/upgrade-3.sql | 46 --
src/sql/upgrade-4.sql | 18 -
src/sql/upgrade-5.sql | 15 -
src/sql/upgrade-6.sql | 47 --
src/sql/upgrade-7.sql | 15 -
src/sql/upgrade-8.sql | 7 -
src/sql/upgrade-9.sql | 9 -
tests/database.scm | 414 ++++++++----
tests/http.scm | 26 +-
tests/metrics.scm | 149 ++---
36 files changed, 1485 insertions(+), 1756 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index 0423a7e..b0223cc 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -13,9 +13,6 @@
(eval put 'test-error 'scheme-indent-function 1)
(eval put 'make-parameter 'scheme-indent-function 1)
(eval put 'with-database 'scheme-indent-function 0)
- (eval put 'with-queue-writer-worker 'scheme-indent-function 0)
- (eval put 'with-db-worker-thread 'scheme-indent-function 1)
- (eval put 'with-db-writer-worker-thread 'scheme-indent-function 1))
(texinfo-mode
(indent-tabs-mode)
(fill-column . 72)
diff --git a/Makefile.am b/Makefile.am
index 59d2c25..280ccae 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -79,25 +79,7 @@ nodist_webobject_DATA = \
dist_pkgdata_DATA = src/schema.sql
dist_sql_DATA = \
- src/sql/upgrade-1.sql \
- src/sql/upgrade-2.sql \
- src/sql/upgrade-3.sql \
- src/sql/upgrade-4.sql \
- src/sql/upgrade-5.sql \
- src/sql/upgrade-6.sql \
- src/sql/upgrade-7.sql \
- src/sql/upgrade-8.sql \
- src/sql/upgrade-9.sql \
- src/sql/upgrade-10.sql \
- src/sql/upgrade-11.sql \
- src/sql/upgrade-12.sql \
- src/sql/upgrade-13.sql \
- src/sql/upgrade-14.sql \
- src/sql/upgrade-15.sql \
- src/sql/upgrade-16.sql \
- src/sql/upgrade-17.sql \
- src/sql/upgrade-18.sql \
- src/sql/upgrade-19.sql
+ src/sql/upgrade-1.sql
dist_css_DATA = \
src/static/css/cuirass.css \
@@ -163,12 +145,6 @@ CLEANFILES = \
$(nodist_guileobject_DATA) \
src/cuirass/config.go
-.PHONY: sql-check
-sql-check: src/schema.sql
- @echo "$<"
- $(AM_V_at)sqlite3 tmp-$$$.db < $< ; \
- rm tmp-$$$.db
-
## -------------- ##
## Distribution. ##
## -------------- ##
diff --git a/README b/README
index 18aa37c..9758bbc 100644
--- a/README
+++ b/README
@@ -1,8 +1,8 @@
-Cuirass is a continuous integration tool using GNU Guix. It is intended as a
-replacement for Hydra.
+-*- mode: org -*-
-Requirements
-============
+Cuirass is a continuous integration tool using GNU Guix.
+
+* Requirements
Cuirass currently depends on the following packages:
@@ -10,7 +10,7 @@ Cuirass currently depends on the following packages:
- GNU Guix (and all its development dependencies)
- GNU Make
- Guile-JSON 3.x
- - Guile-SQLite3
+ - Guile-Squee
- Guile-Git
- Guile-zlib
- Fibers
@@ -18,52 +18,94 @@ Cuirass currently depends on the following packages:
A convenient way to install those dependencies is to install Guix and execute
the following command:
+#+BEGIN_EXAMPLE
$ guix environment -l build-aux/guix.scm
+#+END_EXAMPLE
This will build and enter an environment which provides all the necessary
dependencies.
-Build Instructions
-==================
+* Build Instructions
When all the dependencies are available on you system, in order to build and
install Cuirass, you can proceed with the usual:
+#+BEGIN_EXAMPLE
$ ./configure && sudo make install
+#+END_EXAMPLE
An alternative way is to directly install Cuirass in your Guix profile, using:
+#+BEGIN_EXAMPLE
$ guix package -f build-aux/guix.scm
+#+END_EXAMPLE
To build it, but not install it, run:
+#+BEGIN_EXAMPLE
$ guix build -f build-aux/guix.scm
+#+END_EXAMPLE
+
+* Database connection
+
+Cuirass uses PostgreSQL to store information about jobs, past build results
+and to coordinate the execution of jobs. The database connection string must
+be passed to Cuirass using the =database= argument, under the keyword/value
+format described
[[https://www.postgresql.org/docs/10/libpq-connect.html#LIBPQ-CONNSTRING][here]].
The PostgreSQL database must be created beforehand.
+
+For instance, to connect using Unix sockets to the =cuirass= database:
+
+#+BEGIN_EXAMPLE
+ ./pre-inst-env cuirass --database="dbname=cuirass host=/var/run/postgresql"
+#+END_EXAMPLE
+
+or using a TCP connection:
+
+#+BEGIN_EXAMPLE
+ ./pre-inst-env cuirass --database="dbname=cuirass host=127.0.0.1"
+#+END_EXAMPLE
+
+* Run tests
+
+Cuirass tests also require an access to a PostgreSQL database. This database
+must be dedicated to testing as its content will be dropped. The database
+name and host must be passed using =CUIRASS_DATABASE= and =CUIRASS_HOST=
+environment variables respectively.
+
+#+BEGIN_EXAMPLE
+CUIRASS_DATABASE="test_tmp" CUIRASS_HOST="/var/run/postgresql" make check
+#+END_EXAMPLE
-Example
-=======
+* Example
A quick way to manually test Cuirass is to execute:
- ./pre-inst-env cuirass --specifications=examples/hello-singleton.scm
--database=test.db
+#+BEGIN_EXAMPLE
+ ./pre-inst-env cuirass --specifications=examples/hello-singleton.scm
--database="dbname=cuirass host=/var/run/postgresql"
+#+END_EXAMPLE
-This will read the file "examples/hello-singleton.scm" which contains a list of
-specifications and add them to the database "test.db" which is created if it
-doesn't already exist.
+This will read the file "examples/hello-singleton.scm" which contains a list
+of specifications and add them to the =cuirass= database.
-'cuirass' then loops evaluating/building the specs. The database keeps track
+Cuirass then loops evaluating/building the specs. The database keeps track
of the specifications in order to allow users to accumulate specifications.
To resume the evaluation/build process you can execute the same command
without the '--specifications' option:
- ./pre-inst-env cuirass --database=test.db
+#+BEGIN_EXAMPLE
+ ./pre-inst-env cuirass --database="dbname=cuirass host=/var/run/postgresql"
+#+END_EXAMPLE
To start the web interface run:
- ./pre-inst-env cuirass --web
+#+BEGIN_EXAMPLE
+ ./pre-inst-env cuirass --database="dbname=cuirass host=/var/run/postgresql"
--web
+#+END_EXAMPLE
-Contributing
-============
+* Contributing
See the manual for useful hacking informations, by running
+#+BEGIN_EXAMPLE
info -f doc/cuirass.info "Contributing"
+#+END_EXAMPLE
diff --git a/bin/cuirass.in b/bin/cuirass.in
index 20c2447..81247cd 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -57,8 +57,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
-p --port=NUM Port of the HTTP server.
--listen=HOST Listen on the network interface for HOST
-I, --interval=N Wait N seconds between each poll
- -Q, --queue-size=N Set the writer queue size to N elements.
- --log-queries=FILE Log SQL queries in FILE.
--build-remote Use the remote build mechanism
--use-substitutes Allow usage of pre-built substitutes
--record-events Record events for distribution
@@ -77,12 +75,10 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(port (single-char #\p) (value #t))
(listen (value #t))
(interval (single-char #\I) (value #t))
- (queue-size (single-char #\Q) (value #t))
(build-remote (value #f))
(use-substitutes (value #f))
(threads (value #t))
(fallback (value #f))
- (log-queries (value #t))
(record-events (value #f))
(ttl (value #t))
(version (single-char #\V) (value #f))
@@ -110,9 +106,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(%fallback? (option-ref opts 'fallback #f))
(%record-events? (option-ref opts 'record-events #f))
(%gc-root-ttl
- (time-second (string->duration (option-ref opts 'ttl "30d"))))
- (%db-writer-queue-size
- (string->number (option-ref opts 'queue-size "1"))))
+ (time-second (string->duration (option-ref opts 'ttl "30d")))))
(cond
((option-ref opts 'help #f)
(show-help)
@@ -129,7 +123,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(host (option-ref opts 'listen "localhost"))
(interval (string->number (option-ref opts 'interval "300")))
(specfile (option-ref opts 'specifications #f))
- (queries-file (option-ref opts 'log-queries #f))
;; Since our work is mostly I/O-bound, default to a maximum of 4
;; kernel threads. Going beyond that can increase overhead (GC
@@ -140,95 +133,87 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(min (current-processor-count) 4))))
(prepare-git)
- (unless (option-ref opts 'web #f)
- (log-message "performing database optimizations")
- (db-optimize))
-
(log-message "running Fibers on ~a kernel threads" threads)
(run-fibers
(lambda ()
(with-database
- (with-queue-writer-worker
- (and specfile
- (let ((new-specs (save-module-excursion
- (lambda ()
- (set-current-module
- (make-user-module '()))
- (primitive-load specfile)))))
- (for-each db-add-specification new-specs)))
-
- (when queries-file
- (log-message "Enable SQL query logging.")
- (db-log-queries queries-file))
-
- (if one-shot?
- (process-specs (db-get-specifications))
- (let ((exit-channel (make-channel)))
- (start-watchdog)
- (if (option-ref opts 'web #f)
- (begin
- (spawn-fiber
- (essential-task
- 'web exit-channel
- (lambda ()
- (run-cuirass-server #:host host
- #:port port)))
- #:parallel? #t)
-
- (spawn-fiber
- (essential-task
- 'monitor exit-channel
- (lambda ()
- (while #t
- (log-monitoring-stats)
- (sleep 600))))))
-
- (begin
- (clear-build-queue)
-
- ;; If Cuirass was stopped during an evaluation,
- ;; abort it. Builds that were not registered
- ;; during this evaluation will be registered
- ;; during the next evaluation.
- (db-abort-pending-evaluations)
-
- ;; First off, restart builds that had not
- ;; completed or were not even started on a
- ;; previous run.
- (spawn-fiber
- (essential-task
- 'restart-builds exit-channel
- (lambda ()
- (restart-builds))))
-
- (spawn-fiber
- (essential-task
- 'build exit-channel
- (lambda ()
- (while #t
- (process-specs (db-get-specifications))
- (log-message
- "next evaluation in ~a seconds" interval)
- (sleep interval)))))
-
- (spawn-fiber
- (essential-task
- 'metrics exit-channel
- (lambda ()
- (while #t
- (with-time-logging
- "Metrics update"
- (db-update-metrics))
- (sleep 3600)))))
-
- (spawn-fiber
- (essential-task
- 'monitor exit-channel
- (lambda ()
- (while #t
- (log-monitoring-stats)
- (sleep 600)))))))
- (primitive-exit (get-message exit-channel)))))))
+ (and specfile
+ (let ((new-specs (save-module-excursion
+ (lambda ()
+ (set-current-module
+ (make-user-module '()))
+ (primitive-load specfile)))))
+
+ (for-each db-add-specification new-specs)))
+
+ (if one-shot?
+ (process-specs (db-get-specifications))
+ (let ((exit-channel (make-channel)))
+ (start-watchdog)
+ (if (option-ref opts 'web #f)
+ (begin
+ (spawn-fiber
+ (essential-task
+ 'web exit-channel
+ (lambda ()
+ (run-cuirass-server #:host host
+ #:port port)))
+ #:parallel? #t)
+
+ (spawn-fiber
+ (essential-task
+ 'monitor exit-channel
+ (lambda ()
+ (while #t
+ (log-monitoring-stats)
+ (sleep 600))))))
+
+ (begin
+ (clear-build-queue)
+
+ ;; If Cuirass was stopped during an evaluation,
+ ;; abort it. Builds that were not registered
+ ;; during this evaluation will be registered
+ ;; during the next evaluation.
+ (db-abort-pending-evaluations)
+
+ ;; First off, restart builds that had not
+ ;; completed or were not even started on a
+ ;; previous run.
+ (spawn-fiber
+ (essential-task
+ 'restart-builds exit-channel
+ (lambda ()
+ (restart-builds))))
+
+ (spawn-fiber
+ (essential-task
+ 'build exit-channel
+ (lambda ()
+ (while #t
+ (process-specs (db-get-specifications))
+ (log-message
+ "next evaluation in ~a seconds" interval)
+ (sleep interval)))))
+
+ (spawn-fiber
+ (essential-task
+ 'metrics exit-channel
+ (lambda ()
+ (while #t
+ (with-time-logging
+ "Metrics update"
+ (db-update-metrics))
+ (sleep 3600)))))
+
+ (spawn-fiber
+ (essential-task
+ 'monitor exit-channel
+ (lambda ()
+ (while #t
+ (log-monitoring-stats)
+ (sleep 600)))))))
+ (primitive-exit (get-message exit-channel))))))
;; Most of our code is I/O so preemption doesn't matter much (it
;; could help while we're doing SQL requests, for instance, but it
diff --git a/build-aux/guix.scm b/build-aux/guix.scm
index 2dbdd6e..b03f173 100644
--- a/build-aux/guix.scm
+++ b/build-aux/guix.scm
@@ -67,11 +67,11 @@
;; Wrap the 'cuirass' command to refer to the right modules.
(let* ((out (assoc-ref outputs "out"))
(json (assoc-ref inputs "guile-json"))
- (sqlite (assoc-ref inputs "guile-sqlite3"))
+ (squee (assoc-ref inputs "guile-squee"))
(zlib (assoc-ref inputs "guile-zlib"))
(guix (assoc-ref inputs "guix"))
(mods (string-append json "/share/guile/site/3.0:"
- sqlite "/share/guile/site/3.0:"
+ squee "/share/guile/site/3.0:"
zlib "/share/guile/site/3.0:"
guix "/share/guile/site/3.0")))
(wrap-program (string-append out "/bin/cuirass")
@@ -82,7 +82,7 @@
'("guile"
"guile-fibers"
"guile-json"
- "guile-sqlite3"
+ "guile-squee"
"guile-git"
"guile-zlib"
"guix")))
diff --git a/configure.ac b/configure.ac
index 159e9fe..4bbb2f3 100644
--- a/configure.ac
+++ b/configure.ac
@@ -47,7 +47,7 @@ GUILE_MODULE_REQUIRED([guix])
GUILE_MODULE_REQUIRED([guix git])
GUILE_MODULE_REQUIRED([git])
GUILE_MODULE_REQUIRED([json])
-GUILE_MODULE_REQUIRED([sqlite3])
+GUILE_MODULE_REQUIRED([squee])
GUILE_MODULE_REQUIRED([fibers])
GUILE_MODULE_REQUIRED([zlib])
diff --git a/doc/cuirass.texi b/doc/cuirass.texi
index 00baf4a..75bbd84 100644
--- a/doc/cuirass.texi
+++ b/doc/cuirass.texi
@@ -173,7 +173,7 @@ Currently the only way to add those specifications to
cuirass is to put
a list of them in a file and set the @code{--specifications} command
line option argument with the file name when launching the daemon
(@pxref{Invocation}). The specifications are persistent (they are kept
-in a SQLite database) so the next time @command{cuirass} is run the
+in a PostgreSQL database) so the next time @command{cuirass} is run the
previously added specifications will remain active even if you don't
keep the @code{--specifications} option.
@@ -209,9 +209,9 @@ database before launching the evaluation and build
processes.
@item --database=@var{database}
@itemx -D @var{database}
Use @var{database} as the database containing the jobs and the past
-build results. Since @code{cuirass} uses SQLite as a database engine,
-@var{database} must be a file name. If the file doesn't exist, it will
-be created.
+build results. Since @code{cuirass} uses PostgreSQL as a database
+engine, @var{database} must be a file name. If the file doesn't exist,
+it will be created.
@item --ttl=@var{duration}
Cuirass registers build results as garbage collector (GC) roots, thereby
@@ -263,11 +263,11 @@ Display an help message that summarize all the options
provided.
@node Database
@chapter Database schema
@cindex cuirass database
-@cindex sqlite database
+@cindex postgresql database
@cindex persistent configuration
-Cuirass uses a SQLite database to store information about jobs and past
-build results, but also to coordinate the execution of jobs.
+Cuirass uses a PostgreSQL database to store information about jobs and
+past build results, but also to coordinate the execution of jobs.
The database contains the following tables: @code{Specifications},
@code{Inputs}, @code{Checkouts}, @code{Evaluations}, @code{Builds} and
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index b074f4f..d74a807 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -636,8 +636,7 @@ updating the database accordingly."
"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\"...")
- (with-db-worker-thread db
- (sqlite-exec db "UPDATE Builds SET status = -2 WHERE status = -1;")))
+ (db-clear-build-queue))
(define (restart-builds)
"Restart builds whose status in the database is \"pending\" (scheduled or
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 236f192..701c927 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -26,6 +26,7 @@
#:use-module (cuirass config)
#:use-module (cuirass remote)
#:use-module (cuirass utils)
+ #:use-module (squee)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 ftw)
@@ -37,160 +38,175 @@
#:use-module (srfi srfi-26)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
- #:use-module (sqlite3)
#:export (;; Procedures.
db-init
db-open
db-close
- db-optimize
- db-log-queries
+ exec-query/bind-params
+ expect-one-row
+ read-sql-file
+ db-add-input
+ db-add-checkout
db-add-specification
db-remove-specification
+ db-get-inputs
db-get-specification
db-get-specifications
evaluation-status
- last-insert-rowid
- expect-one-row
db-add-evaluation
db-abort-pending-evaluations
db-set-evaluation-status
db-set-evaluation-time
- db-get-pending-derivations
build-status
+ db-add-output
db-add-build
db-add-build-product
+ db-get-output
+ db-get-outputs
+ db-get-time-since-previous-build
db-register-builds
db-update-build-status!
db-update-build-worker!
- db-get-output
- db-get-inputs
- db-get-build
- db-get-builds
- db-get-time-since-previous-build
+ db-get-build-products
db-get-builds-by-search
- db-get-builds-min
- db-get-builds-max
- db-get-builds-query-min
- db-get-builds-query-max
- db-add-event
+ db-get-builds
+ db-get-build
db-get-events
db-delete-events-with-ids-<=-to
+ db-get-pending-derivations
+ db-get-checkouts
db-get-evaluation
db-get-evaluations
db-get-evaluations-build-summary
db-get-evaluations-id-min
db-get-evaluations-id-max
+ db-get-evaluation-summary
+ db-get-builds-query-min
+ db-get-builds-query-max
+ db-get-builds-min
+ db-get-builds-max
db-get-evaluation-specification
db-get-build-product-path
- db-get-build-products
db-add-worker
db-get-workers
db-clear-workers
- db-get-evaluation-summary
- db-get-checkouts
- read-sql-file
- read-quoted-string
- %sqlite-exec
- sqlite-exec
- catch-sqlite-error
- ;; Constants.
- SQLITE_CONSTRAINT_PRIMARYKEY
- SQLITE_CONSTRAINT_UNIQUE
- SQLITE_BUSY_SNAPSHOT
+ db-clear-build-queue
;; Parameters.
%package-database
%package-schema-file
%db-channel
- %db-writer-channel
%record-events?
- %db-writer-queue-size
;; Macros.
- with-db-worker-thread
- with-db-writer-worker-thread
- with-db-writer-worker-thread/force
+ exec-query/bind
with-database
- with-queue-writer-worker))
+ with-db-worker-thread))
;; Maximum priority for a Build or Specification.
(define max-priority 9)
-(define (%sqlite-exec db sql . args)
- "Evaluate the given SQL query with the given ARGS. Return the list of
-rows."
- (define (normalize arg)
- ;; Turn ARG into a string, unless it's a primitive SQL datatype.
- (if (or (null? arg) (pair? arg) (vector? arg))
- (object->string arg)
- arg))
-
- (let ((stmt (sqlite-prepare db sql #:cache? #t)))
- (for-each (lambda (arg index)
- (sqlite-bind stmt index (normalize arg)))
- args (iota (length args) 1))
- (let ((result (sqlite-fold-right cons '() stmt)))
- (sqlite-reset stmt)
- result)))
-
-(define-syntax sqlite-exec/bind
+(define (%exec-query db query args)
+ (exec-query db query args))
+
+(define (normalize obj)
+ (if (string? obj)
+ obj
+ (and obj (object->string obj))))
+
+(define-syntax %exec-query/bind
(lambda (s)
- ;; Expand to an '%sqlite-exec' call where the query string has
+ ;; Expand to an 'exec-query' call where the query string has
;; interspersed question marks and the argument list is separate.
(define (string-literal? s)
(string? (syntax->datum s)))
+ (define (interleave a b)
+ (if (null? b)
+ (list (car a))
+ `(,(car a) ,(car b) ,@(interleave (cdr a) (cdr b)))))
+
+ (define (interleave-arguments str)
+ (string-join
+ (interleave str
+ (map (lambda (i)
+ (string-append "$"
+ (number->string (1+ i))))
+ (iota (1- (length str)))))
+ " "))
+
(syntax-case s ()
((_ db (bindings ...) tail str arg rest ...)
- #'(sqlite-exec/bind db
+ #'(%exec-query/bind db
(bindings ... (str arg))
tail
rest ...))
((_ db (bindings ...) tail str)
- #'(sqlite-exec/bind db (bindings ...) str))
+ #'(%exec-query/bind db (bindings ...) str))
((_ db ((strings args) ...) tail)
- (and (every string-literal? #'(strings ...))
- (string-literal? #'tail))
;; Optimized case: only string literals.
- (with-syntax ((query (string-join
- (append (syntax->datum #'(strings ...))
- (list (syntax->datum #'tail)))
- "? ")))
- #'(%sqlite-exec db query args ...)))
- ((_ db ((strings args) ...) tail)
- ;; Fallback case: some of the strings aren't literals.
- #'(%sqlite-exec db (string-join (list strings ... tail) "? ")
- args ...)))))
-
-(define-syntax-rule (sqlite-exec db query args ...)
- "Execute the specific QUERY with the given ARGS. Uses of 'sqlite-exec'
+ (with-syntax ((query
+ (interleave-arguments
+ (append (syntax->datum #'(strings ...))
+ (list (syntax->datum #'tail))))))
+ #'(%exec-query db query (map normalize (list args ...))))))))
+
+(define-syntax-rule (exec-query/bind db query args ...)
+ "Execute the specific QUERY with the given ARGS. Uses of 'exec-query/bind'
typically look like this:
- (sqlite-exec db \"SELECT * FROM Foo WHERE x = \"
- x \"AND Y=\" y \";\")
+ (exec-query/bind db \"SELECT * FROM Foo WHERE x = \" x \"AND Y=\" y \";\")
-References to variables 'x' and 'y' here are replaced by question marks in the
-SQL query, and then 'sqlite-bind' is used to bind them.
+References to variables 'x' and 'y' here are replaced by $1 and $2 in the
+SQL query.
This ensures that (1) SQL injection is impossible, and (2) the number of
-question marks matches the number of arguments to bind."
- (sqlite-exec/bind db () "" query args ...))
-
-(define-syntax catch-sqlite-error
- (syntax-rules (on =>)
- "Run EXP..., catching SQLite error and handling the given code as
-specified."
- ((_ exp ... (on error => handle ...))
- (catch 'sqlite-error
- (lambda ()
- exp ...)
- (lambda (key who code message . rest)
- (if (= code error)
- (begin handle ...)
- (apply throw key who code message rest)))))))
+parameters matches the number of arguments to bind."
+ (%exec-query/bind db () "" query args ...))
+
+(define (exec-query/bind-params db query params)
+ (define param-regex
+ (make-regexp ":[a-zA-Z]+"))
+
+ (define (argument-indexes arguments)
+ (let loop ((res '())
+ (bindings '())
+ (counter 1)
+ (arguments arguments))
+ (if (null? arguments)
+ (reverse res)
+ (let* ((arg (car arguments))
+ (index (assoc-ref bindings arg)))
+ (if index
+ (loop (cons index res)
+ bindings
+ counter
+ (cdr arguments))
+ (loop (cons counter res)
+ `((,arg . ,counter) ,@bindings)
+ (1+ counter)
+ (cdr arguments)))))))
+
+ (let* ((args
+ (reverse
+ (fold-matches param-regex query
+ '() (lambda (m p)
+ (cons (match:substring m) p)))))
+ (indexes (argument-indexes args))
+ (proc (lambda (m)
+ (let ((index (car indexes)))
+ (set! indexes (cdr indexes))
+ (string-append "$" (number->string index)))))
+ (query (regexp-substitute/global #f param-regex query
+ 'pre proc 'post))
+ (params (map (lambda (arg)
+ (let ((symbol
+ (symbol->keyword
+ (string->symbol (substring arg 1)))))
+ (assoc-ref params symbol)))
+ (delete-duplicates args))))
+ (exec-query db query (map normalize params))))
(define %package-database
- ;; Define to the database file name of this package.
- (make-parameter (string-append %localstatedir "/lib/" %package
- "/" %package ".db")))
+ (make-parameter #f))
(define %package-schema-file
;; Define to the database schema file of this package.
@@ -207,14 +223,20 @@ specified."
(define %db-channel
(make-parameter #f))
-(define %db-writer-channel
- (make-parameter #f))
-
(define %record-events?
(make-parameter #f))
-(define %db-writer-queue-size
- (make-parameter #f))
+(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.
@@ -241,27 +263,6 @@ This must only be used for reading queries, i.e SELECT
queries."
(number->string receive-timeout)
caller-name))))))
-(define-syntax with-db-writer-worker-thread
- (syntax-rules ()
- "Similar to WITH-DB-WORKER-THREAD but evaluates EXP in a database worker
-dedicated to writing. EXP evaluation is deferred and will only be run once
-the worker evaluation queue in full. To force an immediate evaluation the
-#:FORCE? option or the alias below may be used. This macro is reserved for
-writing queries, i.e CREATE, DELETE, DROP, INSERT, or UPDATE queries."
- ((_ db #:force? force exp ...)
- (call-with-worker-thread
- (%db-writer-channel)
- (lambda (db) exp ...)
- #:options `((#:force? . ,force))))
- ((_ db exp ...)
- (with-db-writer-worker-thread db #:force? #f exp ...))))
-
-(define-syntax with-db-writer-worker-thread/force
- (syntax-rules ()
- "Alias for WITH-DB-WRITER-WORKER-THREAD with FORCE? option set."
- ((_ db exp ...)
- (with-db-writer-worker-thread db #:force? #t exp ...))))
-
(define (read-sql-file file-name)
"Return a list of string containing SQL instructions from FILE-NAME."
(call-with-input-file file-name
@@ -274,42 +275,30 @@ writing queries, i.e CREATE, DELETE, DROP, INSERT, or
UPDATE queries."
(reverse! insts)
(loop (cons inst insts))))))))
-(define (set-db-options db)
- "Set various options for DB and return it."
-
- ;; Turn DB in "write-ahead log" mode and return it.
- (sqlite-exec db "PRAGMA journal_mode=WAL;")
-
- ;; Install a busy handler such that, when the database is locked, sqlite
- ;; retries until 30 seconds have passed, at which point it gives up and
- ;; throws SQLITE_BUSY. This is useful when we have several fibers or
- ;; threads accessing the database concurrently.
- ;;(sqlite-busy-timeout db (* 30 1000))
- (sqlite-exec db "PRAGMA busy_timeout = 30000;")
-
- ;; The want to prioritize read operations over write operations as we can
- ;; have a large number of clients, while the number of write operations is
- ;; modest. Use a small WAL journal to do that, and try to reduce disk I/O
- ;; by increasing RAM usage as described here:
- ;;
https://wiki.mozilla.org/Performance/Avoid_SQLite_In_Your_Next_Firefox_Feature
- (sqlite-exec db "PRAGMA wal_autocheckpoint = 16;")
- (sqlite-exec db "PRAGMA journal_size_limit = 1536;")
- (sqlite-exec db "PRAGMA page_size = 32768;")
- (sqlite-exec db "PRAGMA cache_size = -500000;")
- (sqlite-exec db "PRAGMA temp_store = MEMORY;")
- (sqlite-exec db "PRAGMA synchronous = NORMAL;")
- db)
+(define (expect-one-row rows)
+ "Several SQL queries expect one result, or zero if not found. This gets rid
+of the list, and returns #f when there is no result."
+ (match rows
+ ((row) row)
+ (() #f)))
(define (db-load db schema)
"Evaluate the file SCHEMA, which may contain SQL queries, into DB."
- (for-each (cut sqlite-exec db <>)
+ (for-each (cut exec-query db <>)
(read-sql-file schema)))
(define (db-schema-version db)
- (vector-ref (car (sqlite-exec db "PRAGMA user_version;")) 0))
+ (catch 'psql-query-error
+ (lambda ()
+ (match (expect-one-row
+ (exec-query db "SELECT version FROM SchemaVersion"))
+ ((version) (string->number version))))
+ (lambda _ #f)))
(define (db-set-schema-version db version)
- (sqlite-exec db (format #f "PRAGMA user_version = ~d;" version)))
+ (exec-query db "DELETE FROM SchemaVersion")
+ (exec-query/bind db "INSERT INTO SchemaVersion (version) VALUES
+ (" version ")"))
(define (latest-db-schema-version)
"Return the version to which the schema should be upgraded, based on the
@@ -319,19 +308,14 @@ upgrade-n.sql files, or 0 if there are no such files."
(filter-map (cut string-match "^upgrade-([0-9]+)\\.sql$" <>)
(or (scandir (%package-sql-dir)) '())))))
-(define* (db-init #:optional (db-name (%package-database))
- #:key (schema (%package-schema-file)))
+(define* (db-init db
+ #:key
+ (schema (%package-schema-file)))
"Open the database to store and read jobs and builds informations. Return a
database object."
- (when (file-exists? db-name)
- (format (current-error-port) "Removing leftover database ~a~%" db-name)
- (delete-file db-name))
- (let ((db (sqlite-open db-name (logior SQLITE_OPEN_CREATE
- SQLITE_OPEN_READWRITE
- SQLITE_OPEN_NOMUTEX))))
- (db-load db schema)
- (db-set-schema-version db (latest-db-schema-version))
- db))
+ (db-load db schema)
+ (db-set-schema-version db (latest-db-schema-version))
+ db)
(define (schema-upgrade-file version)
"Return the file containing the SQL instructions that upgrade the schema
@@ -348,144 +332,107 @@ upgrade-n.sql files."
(iota (- (latest-db-schema-version) current) (1+ current))))
db)
-(define* (db-open #:optional (db (%package-database)))
+(define* (db-open #:key
+ (database (%package-database)))
"Open database to store or read jobs and builds informations. Return a
database object."
- ;; Use "write-ahead log" mode because it improves concurrency and should
- ;; avoid SQLITE_LOCKED errors when we have several readers:
- ;; <https://www.sqlite.org/wal.html>.
-
- ;; SQLITE_OPEN_NOMUTEX disables mutexing on database connection and prepared
- ;; statement objects, thus making us responsible for serializing access to
- ;; database connections and prepared statements.
- (set-db-options (if (file-exists? db)
- (db-upgrade
- (sqlite-open db (logior SQLITE_OPEN_READWRITE
- SQLITE_OPEN_NOMUTEX)))
- (db-init db))))
+ (let* ((param (or database
+ (format #f "dbname=~a host=~a"
+ (getenv "CUIRASS_DATABASE")
+ (getenv "CUIRASS_HOST"))))
+ (db (connect-to-postgres-paramstring param)))
+ (match (db-schema-version db)
+ (#f
+ (db-init db))
+ (else
+ (db-upgrade db)))))
(define (db-close db)
"Close database object DB."
- (sqlite-close db))
-
-(define* (db-optimize #:optional (db-file (%package-database)))
- "Open the database and perform optimizations."
- (let ((db (db-open db-file)))
- (sqlite-exec db "PRAGMA optimize;")
- (sqlite-exec db "PRAGMA wal_checkpoint(TRUNCATE);")
- (db-close db)))
-
-(define (trace-callback trace p x)
- (log-query (pointer->string
- (sqlite-expanded-sql p))
- (make-time 'time-duration
- (bytevector-uint-ref
- (pointer->bytevector x (sizeof uint64))
- 0 (native-endianness)
- (sizeof uint64))
- 0)))
-
-(define (db-log-queries file)
- (with-db-worker-thread db
- (query-logging-port (open-output-file file))
- (sqlite-trace db SQLITE_TRACE_PROFILE trace-callback)))
-
-(define (last-insert-rowid db)
- (vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
- 0))
-
-(define (changes-count db)
- "The number of database rows that were changed or inserted or deleted by the
-most recently completed INSERT, DELETE, or UPDATE statement."
- (vector-ref (car (sqlite-exec db "SELECT changes();"))
- 0))
-
-(define (expect-one-row rows)
- "Several SQL queries expect one result, or zero if not found. This gets rid
-of the list, and returns #f when there is no result."
- (match rows
- ((row) row)
- (() #f)))
+ (pg-conn-finish db))
(define (db-add-input spec-name input)
- (with-db-writer-worker-thread/force db
- (sqlite-exec db "\
-INSERT OR IGNORE INTO Inputs (specification, name, url, load_path, branch, \
+ (with-db-worker-thread db
+ (exec-query/bind db "\
+INSERT 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) ");")))
+ 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) ")
+ON CONFLICT ON CONSTRAINT inputs_pkey DO NOTHING;")))
(define (db-add-checkout spec-name eval-id checkout)
"Insert CHECKOUT associated with SPEC-NAME and EVAL-ID. If a checkout with
the same revision already exists for SPEC-NAME, return #f."
- (with-db-writer-worker-thread/force db
- (catch-sqlite-error
- (sqlite-exec db "\
+ (with-db-worker-thread db
+ (match (expect-one-row
+ (exec-query/bind db "\
INSERT INTO Checkouts (specification, revision, evaluation, input,
directory, timestamp) VALUES ("
- spec-name ", "
- (assq-ref checkout #:commit) ", "
- eval-id ", "
- (assq-ref checkout #:input) ", "
- (assq-ref checkout #:directory) ", "
- (or (assq-ref checkout #:timestamp) 0) ");")
- (last-insert-rowid db)
-
- ;; If we get a unique-constraint-failed error, that means we have
- ;; already inserted the same checkout. That happens for each input
- ;; that doesn't change between two evaluations.
- (on SQLITE_CONSTRAINT_PRIMARYKEY => #f))))
+ spec-name ", "
+ (assq-ref checkout #:commit) ", "
+ eval-id ", "
+ (assq-ref checkout #:input) ", "
+ (assq-ref checkout #:directory) ", "
+ (or (assq-ref checkout #:timestamp) 0) ")
+ON CONFLICT ON CONSTRAINT checkouts_pkey DO NOTHING
+RETURNING (specification, revision);"))
+ (x x)
+ (() #f))))
(define (db-add-specification spec)
"Store SPEC in database the database. SPEC inputs are stored in the INPUTS
table."
- (with-db-writer-worker-thread/force db
- (sqlite-exec db "\
-INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \
+ (with-db-worker-thread db
+ (match (expect-one-row
+ (exec-query/bind db "\
+INSERT INTO Specifications (name, load_path_inputs, \
package_path_inputs, proc_input, proc_file, proc, proc_args, \
build_outputs, priority) \
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) ", "
- (assq-ref spec #:build-outputs) ", "
- (or (assq-ref spec #:priority) max-priority) ");")
- (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)))
+ (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) ", "
+ (assq-ref spec #:build-outputs) ", "
+ (or (assq-ref spec #:priority) max-priority) ")
+ON CONFLICT ON CONSTRAINT specifications_pkey DO NOTHING
+RETURNING name;"))
+ ((name)
+ (for-each (lambda (input)
+ (db-add-input (assq-ref spec #:name) input))
+ (assq-ref spec #:inputs))
+ name)
+ (else #f))))
(define (db-remove-specification name)
"Remove the specification matching NAME from the database and its inputs."
- (with-db-writer-worker-thread/force db
- (sqlite-exec db "BEGIN TRANSACTION;")
- (sqlite-exec db "\
+ (with-db-worker-thread db
+ (exec-query db "BEGIN TRANSACTION;")
+ (exec-query/bind db "\
DELETE FROM Inputs WHERE specification=" name ";")
- (sqlite-exec db "\
+ (exec-query/bind db "\
DELETE FROM Specifications WHERE name=" name ";")
- (sqlite-exec db "COMMIT;")))
+ (exec-query db "COMMIT;")))
(define (db-get-inputs spec-name)
(with-db-worker-thread db
- (let loop ((rows (sqlite-exec
+ (let loop ((rows (exec-query/bind
db "SELECT * FROM Inputs WHERE specification="
- spec-name ";"))
+ spec-name "ORDER BY name;"))
(inputs '()))
(match rows
- (() inputs)
- ((#(specification name url load-path branch tag revision no-compile-p)
- . rest)
+ (() (reverse inputs))
+ (((specification name url load-path branch tag revision no-compile-p)
+ . rest)
(loop rest
(cons `((#:name . ,name)
(#:url . ,url)
@@ -493,43 +440,43 @@ DELETE FROM Specifications WHERE name=" name ";")
(#:branch . ,branch)
(#:tag . ,tag)
(#:commit . ,revision)
- (#:no-compile? . ,(positive? no-compile-p)))
+ (#:no-compile? . ,(positive?
+ (string->number no-compile-p))))
inputs)))))))
(define (db-get-specification name)
"Retrieve a specification in the database with the given NAME."
- (with-db-worker-thread db
- (expect-one-row (db-get-specifications name))))
+ (expect-one-row (db-get-specifications name)))
(define* (db-get-specifications #:optional name)
(with-db-worker-thread db
(let loop
((rows (if name
- (sqlite-exec db "
+ (exec-query/bind db "
SELECT * FROM Specifications WHERE name =" name ";")
- (sqlite-exec db "
-SELECT * FROM Specifications ORDER BY name DESC;")))
+ (exec-query db "
+SELECT * FROM Specifications ORDER BY name ASC;")))
(specs '()))
- (match rows
- (() specs)
- ((#(name load-path-inputs package-path-inputs proc-input proc-file
proc
- proc-args build-outputs priority)
- . 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))
- (#:build-outputs .
- ,(with-input-from-string build-outputs read))
- (#:priority . ,priority))
- specs)))))))
+ (match rows
+ (() (reverse specs))
+ (((name load-path-inputs package-path-inputs proc-input proc-file proc
+ proc-args build-outputs priority)
+ . 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))
+ (#:build-outputs .
+ ,(with-input-from-string build-outputs read))
+ (#:priority . ,(string->number priority)))
+ specs)))))))
(define-enumeration evaluation-status
(started -1)
@@ -537,6 +484,17 @@ SELECT * FROM Specifications ORDER BY name DESC;")))
(failed 1)
(aborted 2))
+(define (db-add-event type timestamp details)
+ (with-db-worker-thread db
+ (when (%record-events?)
+ (exec-query/bind db "\
+INSERT INTO Events (type, timestamp, event_json) VALUES ("
+ (symbol->string type) ", "
+ timestamp ", "
+ (object->json-string details)
+ ");")
+ #t)))
+
(define* (db-add-evaluation spec-name checkouts
#:key
(checkouttime 0)
@@ -547,99 +505,49 @@ Otherwise, return #f."
(define now
(or timestamp (time-second (current-time time-utc))))
- (with-db-writer-worker-thread/force db
- (sqlite-exec db "BEGIN TRANSACTION;")
- (sqlite-exec db "INSERT INTO Evaluations (specification, status,
-timestamp, checkouttime, evaltime)
+ (with-db-worker-thread db
+ (exec-query db "BEGIN TRANSACTION;")
+ (let* ((eval-id
+ (match (expect-one-row
+ (exec-query/bind db "\
+INSERT INTO Evaluations (specification, status, timestamp,
+checkouttime, evaltime)
VALUES (" spec-name "," (evaluation-status started) ","
-now "," checkouttime "," evaltime ");")
- (let* ((eval-id (last-insert-rowid db))
+now "," checkouttime "," evaltime ")
+RETURNING id;"))
+ ((id) (string->number id))))
(new-checkouts (filter-map
(cut db-add-checkout spec-name eval-id <>)
checkouts)))
(if (null? new-checkouts)
- (begin (sqlite-exec db "ROLLBACK;")
+ (begin (exec-query db "ROLLBACK;")
#f)
(begin (db-add-event 'evaluation
(time-second (current-time time-utc))
`((#:evaluation . ,eval-id)
(#:specification . ,spec-name)
(#:in_progress . #t)))
- (sqlite-exec db "COMMIT;")
+ (exec-query db "COMMIT;")
eval-id)))))
(define (db-abort-pending-evaluations)
- (with-db-writer-worker-thread/force db
- (sqlite-exec db "UPDATE Evaluations SET status =
+ (with-db-worker-thread db
+ (exec-query/bind db "UPDATE Evaluations SET status =
" (evaluation-status aborted) " WHERE status = "
(evaluation-status started))))
(define (db-set-evaluation-status eval-id status)
- (with-db-writer-worker-thread/force db
- (sqlite-exec db "UPDATE Evaluations SET status =
+ (with-db-worker-thread db
+ (exec-query/bind db "UPDATE Evaluations SET status =
" status " WHERE id = " eval-id ";")))
(define (db-set-evaluation-time eval-id)
(define now
(time-second (current-time time-utc)))
- (with-db-writer-worker-thread/force
- db
- (sqlite-exec db "UPDATE Evaluations SET evaltime = " now
- "WHERE id = " eval-id ";")))
-
-(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) 4))))
- body ...))
-
-(define-syntax-rule (with-queue-writer-worker body ...)
- "Run BODY with %DB-WRITER-CHANNEL being dynamically bound to a channel
-providing a worker thread that allow database write operations to run
-without interfering with fibers.
-
-The worker will queue write operations and run them in a single transaction
-when the queue is full. As write operations are exclusive in SQLite, do not
-allocate more than one worker."
- (parameterize ((%db-writer-channel
- (make-worker-thread-channel
- (lambda ()
- (list (db-open)))
- #:parallelism 1
- #:queue-size (%db-writer-queue-size)
- #:queue-proc
- (lambda (db run-queue)
- (sqlite-exec db "BEGIN TRANSACTION;")
- (run-queue)
- (sqlite-exec db "COMMIT;")))))
- body ...))
-
-(define* (read-quoted-string #:optional (port (current-input-port)))
- "Read all of the characters out of PORT and return them as a SQL quoted
-string."
- (let loop ((chars '()))
- (let ((char (read-char port)))
- (cond ((eof-object? char) (list->string (reverse! chars)))
- ((char=? char #\') (loop (cons* char char chars)))
- (else (loop (cons char chars)))))))
-
-;; Extended error codes (see <sqlite3.h>).
-;; XXX: This should be defined by (sqlite3).
-(define SQLITE_BUSY 5)
-(define SQLITE_CONSTRAINT 19)
-(define SQLITE_CONSTRAINT_PRIMARYKEY
- (logior SQLITE_CONSTRAINT (ash 6 8)))
-(define SQLITE_CONSTRAINT_UNIQUE
- (logior SQLITE_CONSTRAINT (ash 8 8)))
-(define SQLITE_BUSY_SNAPSHOT
- (logior SQLITE_BUSY (ash 2 8)))
+ (with-db-worker-thread db
+ (exec-query/bind db "UPDATE Evaluations SET evaltime = " now
+ "WHERE id = " eval-id ";")))
(define-enumeration build-status
;; Build status as expected by Hydra's API. Note: the negative values are
@@ -654,70 +562,104 @@ string."
(canceled 4))
(define (db-add-output derivation output)
- "Insert OUTPUT associated with DERIVATION. If an output with the same path
-already exists, return #f."
- (with-db-writer-worker-thread/force db
- (catch-sqlite-error
- (match output
- ((name . path)
- (sqlite-exec db "\
+ "Insert OUTPUT associated with DERIVATION."
+ (with-db-worker-thread db
+ (match output
+ ((name . path)
+ (exec-query/bind db "\
INSERT INTO Outputs (derivation, name, path) VALUES ("
- derivation ", " name ", " path ");")))
- (last-insert-rowid db)
-
- ;; If we get a unique-constraint-failed error, that means we have
- ;; already inserted the same output. That happens with fixed-output
- ;; derivations.
- (on SQLITE_CONSTRAINT_PRIMARYKEY => #f))))
+ derivation ", " name ", " path ")
+ON CONFLICT ON CONSTRAINT outputs_pkey DO NOTHING;")))))
(define (db-add-build build)
"Store BUILD in database the database only if one of its outputs is new.
Return #f otherwise. BUILD outputs are stored in the OUTPUTS table."
- (with-db-writer-worker-thread/force db
- (sqlite-exec db "
+ (with-db-worker-thread db
+ (exec-query/bind db "
INSERT INTO Builds (derivation, evaluation, job_name, system, nix_name, log,
status, priority, max_silent, timeout, 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)) ", "
- (assq-ref build #:priority) ", "
- (or (assq-ref build #:max-silent) 0) ", "
- (or (assq-ref build #:timeout) 0) ", "
- (or (assq-ref build #:timestamp) 0) ", "
- (or (assq-ref build #:starttime) 0) ", "
- (or (assq-ref build #:stoptime) 0) ");")
- (let* ((derivation (assq-ref build #:derivation))
- (outputs (assq-ref build #:outputs))
- (new-outputs (filter-map (cut db-add-output derivation <>)
- outputs)))
- (db-add-event 'build
- (assq-ref build #:timestamp)
- `((#:derivation . ,(assq-ref build #:derivation))
- ;; TODO Ideally this would use the value
- ;; from build, with a default of scheduled,
- ;; but it's hard to convert to the symbol,
- ;; so just hard code scheduled for now.
- (#:event . scheduled)))
- derivation)))
+ (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 #:priority) max-priority) ", "
+ (or (assq-ref build #:max-silent) 0) ", "
+ (or (assq-ref build #:timeout) 0) ", "
+ (or (assq-ref build #:timestamp) 0) ", "
+ (or (assq-ref build #:starttime) 0) ", "
+ (or (assq-ref build #:stoptime) 0) ")
+ON CONFLICT ON CONSTRAINT builds_derivation_key DO NOTHING;"))
+ (let* ((derivation (assq-ref build #:derivation))
+ (outputs (assq-ref build #:outputs))
+ (new-outputs (filter-map (cut db-add-output derivation <>)
+ outputs)))
+ (db-add-event 'build
+ (assq-ref build #:timestamp)
+ `((#:derivation . ,derivation)
+ ;; TODO Ideally this would use the value
+ ;; from build, with a default of scheduled,
+ ;; but it's hard to convert to the symbol,
+ ;; so just hard code scheduled for now.
+ (#:event . scheduled)))
+ derivation))
(define (db-add-build-product product)
"Insert PRODUCT into BuildProducts table."
- (with-db-writer-worker-thread/force db
- (sqlite-exec db "\
-INSERT OR IGNORE INTO BuildProducts (build, type, file_size, checksum,
+ (with-db-worker-thread db
+ (exec-query/bind db "\
+INSERT INTO BuildProducts (build, type, file_size, checksum,
path) VALUES ("
- (assq-ref product #:build) ", "
- (assq-ref product #:type) ", "
- (assq-ref product #:file-size) ", "
- (assq-ref product #:checksum) ", "
- (assq-ref product #:path) ");")
- (last-insert-rowid db)))
+ (assq-ref product #:build) ", "
+ (assq-ref product #:type) ", "
+ (assq-ref product #:file-size) ", "
+ (assq-ref product #:checksum) ", "
+ (assq-ref product #:path) ");")))
+
+(define (db-get-output path)
+ "Retrieve the OUTPUT for PATH."
+ (with-db-worker-thread db
+ (match (exec-query/bind db "SELECT derivation, name FROM Outputs
+WHERE path =" path "
+LIMIT 1;")
+ (() #f)
+ (((derivation name))
+ `((#:derivation . ,derivation)
+ (#:name . ,name))))))
+
+(define (db-get-outputs derivation)
+ "Retrieve the OUTPUTS of the build identified by DERIVATION in the
+database."
+ (with-db-worker-thread db
+ (let loop ((rows
+ (exec-query/bind db "SELECT name, path FROM Outputs
+WHERE derivation =" derivation ";"))
+ (outputs '()))
+ (match rows
+ (() (reverse outputs))
+ (((name path)
+ . rest)
+ (loop rest
+ (cons `(,name . ((#:path . ,path)))
+ outputs)))))))
+
+(define (db-get-time-since-previous-build job-name specification)
+ "Return the time difference in seconds between the current time and the
+registration time of the last build for JOB-NAME and SPECIFICATION."
+ (with-db-worker-thread db
+ (match (expect-one-row
+ (exec-query/bind db "
+SELECT extract(epoch from now())::int - Builds.timestamp FROM Builds
+INNER JOIN Evaluations on Builds.evaluation = Evaluations.id
+WHERE job_name = " job-name "AND specification = " specification
+"ORDER BY Builds.timestamp DESC LIMIT 1"))
+ ((time)
+ (string->number time))
+ (else #f))))
(define (db-register-builds jobs eval-id specification)
(define (new-outputs? outputs)
@@ -734,8 +676,7 @@ path) VALUES ("
(+ (* spec-priority 10) priority)))
(define (register job)
- (let* ((name (assq-ref job #:job-name))
- (drv (assq-ref job #:derivation))
+ (let* ((drv (assq-ref job #:derivation))
(job-name (assq-ref job #:job-name))
(system (assq-ref job #:system))
(nix-name (assq-ref job #:nix-name))
@@ -779,11 +720,11 @@ path) VALUES ("
;; Use the database worker dedicated to write queries. We don't want this
;; query to be queued as it is already a quite large transaction by itself,
;; so pass the #:FORCE? option.
- (with-db-writer-worker-thread/force db
+ (with-db-worker-thread db
(log-message "Registering builds for evaluation ~a." eval-id)
- (sqlite-exec db "BEGIN TRANSACTION;")
+ (exec-query db "BEGIN TRANSACTION;")
(let ((derivations (filter-map register jobs)))
- (sqlite-exec db "COMMIT;")
+ (exec-query db "COMMIT;")
derivations)))
(define* (db-update-build-status! drv status #:key log-file)
@@ -800,11 +741,16 @@ log file for DRV."
(,(build-status failed-other) . "failed (other)")
(,(build-status canceled) . "canceled")))
- (with-db-writer-worker-thread db
+ (with-db-worker-thread db
(if (= status (build-status started))
(begin
- (sqlite-exec db "UPDATE Builds SET starttime=" now ", status="
- status "WHERE derivation=" drv ";")
+ (if log-file
+ (exec-query/bind db "UPDATE Builds SET starttime=" now
+ ",status=" status ",log=" log-file
+ "WHERE derivation=" drv ";")
+ (exec-query/bind db "UPDATE Builds SET starttime=" now
+ ",status="
+ status "WHERE derivation=" drv ";"))
(db-add-event 'build
now
`((#:derivation . ,drv)
@@ -815,56 +761,23 @@ log file for DRV."
;; and doesn't change every time we mark DRV as 'succeeded' several
;; times in a row, for instance.
(begin
- (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
- ";"))
- (when (positive? (changes-count db))
- (db-add-event 'build
- now
- `((#:derivation . ,drv)
- (#:event . ,(assq-ref status-names
- status)))))))))
+ (let ((rows
+ (exec-query/bind db "UPDATE Builds SET stoptime=" now
+ ", status=" status
+ "WHERE derivation=" drv
+ " AND status != " status ";")))
+ (when (positive? rows)
+ (db-add-event 'build
+ now
+ `((#:derivation . ,drv)
+ (#:event . ,(assq-ref status-names
+ status))))))))))
(define* (db-update-build-worker! drv worker)
"Update the database so that DRV's worker is WORKER."
- (with-db-writer-worker-thread db
- (sqlite-exec db "UPDATE Builds SET worker=" worker
- "WHERE derivation=" drv ";")))
-
-(define (db-get-output path)
- "Retrieve the OUTPUT for PATH."
(with-db-worker-thread db
- ;; There isn't a unique index on path, but because Cuirass avoids adding
- ;; derivations which introduce the same outputs, there should only be one
- ;; result.
- (match (sqlite-exec db "SELECT derivation, name FROM Outputs
-WHERE path =" path "
-LIMIT 1;")
- (() #f)
- ((#(derivation name))
- `((#:derivation . ,derivation)
- (#:name . ,name))))))
-
-(define (db-get-outputs derivation)
- "Retrieve the OUTPUTS of the build identified by DERIVATION in the
-database."
- (with-db-worker-thread 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)))))))
+ (exec-query/bind db "UPDATE Builds SET worker=" worker
+ "WHERE derivation=" drv ";")))
(define (query->bind-arguments query-string)
"Return a list of keys to query strings by parsing QUERY-STRING."
@@ -874,91 +787,103 @@ WHERE derivation =" derivation ";"))
("failed-dependency" . ,(build-status failed-dependency))
("failed-other" . ,(build-status failed-other))
("canceled" . ,(build-status canceled))))
- (let ((args (append-map
+ (let ((args (map
(lambda (token)
(match (string-split token #\:)
(("system" system)
- `(#:system ,system))
+ `(#:system . ,system))
(("spec" spec)
- `(#:spec ,spec))
+ `(#:spec . ,spec))
(("status" status)
- `(#:status ,(assoc-ref status-values status)))
+ `(#:status . ,(assoc-ref status-values status)))
((_ invalid) '()) ; ignore
((query)
;; Remove any '%' that could make the search too slow and
;; add one at the end of the query.
- `(#:query ,(string-append
- (string-join
- (string-split query #\%)
- "")
- "%")))))
+ `(#:query . ,(string-append
+ (string-join
+ (string-split query #\%)
+ "")
+ "%")))))
(string-tokenize query-string))))
;; Normalize arguments
(fold (lambda (key acc)
- (if (member key acc)
+ (if (assq key acc)
acc
- (append (list key #f) acc)))
+ (cons (cons key #f) acc)))
args '(#:spec #:system))))
+(define (db-get-build-products build-id)
+ "Return the build products associated to the given BUILD-ID."
+ (with-db-worker-thread db
+ (let loop ((rows (exec-query/bind db "
+SELECT id, type, file_size, checksum, path from BuildProducts
+WHERE build = " build-id))
+ (products '()))
+ (match rows
+ (() (reverse products))
+ (((id type file-size checksum path)
+ . rest)
+ (loop rest
+ (cons `((#:id . ,(string->number id))
+ (#:type . ,type)
+ (#:file-size . ,(string->number file-size))
+ (#:checksum . ,checksum)
+ (#:path . ,path))
+ products)))))))
+
(define (db-get-builds-by-search filters)
"Retrieve all builds in the database which are matched by given FILTERS.
FILTERS is an assoc list whose possible keys are the symbols query,
border-low-id, border-high-id, and nr."
(with-db-worker-thread db
- (let* ((stmt-text (format #f "SELECT Builds.rowid, Builds.timestamp,
+ (let* ((query (format #f "SELECT Builds.id, Builds.timestamp,
Builds.starttime,Builds.stoptime, Builds.log, Builds.status,
Builds.job_name, Builds.system, Builds.nix_name, Specifications.name
FROM Builds
INNER JOIN Evaluations ON Builds.evaluation = Evaluations.id
INNER JOIN Specifications ON Evaluations.specification = Specifications.name
WHERE (Builds.nix_name LIKE :query)
-AND (:status IS NULL
- OR (Builds.status = :status))
-AND (:spec IS NULL
- OR (Specifications.name = :spec))
-AND (:system IS NULL
- OR (Builds.system = :system))
-AND (:borderlowid IS NULL
- OR (:borderlowid < Builds.rowid))
-AND (:borderhighid IS NULL
- OR (:borderhighid > Builds.rowid))
+AND ((Builds.status = :status) OR :status IS NULL)
+AND ((Specifications.name = :spec) OR :spec IS NULL)
+AND ((Builds.system = :system) OR :system IS NULL)
+AND ((:borderlowid < Builds.id) OR :borderlowid IS NULL)
+AND ((:borderhighid > Builds.id) OR :borderhighid IS NULL)
ORDER BY
-CASE WHEN :borderlowid IS NULL THEN Builds.rowid
- ELSE -Builds.rowid
+CASE WHEN :borderlowid IS NULL THEN Builds.id
+ ELSE -Builds.id
END DESC
LIMIT :nr;"))
- (stmt (sqlite-prepare db stmt-text #:cache? #t)))
- (apply sqlite-bind-arguments
- stmt
- (append (list
- #:borderlowid (assq-ref filters 'border-low-id)
- #:borderhighid (assq-ref filters 'border-high-id)
- #:nr (match (assq-ref filters 'nr)
- (#f -1)
- (x x)))
- (query->bind-arguments (assq-ref filters 'query))))
- (let ((builds
- (sqlite-fold-right
- (lambda (row result)
- (match row
- (#(id timestamp starttime stoptime log status job-name
- system nix-name specification)
- (cons `((#:id . ,id)
- (#:timestamp . ,timestamp)
- (#:starttime . ,starttime)
- (#:stoptime . ,stoptime)
- (#:log . ,log)
- (#:status . ,status)
- (#:job-name . ,job-name)
- (#:system . ,system)
- (#:nix-name . ,nix-name)
- (#:specification . ,specification)
- (#:buildproducts . ,(db-get-build-products id)))
- result))))
- '()
- stmt)))
- (sqlite-reset stmt)
- builds))))
+ (builds
+ (exec-query/bind-params
+ db
+ query
+ `((#:borderlowid . ,(assq-ref filters 'border-low-id))
+ (#:borderhighid . ,(assq-ref filters 'border-high-id))
+ (#:nr . ,(match (assq-ref filters 'nr)
+ (#f -1)
+ (x x)))
+ ,@(query->bind-arguments (assq-ref filters 'query))))))
+ (let loop ((builds builds)
+ (result '()))
+ (match builds
+ (() result)
+ (((id timestamp starttime stoptime log status job-name
+ system nix-name specification)
+ . rest)
+ (loop rest
+ (cons `((#:id . ,(string->number id))
+ (#:timestamp . ,(string->number timestamp))
+ (#:starttime . ,(string->number starttime))
+ (#:stoptime . ,(string->number stoptime))
+ (#:log . ,log)
+ (#:status . ,(string->number status))
+ (#:job-name . ,job-name)
+ (#:system . ,system)
+ (#:nix-name . ,nix-name)
+ (#:specification . ,specification)
+ (#:buildproducts . ,(db-get-build-products id)))
+ result))))))))
(define (db-get-builds filters)
"Retrieve all builds in the database which are matched by given FILTERS.
@@ -969,22 +894,22 @@ FILTERS is an assoc list whose possible keys are
'derivation | 'id | 'jobset |
(define (filters->order filters)
(lambda (inner)
(match (assq 'order filters)
- (('order . 'build-id) "Builds.rowid ASC")
+ (('order . 'build-id) "Builds.id ASC")
(('order . 'finish-time) "stoptime DESC")
(('order . 'finish-time+build-id)
(if inner
- "CASE WHEN :borderlowid IS NULL THEN
+ "CASE WHEN CAST(:borderlowid AS integer) IS NULL THEN
stoptime ELSE -stoptime END DESC,
-CASE WHEN :borderlowid IS NULL THEN
- Builds.rowid ELSE -Builds.rowid END DESC"
- "stoptime DESC, Builds.rowid DESC"))
+CASE WHEN CAST(:borderlowid AS integer) IS NULL THEN
+ Builds.id ELSE -Builds.id END DESC"
+ "stoptime DESC, Builds.id DESC"))
;; With this order, builds in 'running' state (-1) appear
;; before those in 'scheduled' state (-2).
(('order . 'status+submission-time)
- "Builds.status DESC, Builds.timestamp DESC, Builds.rowid ASC")
+ "Builds.status DESC, Builds.timestamp DESC, Builds.id ASC")
(('order . 'priority+timestamp)
- "Builds.priority DESC, Builds.timestamp ASC")
- (_ "Builds.rowid DESC"))))
+ "Builds.priority ASC, Builds.timestamp DESC")
+ (_ "Builds.id DESC"))))
;; XXX: Make sure that all filters are covered by an index.
(define (where-conditions filters)
@@ -1005,11 +930,11 @@ CASE WHEN :borderlowid IS NULL THEN
('succeeded "Builds.status = 0")
('failed "Builds.status > 0")))
(border-low-time
- . "(:borderlowtime IS NULL OR :borderlowid IS NULL OR
- ((:borderlowtime, :borderlowid) < (Builds.stoptime, Builds.rowid)))")
+ . "(((:borderlowtime, :borderlowid) < (Builds.stoptime, Builds.id))
+OR :borderlowtime IS NULL OR :borderlowid IS NULL)")
(border-high-time
- . "(:borderhightime IS NULL OR :borderhighid IS NULL OR
- ((:borderhightime, :borderhighid) > (Builds.stoptime, Builds.rowid)))")))
+ . "(((:borderhightime, :borderhighid) > (Builds.stoptime, Builds.id))
+OR :borderhightime IS NULL OR :borderhighid IS NULL)")))
(filter
string?
@@ -1055,422 +980,389 @@ CASE WHEN :borderlowid IS NULL THEN
((first-condition rest ...)
(string-append "WHERE " first-condition "\n AND "
(string-join rest " AND ")))))
- (stmt-text
- (format #f "
-SELECT Builds.*,
-GROUP_CONCAT(Outputs.name), GROUP_CONCAT(Outputs.path),
-GROUP_CONCAT(BP.rowid), GROUP_CONCAT(BP.type), GROUP_CONCAT(BP.file_size),
-GROUP_CONCAT(BP.checksum), GROUP_CONCAT(BP.path) FROM
-(SELECT Builds.derivation, Builds.rowid, Builds.timestamp, Builds.starttime,
- Builds.stoptime, Builds.log, Builds.status, Builds.priority,
- Builds.max_silent, Builds.timeout, Builds.job_name,
- Builds.system, Builds.nix_name, Builds.evaluation,
- Specifications.name
-FROM Builds
+ (query
+ (format #f " SELECT Builds.derivation, Builds.id, Builds.timestamp,
+Builds.starttime, Builds.stoptime, Builds.log, Builds.status, Builds.priority,
+Builds.max_silent, Builds.timeout, Builds.job_name, Builds.system,
+Builds.nix_name, Builds.evaluation, agg.name, agg.outputs_name,
+agg.outputs_path,agg.bp_build, agg.bp_type, agg.bp_file_size,
+agg.bp_checksum, agg.bp_path
+FROM
+(SELECT B.id, B.derivation, B.name,
+string_agg(Outputs.name, ',') AS outputs_name,
+string_agg(Outputs.path, ',') AS outputs_path,
+string_agg(cast(BP.build AS text), ',') AS bp_build,
+string_agg(BP.type, ',') AS bp_type,
+string_agg(cast(BP.file_size AS text), ',') AS bp_file_size,
+string_agg(BP.checksum, ',') AS bp_checksum,
+string_agg(BP.path, ',') AS bp_path FROM
+(SELECT Builds.id, Builds.derivation, Specifications.name FROM Builds
INNER JOIN Evaluations ON Builds.evaluation = Evaluations.id
INNER JOIN Specifications ON Evaluations.specification = Specifications.name
~a
ORDER BY ~a
-LIMIT :nr) Builds
-INNER JOIN Outputs ON Outputs.derivation = Builds.derivation
-LEFT JOIN BuildProducts as BP ON BP.build = Builds.rowid
-GROUP BY Builds.derivation
+LIMIT :nr) B
+INNER JOIN Outputs ON Outputs.derivation = B.derivation
+LEFT JOIN BuildProducts as BP ON BP.build = B.id
+GROUP BY B.derivation, B.id, B.name) agg
+JOIN Builds on agg.id = Builds.id
ORDER BY ~a;"
where (order #t) (order #f)))
- (stmt (sqlite-prepare db stmt-text #:cache? #t)))
-
- (sqlite-bind stmt 'nr (match (assq-ref filters 'nr)
- (#f -1)
- (x x)))
- (for-each (match-lambda
- (('nr . _) #f) ; Handled above
- (('order . _) #f) ; Doesn't need binding
- (('status . _) #f) ; Doesn't need binding
- ((name . value)
- (when value
- (sqlite-bind stmt
- (or (assq-ref
- '((border-low-time . borderlowtime)
- (border-high-time . borderhightime)
- (border-low-id . borderlowid)
- (border-high-id . borderhighid))
- name)
- name)
- value))))
- filters)
- (let ((builds
- (sqlite-fold-right
- (lambda (row result)
- (match row
- (#(derivation id timestamp starttime stoptime log status
- priority max-silent timeout job-name
- system nix-name eval-id specification
- outputs-name outputs-path
- products-id products-type products-file-size
- products-checksum products-path)
- (cons `((#:derivation . ,derivation)
- (#:id . ,id)
- (#:timestamp . ,timestamp)
- (#:starttime . ,starttime)
- (#:stoptime . ,stoptime)
- (#:log . ,log)
- (#:status . ,status)
- (#:priority . ,priority)
- (#:max-silent . ,max-silent)
- (#:timeout . ,timeout)
- (#:job-name . ,job-name)
- (#:system . ,system)
- (#:nix-name . ,nix-name)
- (#:eval-id . ,eval-id)
- (#:specification . ,specification)
- (#:outputs . ,(format-outputs outputs-name
- outputs-path))
- (#:buildproducts .
- ,(format-build-products products-id
- products-type
- products-file-size
- products-checksum
- products-path)))
- result))))
- '()
- stmt)))
- (sqlite-reset stmt)
- builds))))
+ (params
+ (map (match-lambda
+ ((name . value)
+ (let ((key
+ (symbol->keyword
+ (or (assq-ref
+ '((border-low-time . borderlowtime)
+ (border-high-time . borderhightime)
+ (border-low-id . borderlowid)
+ (border-high-id . borderhighid))
+ name)
+ name)))
+ (value
+ (match name
+ ('nr (or value -1))
+ ('order #f) ; Doesn't need binding.
+ ('status #f) ; Doesn't need binding.
+ (else value))))
+ (cons key value))))
+ filters))
+ (builds (exec-query/bind-params db query params)))
+ (let loop ((builds builds)
+ (result '()))
+ (match builds
+ (() (reverse result))
+ (((derivation id timestamp starttime stoptime log status
+ priority max-silent timeout job-name
+ system nix-name eval-id specification
+ outputs-name outputs-path
+ products-id products-type products-file-size
+ products-checksum products-path)
+ . rest)
+ (loop rest
+ (cons `((#:derivation . ,derivation)
+ (#:id . ,(string->number id))
+ (#:timestamp . ,(string->number timestamp))
+ (#:starttime . ,(string->number starttime))
+ (#:stoptime . ,(string->number stoptime))
+ (#:log . ,log)
+ (#:status . ,(string->number status))
+ (#:priority . ,(string->number priority))
+ (#:max-silent . ,(string->number max-silent))
+ (#:timeout . ,(string->number timeout))
+ (#:job-name . ,job-name)
+ (#:system . ,system)
+ (#:nix-name . ,nix-name)
+ (#:eval-id . ,(string->number eval-id))
+ (#:specification . ,specification)
+ (#:outputs . ,(format-outputs outputs-name
+ outputs-path))
+ (#:buildproducts .
+ ,(format-build-products products-id
+ products-type
+ products-file-size
+ products-checksum
+ products-path)))
+ result))))))))
(define (db-get-build derivation-or-id)
"Retrieve a build in the database which corresponds to DERIVATION-OR-ID."
- (with-db-worker-thread db
- (let ((key (if (number? derivation-or-id) 'id 'derivation)))
- (expect-one-row (db-get-builds `((,key . ,derivation-or-id)))))))
-
-(define (db-get-time-since-previous-build job-name specification)
- "Return the time difference in seconds between the current time and the
-registration time of the last build for JOB-NAME and SPECIFICATION."
- (with-db-worker-thread db
- (let ((rows (sqlite-exec db "
-SELECT strftime('%s', 'now') - Builds.timestamp FROM Builds
-INNER JOIN Evaluations on Builds.evaluation = Evaluations.id
-WHERE job_name = " job-name "AND specification = " specification
-"ORDER BY Builds.timestamp DESC LIMIT 1")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
-
-(define (db-add-event type timestamp details)
- (when (%record-events?)
- (with-db-writer-worker-thread db
- (sqlite-exec db "\
-INSERT INTO Events (type, timestamp, event_json) VALUES ("
- (symbol->string type) ", "
- timestamp ", "
- (object->json-string details)
- ");")
- #t)))
+ (let ((key (if (number? derivation-or-id) 'id 'derivation)))
+ (expect-one-row (db-get-builds `((,key . ,derivation-or-id))))))
(define (db-get-events filters)
(with-db-worker-thread db
- (let* ((stmt-text "\
+ (let* ((query "\
SELECT Events.id,
Events.type,
Events.timestamp,
Events.event_json
FROM Events
-WHERE (:type IS NULL OR (:type = Events.type))
- AND (:borderlowtime IS NULL OR
- :borderlowid IS NULL OR
- ((:borderlowtime, :borderlowid) <
- (Events.timestamp, Events.id)))
- AND (:borderhightime IS NULL OR
- :borderhighid IS NULL OR
- ((:borderhightime, :borderhighid) >
- (Events.timestamp, Events.id)))
+WHERE (:type = Events.type OR :type IS NULL)
+ AND (((:borderlowtime, :borderlowid) <
+ (Events.timestamp, Events.id)) OR
+ :borderlowtime IS NULL OR
+ :borderlowid IS NULL)
+ AND (((:borderhightime, :borderhighid) >
+ (Events.timestamp, Events.id)) OR
+ :borderhightime IS NULL OR
+ :borderhighid IS NULL)
ORDER BY Events.id ASC
LIMIT :nr;")
- (stmt (sqlite-prepare db stmt-text #:cache? #t)))
- (sqlite-bind-arguments
- stmt
- #:type (and=> (assq-ref filters 'type)
- symbol->string)
- #:nr (match (assq-ref filters 'nr)
- (#f -1)
- (x x)))
- (let ((events
- (sqlite-fold-right
- (lambda (row result)
- (match row
- (#(id type timestamp event_json)
- (cons `((#:id . ,id)
- (#:type . ,type)
- (#:timestamp . ,timestamp)
- (#:event_json . ,event_json))
- result))))
- '()
- stmt)))
- (sqlite-reset stmt)
- events))))
+ (params `((#:type . ,(and=> (assq-ref filters 'type)
+ symbol->string))
+ (#:nr . ,(match (assq-ref filters 'nr)
+ (#f -1)
+ (x x)))))
+ (events (exec-query/bind-params db query params)))
+ (let loop ((events events)
+ (result '()))
+ (match events
+ (() (reverse result))
+ (((id type timestamp event_json)
+ . rest)
+ (loop rest
+ (cons `((#:id . ,(string->number id))
+ (#:type . ,(string->symbol type))
+ (#:timestamp . ,(string->number timestamp))
+ (#:event_json . ,event_json))
+ result))))))))
(define (db-delete-events-with-ids-<=-to id)
- (with-db-writer-worker-thread db
- (sqlite-exec
- db
- "DELETE FROM Events WHERE id <= " id ";")))
+ (with-db-worker-thread db
+ (exec-query/bind db "DELETE FROM Events WHERE id <= " id ";")))
(define (db-get-pending-derivations)
"Return the list of derivation file names corresponding to pending builds in
the database. The returned list is guaranteed to not have any duplicates."
(with-db-worker-thread db
- (map (match-lambda (#(drv) drv))
- (sqlite-exec db "
+ (map (match-lambda ((drv) drv))
+ (exec-query db "
SELECT derivation FROM Builds WHERE Builds.status < 0;"))))
(define (db-get-checkouts eval-id)
(with-db-worker-thread db
- (let loop ((rows (sqlite-exec
+ (let loop ((rows (exec-query/bind
db "SELECT revision, input, directory FROM Checkouts
WHERE evaluation =" eval-id ";"))
(checkouts '()))
(match rows
- (() checkouts)
- ((#(revision input directory)
- . rest)
+ (() (reverse checkouts))
+ (((revision input directory)
+ . rest)
(loop rest
(cons `((#:commit . ,revision)
(#:input . ,input)
(#:directory . ,directory))
checkouts)))))))
+(define (parse-evaluation evaluation)
+ (match evaluation
+ ((id specification status timestamp checkouttime evaltime)
+ `((#:id . ,(string->number id))
+ (#:specification . ,specification)
+ (#:status . ,(string->number status))
+ (#:timestamp . ,(string->number timestamp))
+ (#:checkouttime . ,(string->number checkouttime))
+ (#:evaltime . ,(string->number evaltime))
+ (#:checkouts . ,(db-get-checkouts id))))))
+
(define (db-get-evaluation id)
(with-db-worker-thread db
- (match (sqlite-exec db "SELECT id, specification, status,
+ (match (exec-query/bind db "SELECT id, specification, status,
timestamp, checkouttime, evaltime
FROM Evaluations WHERE id = " id)
(() #f)
- ((#(id specification status timestamp checkouttime evaltime))
- `((#:id . ,id)
- (#:specification . ,specification)
- (#:status . ,status)
- (#:timestamp . ,timestamp)
- (#:checkouttime . ,checkouttime)
- (#:evaltime . ,evaltime)
- (#:checkouts . ,(db-get-checkouts id)))))))
+ ((evaluation)
+ (parse-evaluation evaluation)))))
(define (db-get-evaluations limit)
(with-db-worker-thread db
- (let loop ((rows (sqlite-exec db "SELECT id, specification, status,
+ (let loop ((rows (exec-query/bind db "SELECT id, specification, status,
timestamp, checkouttime, evaltime
FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
(evaluations '()))
(match rows
(() (reverse evaluations))
- ((#(id specification status timestamp checkouttime evaltime)
- . rest)
+ ((evaluation . rest)
(loop rest
- (cons `((#:id . ,id)
- (#:specification . ,specification)
- (#:status . ,status)
- (#:timestamp . ,timestamp)
- (#:checkouttime . ,checkouttime)
- (#:evaltime . ,evaltime)
- (#:checkouts . ,(db-get-checkouts id)))
- evaluations)))))))
+ (cons (parse-evaluation evaluation) evaluations)))))))
(define (db-get-evaluations-build-summary spec limit border-low border-high)
(with-db-worker-thread db
- (let loop ((rows (sqlite-exec db "
-SELECT E.id, E.status, SUM(B.status=0) as succeeded,
-SUM(B.status>0) as failed, SUM(B.status<0) as scheduled FROM
+ (let ((query "
+SELECT E.id, E.status,
+SUM(CASE WHEN B.status = 0 THEN 1 ELSE 0 END) as succeeded,
+SUM(CASE WHEN B.status > 0 THEN 1 ELSE 0 END) as failed,
+SUM(CASE WHEN B.status < 0 THEN 1 ELSE 0 END) as scheduled FROM
(SELECT id, status FROM Evaluations
-WHERE (specification=" spec ")
-AND (" border-low "IS NULL OR (id >" border-low "))
-AND (" border-high "IS NULL OR (id <" border-high "))
-ORDER BY CASE WHEN " border-low "IS NULL THEN id ELSE -id END DESC
-LIMIT " limit ") E
+WHERE specification=:spec
+AND (id > :borderlow OR :borderlow IS NULL)
+AND (id < :borderhigh OR :borderhigh IS NULL)
+ORDER BY CASE WHEN :borderlow IS NULL THEN id ELSE -id END DESC
+LIMIT :limit) E
LEFT JOIN Builds as B
ON B.evaluation=E.id
-GROUP BY E.id
-ORDER BY E.id ASC;"))
- (evaluations '()))
- (match rows
- (() evaluations)
- ((#(id status succeeded failed scheduled) . rest)
- (loop rest
- (cons `((#:id . ,id)
- (#:status . ,status)
- (#:checkouts . ,(db-get-checkouts id))
- (#:succeeded . ,(or succeeded 0))
- (#:failed . ,(or failed 0))
- (#:scheduled . ,(or scheduled 0)))
- evaluations)))))))
+GROUP BY E.id, E.status
+ORDER BY E.id DESC;")
+ (params `((#:spec . ,spec)
+ (#:limit . ,limit)
+ (#:borderlow . ,border-low)
+ (#:borderhigh . ,border-high))))
+ (let loop ((rows (exec-query/bind-params db query params))
+ (evaluations '()))
+ (match rows
+ (() (reverse evaluations))
+ (((id status succeeded failed scheduled) . rest)
+ (loop rest
+ (cons `((#:id . ,(string->number id))
+ (#:status . ,(string->number status))
+ (#:checkouts . ,(db-get-checkouts id))
+ (#:succeeded . ,(or (string->number succeeded) 0))
+ (#:failed . ,(or (string->number failed) 0))
+ (#:scheduled . ,(or (string->number scheduled) 0)))
+ evaluations))))))))
(define (db-get-evaluations-id-min spec)
"Return the min id of evaluations for the given specification SPEC."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "
+ (match (expect-one-row
+ (exec-query/bind db "
SELECT MIN(id) FROM Evaluations
-WHERE specification=" spec)))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+WHERE specification=" spec))
+ ((min) (and min (string->number min))))))
(define (db-get-evaluations-id-max spec)
"Return the max id of evaluations for the given specification SPEC."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "
+ (match (expect-one-row
+ (exec-query/bind db "
SELECT MAX(id) FROM Evaluations
-WHERE specification=" spec)))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+WHERE specification=" spec))
+ ((max) (and max (string->number max))))))
(define (db-get-evaluation-summary id)
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "
-SELECT E.id, E.status, E.timestamp, E.checkouttime, E.evaltime,
-SUM(B.status>-100) as total, SUM(B.status=0) as succeeded,
-SUM(B.status>0) as failed, SUM(B.status<0) as scheduled FROM
-(SELECT id, status, timestamp, checkouttime, evaltime FROM
- Evaluations WHERE (id=" id ")) E
+ (match (expect-one-row
+ (exec-query/bind db "
+SELECT Evaluations.id, Evaluations.status, Evaluations.timestamp,
+Evaluations.checkouttime, Evaluations.evaltime,
+SUM(CASE WHEN B.status > -100 THEN 1 ELSE 0 END) as total,
+SUM(CASE WHEN B.status = 0 THEN 1 ELSE 0 END) as succeeded,
+SUM(CASE WHEN B.status > 0 THEN 1 ELSE 0 END) as failed,
+SUM(CASE WHEN B.status < 0 THEN 1 ELSE 0 END) as scheduled
+FROM Evaluations
LEFT JOIN Builds as B
-ON B.evaluation=E.id
-ORDER BY E.id ASC;")))
- (and=> (expect-one-row rows)
- (match-lambda
- (#(id status timestamp checkouttime evaltime
- total succeeded failed scheduled)
- `((#:id . ,id)
- (#:status . ,status)
- (#:total . ,(or total 0))
- (#:timestamp . ,timestamp)
- (#:checkouttime . ,checkouttime)
- (#:evaltime . ,evaltime)
- (#:succeeded . ,(or succeeded 0))
- (#:failed . ,(or failed 0))
- (#:scheduled . ,(or scheduled 0)))))))))
-
-(define (db-get-builds-query-min query)
+ON B.evaluation = Evaluations.id
+WHERE Evaluations.id = " id
+"GROUP BY Evaluations.id
+ORDER BY Evaluations.id ASC;"))
+ ((id status timestamp checkouttime evaltime
+ total succeeded failed scheduled)
+ `((#:id . ,(string->number id))
+ (#:status . ,(string->number status))
+ (#:total . ,(or (string->number total) 0))
+ (#:timestamp . ,(string->number timestamp))
+ (#:checkouttime . ,(string->number checkouttime))
+ (#:evaltime . ,(string->number evaltime))
+ (#:succeeded . ,(or (string->number succeeded) 0))
+ (#:failed . ,(or (string->number failed) 0))
+ (#:scheduled . ,(or (string->number scheduled) 0))))
+ (else #f))))
+
+(define (db-get-builds-query-min filters)
"Return the smallest build row identifier matching QUERY."
(with-db-worker-thread db
- (let* ((stmt-text "SELECT MIN(Builds.rowid) FROM Builds
+ (let* ((query "SELECT MIN(Builds.id) FROM Builds
INNER JOIN Evaluations ON Builds.evaluation = Evaluations.id
INNER JOIN Specifications ON Evaluations.specification = Specifications.name
WHERE (Builds.nix_name LIKE :query)
-AND (:status IS NULL
- OR (Builds.status = :status))
-AND (:spec IS NULL
- OR (Specifications.name = :spec))
-AND (:system IS NULL
- OR (Builds.system = :system));")
- (stmt (sqlite-prepare db stmt-text #:cache? #t)))
- (apply sqlite-bind-arguments stmt
- (query->bind-arguments query))
- (let ((rows (sqlite-fold-right cons '() stmt)))
- (sqlite-reset stmt)
- (and=> (expect-one-row rows) vector->list)))))
-
-(define (db-get-builds-query-max query)
+AND (Builds.status = :status OR :status IS NULL)
+AND (Specifications.name = :spec OR :spec IS NULL)
+AND (Builds.system = :system OR :system IS NULL);")
+ (params (query->bind-arguments filters)))
+ (match (expect-one-row
+ (exec-query/bind-params db query params))
+ ((min) (and min
+ (list (string->number min))))))))
+
+(define (db-get-builds-query-max filters)
"Return the largest build row identifier matching QUERY."
(with-db-worker-thread db
- (let* ((stmt-text "SELECT MAX(Builds.rowid) FROM Builds
+ (let* ((query "SELECT MAX(Builds.id) FROM Builds
INNER JOIN Evaluations ON Builds.evaluation = Evaluations.id
INNER JOIN Specifications ON Evaluations.specification = Specifications.name
WHERE (Builds.nix_name LIKE :query)
-AND (:status IS NULL
- OR (Builds.status = :status))
-AND (:spec IS NULL
- OR (Specifications.name = :spec))
-AND (:system IS NULL
- OR (Builds.system = :system));")
- (stmt (sqlite-prepare db stmt-text #:cache? #t)))
- (apply sqlite-bind-arguments stmt
- (query->bind-arguments query))
- (let ((rows (sqlite-fold-right cons '() stmt)))
- (sqlite-reset stmt)
- (and=> (expect-one-row rows) vector->list)))))
+AND (Builds.status = :status OR :status IS NULL)
+AND (Specifications.name = :spec OR :spec IS NULL)
+AND (Builds.system = :system OR :system IS NULL);")
+ (params (query->bind-arguments filters)))
+ (match (expect-one-row
+ (exec-query/bind-params db query params))
+ ((max) (and max
+ (list (string->number max))))))))
(define (db-get-builds-min eval status)
"Return the min build (stoptime, rowid) pair for the given evaluation EVAL
and STATUS."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "
-SELECT stoptime, rowid FROM Builds
-WHERE evaluation=" eval "
-AND (" status " IS NULL OR (" status " = 'pending'
- AND Builds.status < 0)
- OR (" status " = 'succeeded'
- AND Builds.status = 0)
- OR (" status " = 'failed'
- AND Builds.status > 0))
-ORDER BY stoptime ASC, rowid ASC
-LIMIT 1")))
- (and=> (expect-one-row rows) vector->list))))
+ (let ((query "SELECT stoptime, id FROM Builds
+WHERE evaluation = :eval AND
+((:status = 'pending' AND Builds.status < 0) OR
+(:status = 'succeeded' AND Builds.status = 0) OR
+(:status = 'failed' AND Builds.status > 0) OR
+:status IS NULL)
+ORDER BY stoptime ASC, id ASC
+LIMIT 1")
+ (params `((#:eval . ,eval)
+ (#:status . ,status))))
+ (match (expect-one-row
+ (exec-query/bind-params db query params))
+ ((stoptime id) (list (string->number stoptime)
+ (string->number id)))
+ (else #f)))))
(define (db-get-builds-max eval status)
"Return the max build (stoptime, rowid) pair for the given evaluation EVAL
and STATUS."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "
-SELECT stoptime, rowid FROM Builds
-WHERE evaluation=" eval "
-AND (" status " IS NULL OR (" status " = 'pending'
- AND Builds.status < 0)
- OR (" status " = 'succeeded'
- AND Builds.status = 0)
- OR (" status " = 'failed'
- AND Builds.status > 0))
-ORDER BY stoptime DESC, rowid DESC
-LIMIT 1")))
- (and=> (expect-one-row rows) vector->list))))
+ (let ((query "SELECT stoptime, id FROM Builds
+WHERE evaluation = :eval AND
+((:status = 'pending' AND Builds.status < 0) OR
+(:status = 'succeeded' AND Builds.status = 0) OR
+(:status = 'failed' AND Builds.status > 0) OR
+:status IS NULL)
+ORDER BY stoptime DESC, id DESC
+LIMIT 1")
+ (params `((#:eval . ,eval)
+ (#:status . ,status))))
+ (match (expect-one-row
+ (exec-query/bind-params db query params))
+ ((stoptime id) (list (string->number stoptime)
+ (string->number id)))
+ (else #f)))))
(define (db-get-evaluation-specification eval)
"Return specification of evaluation with id EVAL."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "
+ (match (expect-one-row
+ (exec-query/bind db "
SELECT specification FROM Evaluations
-WHERE id = " eval)))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+WHERE id = " eval))
+ ((spec) spec)
+ (else #f))))
(define (db-get-build-product-path id)
"Return the build product with the given ID."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "
+ (match (expect-one-row
+ (exec-query/bind db "
SELECT path FROM BuildProducts
-WHERE rowid = " id)))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
-
-(define (db-get-build-products build-id)
- "Return the build products associated to the given BUILD-ID."
- (with-db-worker-thread db
- (let loop ((rows (sqlite-exec db "
-SELECT rowid, type, file_size, checksum, path from BuildProducts
-WHERE build = " build-id))
- (products '()))
- (match rows
- (() (reverse products))
- ((#(id type file-size checksum path)
- . rest)
- (loop rest
- (cons `((#:id . ,id)
- (#:type . ,type)
- (#:file-size . ,file-size)
- (#:checksum . ,checksum)
- (#:path . ,path))
- products)))))))
+WHERE id = " id))
+ ((path) path)
+ (else #f))))
(define (db-add-worker worker)
"Insert WORKER into Worker table."
- (with-db-writer-worker-thread db
- (sqlite-exec db "\
-INSERT OR REPLACE INTO Workers (name, address, systems, last_seen)
+ (with-db-worker-thread db
+ (exec-query/bind db "\
+INSERT INTO Workers (name, address, systems, last_seen)
VALUES ("
- (worker-name worker) ", "
- (worker-address worker) ", "
- (string-join (worker-systems worker) ",") ", "
- (worker-last-seen worker) ");")
- (last-insert-rowid db)))
+ (worker-name worker) ", "
+ (worker-address worker) ", "
+ (string-join (worker-systems worker) ",") ", "
+ (worker-last-seen worker) ");")))
(define (db-get-workers)
"Return the workers in Workers table."
(with-db-worker-thread db
- (let loop ((rows (sqlite-exec db "
+ (let loop ((rows (exec-query db "
SELECT name, address, systems, last_seen from Workers"))
(workers '()))
(match rows
(() (reverse workers))
- ((#(name address systems last-seen)
+ (((name address systems last-seen)
. rest)
(loop rest
(cons (worker
@@ -1482,5 +1374,14 @@ SELECT name, address, systems, last_seen from Workers"))
(define (db-clear-workers)
"Remove all workers from Workers table."
- (with-db-writer-worker-thread db
- (sqlite-exec db "DELETE FROM Workers;")))
+ (with-db-worker-thread db
+ (exec-query db "DELETE FROM Workers;")))
+
+(define (db-clear-build-queue)
+ "Reset the status of builds in the database that are marked as \"started\"."
+ (with-db-worker-thread db
+ (exec-query db "UPDATE Builds SET status = -2 WHERE status < 0;")))
+
+;;; Local Variables:
+;;; eval: (put 'with-db-worker-thread 'scheme-indent-function 1)
+;;; End:
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 3ac7ef9..6bca85c 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -250,14 +250,14 @@ Hydra format."
#:avg-eval-build-start-time
(db-get-metrics-with-id 'average-eval-build-start-time
#:limit 100
- #:order "field ASC")
+ #:order "cast(field as int) ASC")
#:builds-per-day
(db-get-metrics-with-id 'builds-per-day
#:limit 100)
#:eval-completion-speed
(db-get-metrics-with-id 'evaluation-completion-speed
#:limit 100
- #:order "field ASC")
+ #:order "cast(field as int) ASC")
#:new-derivations-per-day
(db-get-metrics-with-id 'new-derivations-per-day
#:limit 100)
diff --git a/src/cuirass/metrics.scm b/src/cuirass/metrics.scm
index 9a0fd14..f993cf2 100644
--- a/src/cuirass/metrics.scm
+++ b/src/cuirass/metrics.scm
@@ -20,13 +20,16 @@
#:use-module (cuirass database)
#:use-module (cuirass logging)
#:use-module (guix records)
+ #:use-module (squee)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 i18n)
#:use-module (ice-9 match)
#:export (metric
metric?
metric-id
+ metric-field-type
metric-proc
%metrics
@@ -47,6 +50,8 @@
metric?
(id metric-id)
(compute-proc metric-compute-proc)
+ (field-type metric-field-type
+ (default 'int))
(field-proc metric-field-proc
(default #f)))
@@ -55,72 +60,98 @@
;;; Database procedures.
;;;
+(define-syntax-rule (return-exact body ...)
+ (match (expect-one-row body ...)
+ ((result)
+ (and result (string->number result)))))
+
+(define-syntax-rule (return-inexact body ...)
+ (match (expect-one-row body ...)
+ ((result)
+ (and result (locale-string->inexact result)))))
+
(define* (db-average-eval-duration-per-spec spec #:key limit)
"Return the average evaluation duration for SPEC. Limit the average
computation to the most recent LIMIT records if this argument is set."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "SELECT AVG(duration) FROM
+ (let ((query "\
+SELECT AVG(m.duration) FROM
(SELECT (evaltime - timestamp) as duration
-FROM Evaluations WHERE specification = " spec
-" AND evaltime != 0 ORDER BY rowid DESC
-LIMIT " (or limit -1) ");")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+FROM Evaluations WHERE specification = :spec
+AND evaltime != 0 ORDER BY id DESC LIMIT ~a) m;")
+ (params `((#:spec . ,spec))))
+ (return-inexact
+ (exec-query/bind-params db
+ (format #f query
+ (if limit
+ (number->string limit)
+ "ALL"))
+ params)))))
(define (db-builds-previous-day _)
"Return the builds count of the previous day."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "SELECT COUNT(*) from Builds
-WHERE date(timestamp, 'unixepoch') = date('now', '-1 day') AND
-date(stoptime, 'unixepoch') = date('now', '-1 day');")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+ (return-exact
+ (exec-query/bind db "SELECT COUNT(*) from Builds
+WHERE to_timestamp(timestamp)::date = 'yesterday'::date AND
+to_timestamp(stoptime)::date = 'yesterday'::date;"))))
(define (db-new-derivations-previous-day _)
"Return the new derivations count of the previous day."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "SELECT COUNT(*) from Builds
-WHERE date(timestamp, 'unixepoch') = date('now', '-1 day');")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+ (return-exact
+ (exec-query/bind db "SELECT COUNT(*) from Builds
+WHERE to_timestamp(timestamp)::date = 'yesterday'::date;"))))
(define (db-pending-builds _)
"Return the current pending builds count."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "SELECT COUNT(*) from Builds
-WHERE status < 0;")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+ (return-exact
+ (exec-query/bind db "SELECT COUNT(*) from Builds
+WHERE status < 0;"))))
(define* (db-percentage-failed-eval-per-spec spec #:key limit)
"Return the failed evaluation percentage for SPEC. If LIMIT is set, limit
the percentage computation to the most recent LIMIT records."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "\
-SELECT 100 * CAST(SUM(status > 0) as float) / COUNT(*) FROM
-(SELECT status from Evaluations WHERE specification = " spec
-" ORDER BY rowid DESC LIMIT " (or limit -1) ");")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+ (let ((query "\
+SELECT 100 *
+CAST(SUM(CASE WHEN m.status > 0 THEN 1 ELSE 0 END) as float) /
+COUNT(*) FROM
+(SELECT status from Evaluations WHERE specification = :spec
+ORDER BY id DESC LIMIT ~a) m")
+ (params `((#:spec . ,spec))))
+ (return-inexact
+ (exec-query/bind-params db
+ (format #f query
+ (if limit
+ (number->string limit)
+ "ALL"))
+ params)))))
(define* (db-average-build-start-time-per-eval eval)
"Return the average build start time for the given EVAL."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "\
+ (return-inexact
+ (exec-query/bind db "\
SELECT AVG(B.starttime - E.evaltime) FROM
(SELECT id, evaltime
FROM Evaluations WHERE id = " eval ") E
LEFT JOIN Builds as B
ON E.id = B.evaluation and B.starttime > 0
-GROUP BY E.id;")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+GROUP BY E.id;"))))
(define* (db-average-build-complete-time-per-eval eval)
"Return the average build complete time for the given EVAL."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "\
+ (return-inexact
+ (exec-query/bind db "\
SELECT AVG(B.stoptime - E.evaltime) FROM
(SELECT id, evaltime
FROM Evaluations WHERE id = " eval ") E
LEFT JOIN Builds as B
ON E.id = B.evaluation and B.stoptime > 0
-GROUP BY E.id;")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+GROUP BY E.id;"))))
(define* (db-evaluation-completion-speed eval)
"Return the evaluation completion speed of the given EVAL. The speed is
@@ -133,45 +164,45 @@ expressed in builds per hour."
;; evaluation_duration (seconds) = max(build_stop_time) - eval_start_time
;; If the evaluation builds are all completed.
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "\
+ (return-inexact
+ (exec-query/bind db "\
SELECT
-3600.0 * SUM(B.status = 0) /
-(CASE SUM(status < 0)
+3600.0 * SUM(CASE WHEN B.status = 0 THEN 1 ELSE 0 END) /
+(CASE SUM(CASE WHEN status < 0 THEN 1 ELSE 0 END)
WHEN 0 THEN MAX(stoptime)
- ELSE strftime('%s', 'now')
+ ELSE extract(epoch from 'today'::date)
END - E.evaltime) FROM
(SELECT id, evaltime
FROM Evaluations WHERE id = " eval ") E
LEFT JOIN Builds as B
ON E.id = B.evaluation and B.stoptime > 0
-GROUP BY E.id;")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+GROUP BY E.id, E.evaltime;"))))
(define (db-previous-day-timestamp)
"Return the timestamp of the previous day."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "SELECT strftime('%s',
-date('now', '-1 day'));")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+ (return-exact
+ (exec-query
+ db "SELECT extract(epoch from 'yesterday'::date);"))))
(define (db-current-day-timestamp)
"Return the timestamp of the current day."
(with-db-worker-thread db
- (let ((rows (sqlite-exec db "SELECT strftime('%s',
-date('now'));")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+ (return-exact
+ (exec-query
+ db "SELECT extract(epoch from 'today'::date);"))))
(define* (db-latest-evaluations #:key (days 3))
"Return the successful evaluations added during the previous DAYS."
(with-db-worker-thread db
(let ((query (format #f "SELECT id from Evaluations
-WHERE date(timestamp, 'unixepoch') > date('now', '-~a day') AND
-status = 0 ORDER BY rowid DESC" days)))
- (let loop ((rows (sqlite-exec db query))
+WHERE to_timestamp(timestamp)::date > 'today'::date - interval '~a day' AND
+status = 0 ORDER BY id DESC" days)))
+ (let loop ((rows (exec-query db query))
(evaluations '()))
(match rows
(() (reverse evaluations))
- ((#(id) . rest)
+ (((id) . rest)
(loop rest
(cons id evaluations))))))))
@@ -187,16 +218,19 @@ status = 0 ORDER BY rowid DESC" days)))
;; Average evaluation duration per specification.
(metric
(id 'average-10-last-eval-duration-per-spec)
+ (field-type 'string)
(compute-proc
(cut db-average-eval-duration-per-spec <> #:limit 10)))
(metric
(id 'average-100-last-eval-duration-per-spec)
+ (field-type 'string)
(compute-proc
(cut db-average-eval-duration-per-spec <> #:limit 100)))
(metric
(id 'average-eval-duration-per-spec)
+ (field-type 'string)
(compute-proc db-average-eval-duration-per-spec))
;; Builds count per day.
@@ -220,16 +254,19 @@ status = 0 ORDER BY rowid DESC" days)))
;; Percentage of failed evaluations per specification.
(metric
(id 'percentage-failure-10-last-eval-per-spec)
+ (field-type 'string)
(compute-proc
(cut db-percentage-failed-eval-per-spec <> #:limit 10)))
(metric
(id 'percentage-failure-100-last-eval-per-spec)
+ (field-type 'string)
(compute-proc
(cut db-percentage-failed-eval-per-spec <> #:limit 100)))
(metric
(id 'percentage-failed-eval-per-spec)
+ (field-type 'string)
(compute-proc db-percentage-failed-eval-per-spec))
;; Average time to start a build for an evaluation.
@@ -268,33 +305,38 @@ to identify the metric type in database."
(define* (db-get-metric id field)
"Return the metric with the given ID and FIELD."
- (let* ((metric (find-metric id))
- (type (metric->type metric)))
- (with-db-worker-thread db
- (let ((rows (sqlite-exec db "SELECT value from Metrics
-WHERE type = " type " AND field = " field ";")))
- (and=> (expect-one-row rows) (cut vector-ref <> 0))))))
+ (with-db-worker-thread db
+ (let* ((metric (find-metric id))
+ (type (metric->type metric)))
+ (return-inexact
+ (exec-query/bind db "SELECT value from Metrics
+WHERE type = " type " AND field = " field ";")))))
(define* (db-get-metrics-with-id id
#:key
limit
- (order "rowid DESC"))
+ (order "id DESC"))
"Return the metrics with the given ID. If LIMIT is set, the resulting list
if restricted to LIMIT records."
- (let* ((metric (find-metric id))
- (type (metric->type metric))
- (limit (or limit -1)))
- (with-db-worker-thread db
+ (with-db-worker-thread db
+ (let* ((metric (find-metric id))
+ (type (metric->type metric))
+ (field-type (metric-field-type metric))
+ (limit (or limit "ALL")))
(let ((query (format #f "SELECT field, value from Metrics
-WHERE type = ? ORDER BY ~a LIMIT ~a" order limit)))
- (let loop ((rows (%sqlite-exec db query type))
+WHERE type = :type ORDER BY ~a LIMIT ~a" order limit))
+ (params `((#:type . ,type))))
+ (let loop ((rows (exec-query/bind-params db query params))
(metrics '()))
(match rows
(() (reverse metrics))
- ((#(field value) . rest)
- (loop rest
- `((,field . ,value)
- ,@metrics)))))))))
+ (((field value) . rest)
+ (let ((field (match field-type
+ ('int (string->number field))
+ (else field))))
+ (loop rest
+ `((,field . ,(locale-string->inexact value))
+ ,@metrics))))))))))
(define* (db-update-metric id #:optional field)
"Compute and update the value of the metric ID in database.
@@ -306,67 +348,66 @@ for periodical metrics for instance."
(define now
(time-second (current-time time-utc)))
- (let* ((metric (find-metric id))
- (field-proc (metric-field-proc metric))
- (field (or field (field-proc)))
- (value (compute-metric metric field)))
- (if value
- (begin
- (log-message "Updating metric ~a (~a) to ~a."
- (symbol->string id) field value)
- (with-db-worker-thread db
- (sqlite-exec db "\
-INSERT OR REPLACE INTO Metrics (field, type, value,
+ (with-db-worker-thread db
+ (let* ((metric (find-metric id))
+ (field-proc (metric-field-proc metric))
+ (field (or field (field-proc)))
+ (value (compute-metric metric field)))
+ (if value
+ (begin
+ (log-message "Updating metric ~a (~a) to ~a."
+ (symbol->string id) field value)
+ (exec-query/bind db "\
+INSERT INTO Metrics (field, type, value,
timestamp) VALUES ("
- field ", "
- (metric->type metric) ", "
- value ", "
- now ");")
- (last-insert-rowid db)))
- (log-message "Failed to compute metric ~a (~a)."
- (symbol->string id) field))))
+ field ", "
+ (metric->type metric) ", "
+ value ", "
+ now ")
+ON CONFLICT ON CONSTRAINT metrics_pkey DO
+UPDATE SET value = " value ", timestamp = " now ";"))
+ (log-message "Failed to compute metric ~a (~a)."
+ (symbol->string id) field)))))
(define (db-update-metrics)
"Compute and update all available metrics in database."
- (with-db-writer-worker-thread/force db
- (catch-sqlite-error
- ;; We can not update all evaluations metrics for performance reasons.
- ;; Limit to the evaluations that were added during the past three days.
- (let ((specifications
- (map (cut assq-ref <> #:name) (db-get-specifications)))
- (evaluations (db-latest-evaluations)))
- (sqlite-exec db "BEGIN TRANSACTION;")
-
- (db-update-metric 'builds-per-day)
- (db-update-metric 'new-derivations-per-day)
- (db-update-metric 'pending-builds)
-
- ;; Update specification related metrics.
- (for-each (lambda (spec)
- (db-update-metric
- 'average-10-last-eval-duration-per-spec spec)
- (db-update-metric
- 'average-100-last-eval-duration-per-spec spec)
- (db-update-metric
- 'average-eval-duration-per-spec spec)
-
- (db-update-metric
- 'percentage-failure-10-last-eval-per-spec spec)
- (db-update-metric
- 'percentage-failure-100-last-eval-per-spec spec)
- (db-update-metric
- 'percentage-failed-eval-per-spec spec))
- specifications)
-
- ;; Update evaluation related metrics.
- (for-each (lambda (evaluation)
- (db-update-metric
- 'average-eval-build-start-time evaluation)
- (db-update-metric
- 'average-eval-build-complete-time evaluation)
- (db-update-metric
- 'evaluation-completion-speed evaluation))
- evaluations)
-
- (sqlite-exec db "COMMIT;"))
- (on SQLITE_BUSY_SNAPSHOT => #f))))
+ ;; We can not update all evaluations metrics for performance reasons.
+ ;; Limit to the evaluations that were added during the past three days.
+ (with-db-worker-thread db
+ (let ((specifications
+ (map (cut assq-ref <> #:name) (db-get-specifications)))
+ (evaluations (db-latest-evaluations)))
+ (exec-query db "BEGIN TRANSACTION;")
+
+ (db-update-metric 'builds-per-day)
+ (db-update-metric 'new-derivations-per-day)
+ (db-update-metric 'pending-builds)
+
+ ;; Update specification related metrics.
+ (for-each (lambda (spec)
+ (db-update-metric
+ 'average-10-last-eval-duration-per-spec spec)
+ (db-update-metric
+ 'average-100-last-eval-duration-per-spec spec)
+ (db-update-metric
+ 'average-eval-duration-per-spec spec)
+
+ (db-update-metric
+ 'percentage-failure-10-last-eval-per-spec spec)
+ (db-update-metric
+ 'percentage-failure-100-last-eval-per-spec spec)
+ (db-update-metric
+ 'percentage-failed-eval-per-spec spec))
+ specifications)
+
+ ;; Update evaluation related metrics.
+ (for-each (lambda (evaluation)
+ (db-update-metric
+ 'average-eval-build-start-time evaluation)
+ (db-update-metric
+ 'average-eval-build-complete-time evaluation)
+ (db-update-metric
+ 'evaluation-completion-speed evaluation))
+ evaluations)
+
+ (exec-query db "COMMIT;"))))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index e55e1cb..c32c0aa 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -157,6 +157,7 @@ system whose names start with " (code "guile-") ":" (br)
(define (status-class status)
(cond
+ ((= (build-status submitted) status) "oi oi-clock
text-warning")
((= (build-status scheduled) status) "oi oi-clock
text-warning")
((= (build-status started) status) "oi oi-reload
text-warning")
((= (build-status succeeded) status) "oi oi-check
text-success")
@@ -168,6 +169,7 @@ system whose names start with " (code "guile-") ":" (br)
(define (status-title status)
(cond
+ ((= (build-status submitted) status) "Submitted")
((= (build-status scheduled) status) "Scheduled")
((= (build-status started) status) "Started")
((= (build-status succeeded) status) "Succeeded")
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index f32e3a1..892419a 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -23,6 +23,10 @@
#:use-module (cuirass logging)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
+ #:use-module ((ice-9 suspendable-ports)
+ #:select (current-read-waiter
+ current-write-waiter))
+ #:use-module (ice-9 ports internal)
#:use-module (rnrs bytevectors)
#:use-module (system foreign)
#:use-module (srfi srfi-1)
@@ -106,58 +110,32 @@ delimited continuations and fibers."
(make-parameter #f))
(define* (make-worker-thread-channel initializer
- #:key
- (parallelism 1)
- queue-size
- (queue-proc (const #t)))
+ #:key (parallelism 1))
"Return a channel used to offload work to a dedicated thread. ARGS are the
-arguments of the worker thread procedure. This procedure supports deferring
-work sent to the worker. If QUEUE-SIZE is set, each work query will be
-appended to a queue that will be run once it reaches QUEUE-SIZE elements.
-
-When that happens, the QUEUE-PROC procedure is called with %WORKER-THREAD-ARGS
-and a procedure running the queued work as arguments. The worker thread can
-be passed options. When #:FORCE? option is set, the worker runs the sent work
-immediately even if QUEUE-SIZE has been set."
+arguments of the worker thread procedure."
(parameterize (((@@ (fibers internal) current-fiber) #f))
(let ((channel (make-channel)))
(for-each
(lambda _
(let ((args (initializer)))
(call-with-new-thread
- (lambda ()
- (parameterize ((%worker-thread-args args))
- (let loop ((queue '()))
- (match (get-message channel)
- (((? channel? reply) options (? procedure? proc))
- (put-message
- reply
- (catch #t
- (lambda ()
- (cond
- ((or (not queue-size)
- (assq-ref options #:force?))
+ (parameterize ((current-read-waiter (lambda (port)
+ (port-poll port "r")))
+ (current-write-waiter (lambda (port)
+ (port-poll port "w"))))
+ (lambda ()
+ (parameterize ((%worker-thread-args args))
+ (let loop ()
+ (match (get-message channel)
+ (((? channel? reply) . (? procedure? proc))
+ (put-message
+ reply
+ (catch #t
+ (lambda ()
(apply proc args))
- (else
- (length queue))))
- (lambda (key . args)
- (cons* 'worker-thread-error key args))))
- (let ((new-queue
- (cond
- ((or (not queue-size)
- (assq-ref options #:force?))
- '())
- ((= (1+ (length queue)) queue-size)
- (let ((run-queue
- (lambda ()
- (for-each (lambda (thunk)
- (apply thunk args))
- (append queue (list proc))))))
- (apply queue-proc (append args (list run-queue)))
- '()))
- (else
- (append queue (list proc))))))
- (loop new-queue))))))))))
+ (lambda (key . args)
+ (cons* 'worker-thread-error key args))))))
+ (loop))))))))
(iota parallelism))
channel)))
@@ -225,7 +203,6 @@ put-operation until it succeeds."
(define* (call-with-worker-thread channel proc
#:key
- options
send-timeout
send-timeout-proc
receive-timeout
@@ -239,15 +216,12 @@ to a worker thread.
The same goes for RECEIVE-TIMEOUT and RECEIVE-TIMEOUT-PROC, except that the
timer expires if there is no response from the database worker PROC was sent
-to.
-
-OPTIONS are forwarded to the worker thread. See MAKE-WORKER-THREAD-CHANNEL
-for a description of the supported options."
+to."
(let ((args (%worker-thread-args)))
(if args
(apply proc args)
(let* ((reply (make-channel))
- (message (list reply options proc)))
+ (message (cons reply proc)))
(if (and send-timeout (current-fiber))
(put-message-with-timeout channel message
#:seconds send-timeout
diff --git a/src/schema.sql b/src/schema.sql
index 761b48f..d7c85d9 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -1,5 +1,9 @@
BEGIN TRANSACTION;
+CREATE TABLE SchemaVersion (
+ version INTEGER NOT NULL
+);
+
CREATE TABLE Specifications (
name TEXT NOT NULL PRIMARY KEY,
load_path_inputs TEXT NOT NULL, -- list of input names whose load path will
be in Guile's %load-path
@@ -23,41 +27,34 @@ CREATE TABLE Inputs (
revision TEXT,
no_compile_p INTEGER,
PRIMARY KEY (specification, name),
- FOREIGN KEY (specification) REFERENCES Specifications (name)
-);
-
-CREATE TABLE Checkouts (
- specification TEXT NOT NULL,
- revision TEXT NOT NULL,
- evaluation INTEGER NOT NULL,
- input TEXT NOT NULL,
- directory TEXT NOT NULL,
- timestamp INTEGER NOT NULL,
- PRIMARY KEY (specification, revision),
- FOREIGN KEY (evaluation) REFERENCES Evaluations (id),
- FOREIGN KEY (specification) REFERENCES Specifications (name),
- FOREIGN KEY (input) REFERENCES Inputs (name)
+ FOREIGN KEY (specification) REFERENCES Specifications(name)
);
CREATE TABLE Evaluations (
- id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
+ id SERIAL PRIMARY KEY,
specification TEXT NOT NULL,
status INTEGER NOT NULL,
timestamp INTEGER NOT NULL,
checkouttime INTEGER NOT NULL,
evaltime INTEGER NOT NULL,
- FOREIGN KEY (specification) REFERENCES Specifications (name)
+ FOREIGN KEY (specification) REFERENCES Specifications(name)
);
-CREATE TABLE Outputs (
- derivation TEXT NOT NULL,
- name TEXT NOT NULL,
- path TEXT NOT NULL PRIMARY KEY,
- FOREIGN KEY (derivation) REFERENCES Builds (derivation)
+CREATE TABLE Checkouts (
+ specification TEXT NOT NULL,
+ revision TEXT NOT NULL,
+ evaluation INTEGER NOT NULL,
+ input TEXT NOT NULL,
+ directory TEXT NOT NULL,
+ timestamp INTEGER NOT NULL,
+ PRIMARY KEY (specification, revision),
+ FOREIGN KEY (evaluation) REFERENCES Evaluations(id),
+ FOREIGN KEY (specification) REFERENCES Specifications(name),
+ FOREIGN KEY (specification, input) REFERENCES Inputs(specification, name)
);
CREATE TABLE Builds (
- id INTEGER NOT NULL PRIMARY KEY,
+ id SERIAL PRIMARY KEY,
derivation TEXT NOT NULL UNIQUE,
evaluation INTEGER NOT NULL,
job_name TEXT NOT NULL,
@@ -72,11 +69,19 @@ CREATE TABLE Builds (
timestamp INTEGER NOT NULL,
starttime INTEGER NOT NULL,
stoptime INTEGER NOT NULL,
- FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
+ FOREIGN KEY (evaluation) REFERENCES Evaluations(id)
+);
+
+CREATE TABLE Outputs (
+ derivation TEXT NOT NULL,
+ name TEXT NOT NULL,
+ path TEXT NOT NULL PRIMARY KEY,
+ FOREIGN KEY (derivation) REFERENCES Builds(derivation) ON DELETE CASCADE
);
CREATE TABLE Metrics (
- field INTEGER NOT NULL,
+ id SERIAL,
+ field TEXT NOT NULL,
type INTEGER NOT NULL,
value DOUBLE PRECISION NOT NULL,
timestamp INTEGER NOT NULL,
@@ -84,17 +89,18 @@ CREATE TABLE Metrics (
);
CREATE TABLE BuildProducts (
+ id SERIAL,
build INTEGER NOT NULL,
type TEXT NOT NULL,
file_size BIGINT NOT NULL,
checksum TEXT NOT NULL,
path TEXT NOT NULL,
- PRIMARY KEY (build, path)
- FOREIGN KEY (build) REFERENCES Builds (id) ON DELETE CASCADE
+ PRIMARY KEY (build, path),
+ FOREIGN KEY (build) REFERENCES Builds(id) ON DELETE CASCADE
);
CREATE TABLE Events (
- id INTEGER PRIMARY KEY,
+ id SERIAL PRIMARY KEY,
type TEXT NOT NULL,
timestamp INTEGER NOT NULL,
event_json TEXT NOT NULL
@@ -112,12 +118,12 @@ CREATE TABLE Workers (
CREATE INDEX Builds_status_index ON Builds (status);
CREATE INDEX Builds_evaluation_index ON Builds (evaluation, status);
CREATE INDEX Builds_job_name_timestamp on Builds(job_name, timestamp);
-CREATE INDEX Builds_nix_name ON Builds (nix_name COLLATE NOCASE);
+CREATE INDEX Builds_nix_name ON Builds (nix_name);
CREATE INDEX Builds_timestamp_stoptime on Builds(timestamp, stoptime);
CREATE INDEX Builds_stoptime on Builds(stoptime DESC);
CREATE INDEX Builds_stoptime_id on Builds(stoptime DESC, id DESC);
CREATE INDEX Builds_status_ts_id on Builds(status DESC, timestamp DESC, id
ASC);
-CREATE INDEX Builds_priority_timestamp on Builds(priority DESC, timestamp ASC);
+CREATE INDEX Builds_priority_timestamp on Builds(priority ASC, timestamp DESC);
CREATE INDEX Evaluations_status_index ON Evaluations (id, status);
CREATE INDEX Evaluations_specification_index ON Evaluations (specification, id
DESC);
diff --git a/src/sql/upgrade-1.sql b/src/sql/upgrade-1.sql
index 7874f94..5ec73bf 100644
--- a/src/sql/upgrade-1.sql
+++ b/src/sql/upgrade-1.sql
@@ -1,78 +1,3 @@
BEGIN TRANSACTION;
-DROP INDEX Specifications_index;
-
-ALTER TABLE Specifications RENAME TO tmp_Specifications;
-ALTER TABLE Stamps RENAME TO tmp_Stamps;
-ALTER TABLE Evaluations RENAME TO tmp_Evaluations;
-
-CREATE TABLE Specifications (
- name TEXT NOT NULL PRIMARY KEY,
- load_path_inputs TEXT NOT NULL, -- list of input names whose load path will
be in Guile's %load-path
- package_path_inputs TEXT NOT NULL, -- list of input names whose load paths
will be in GUIX_PACKAGE_PATH
- proc_input TEXT NOT NULL, -- name of the input containing the proc that
does the evaluation
- proc_file TEXT NOT NULL, -- file containing the procedure that does the
evaluation, relative to proc_input
- proc TEXT NOT NULL, -- defined in proc_file
- proc_args TEXT NOT NULL -- passed to proc
-);
-
-CREATE TABLE Inputs (
- specification TEXT NOT NULL,
- name TEXT NOT NULL,
- url TEXT NOT NULL,
- load_path TEXT NOT NULL,
- -- The following columns are optional.
- branch TEXT,
- tag TEXT,
- revision TEXT,
- no_compile_p INTEGER,
- PRIMARY KEY (specification, name),
- FOREIGN KEY (specification) REFERENCES Specifications (name)
-);
-
-CREATE TABLE Stamps (
- specification TEXT NOT NULL PRIMARY KEY,
- stamp TEXT NOT NULL,
- FOREIGN KEY (specification) REFERENCES Specifications (name)
-);
-
-CREATE TABLE Evaluations (
- id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
- specification TEXT NOT NULL,
- commits TEXT NOT NULL,
- FOREIGN KEY (specification) REFERENCES Specifications (name)
-);
-
-INSERT INTO Specifications (name, load_path_inputs, package_path_inputs,
proc_input, proc_file, proc, proc_args)
-SELECT printf('%s-%s', repo_name, branch) AS name,
- printf('("%s")', repo_name) AS load_path_inputs,
- '()' AS package_path_inputs,
- repo_name AS proc_input,
- file AS proc_file,
- proc,
- arguments AS proc_args
-FROM tmp_Specifications;
-
-INSERT INTO Inputs (specification, name, url, load_path, branch, tag,
revision, no_compile_p)
-SELECT printf('%s-%s', repo_name, branch) AS specification,
- repo_name AS name,
- url, load_path, branch, tag, revision, no_compile_p
-FROM tmp_Specifications;
-
-INSERT INTO Stamps (specification, stamp)
-SELECT Specifications.name AS specification, stamp
-FROM tmp_Stamps
-LEFT JOIN Specifications ON Specifications.proc_input =
tmp_Stamps.specification;
-
-INSERT INTO Evaluations (id, specification, commits)
-SELECT id, Specifications.name AS specification, revision
-FROM tmp_Evaluations
-LEFT JOIN Specifications ON Specifications.proc_input =
tmp_Evaluations.specification;
-
-CREATE INDEX Inputs_index ON Inputs(specification, name, branch);
-
-DROP TABLE tmp_Specifications;
-DROP TABLE tmp_Stamps;
-DROP TABLE tmp_Evaluations;
-
COMMIT;
diff --git a/src/sql/upgrade-10.sql b/src/sql/upgrade-10.sql
deleted file mode 100644
index 0ad299c..0000000
--- a/src/sql/upgrade-10.sql
+++ /dev/null
@@ -1,12 +0,0 @@
-BEGIN TRANSACTION;
-
-ALTER TABLE Evaluations RENAME COLUMN in_progress TO status;
-
--- Set all pending evaluations to aborted.
-UPDATE Evaluations SET status = 2 WHERE status = 1;
-
--- All evaluations that did not trigger any build are set to failed.
-UPDATE Evaluations SET status = 1 WHERE id NOT IN
-(SELECT evaluation FROM Builds);
-
-COMMIT;
diff --git a/src/sql/upgrade-11.sql b/src/sql/upgrade-11.sql
deleted file mode 100644
index 22f2dac..0000000
--- a/src/sql/upgrade-11.sql
+++ /dev/null
@@ -1,11 +0,0 @@
-BEGIN TRANSACTION;
-
-CREATE TABLE Metrics (
- field INTEGER NOT NULL,
- type INTEGER NOT NULL,
- value DOUBLE PRECISION NOT NULL,
- timestamp INTEGER NOT NULL,
- PRIMARY KEY (field, type)
-);
-
-COMMIT;
diff --git a/src/sql/upgrade-12.sql b/src/sql/upgrade-12.sql
deleted file mode 100644
index 06aaffe..0000000
--- a/src/sql/upgrade-12.sql
+++ /dev/null
@@ -1,7 +0,0 @@
-BEGIN TRANSACTION;
-
-CREATE INDEX Builds_evaluation_index ON Builds (evaluation, status);
-CREATE INDEX Evaluations_status_index ON Evaluations (id, status);
-CREATE INDEX Evaluations_specification_index ON Evaluations (specification, id
DESC);
-
-COMMIT;
diff --git a/src/sql/upgrade-13.sql b/src/sql/upgrade-13.sql
deleted file mode 100644
index b7a0cb5..0000000
--- a/src/sql/upgrade-13.sql
+++ /dev/null
@@ -1,5 +0,0 @@
-BEGIN TRANSACTION;
-
-CREATE INDEX Builds_nix_name ON Builds (nix_name COLLATE NOCASE);
-
-COMMIT;
diff --git a/src/sql/upgrade-14.sql b/src/sql/upgrade-14.sql
deleted file mode 100644
index 566077c..0000000
--- a/src/sql/upgrade-14.sql
+++ /dev/null
@@ -1,5 +0,0 @@
-BEGIN TRANSACTION;
-
-CREATE INDEX Builds_timestamp_stoptime on Builds(timestamp, stoptime);
-
-COMMIT;
diff --git a/src/sql/upgrade-15.sql b/src/sql/upgrade-15.sql
deleted file mode 100644
index 1fc38d6..0000000
--- a/src/sql/upgrade-15.sql
+++ /dev/null
@@ -1,7 +0,0 @@
-BEGIN TRANSACTION;
-
-CREATE INDEX Builds_stoptime on Builds(stoptime DESC);
-CREATE INDEX Builds_stoptime_id on Builds(stoptime DESC, id DESC);
-CREATE INDEX Builds_status_ts_id on Builds(status DESC, timestamp DESC, id
ASC);
-
-COMMIT;
diff --git a/src/sql/upgrade-16.sql b/src/sql/upgrade-16.sql
deleted file mode 100644
index 47d498c..0000000
--- a/src/sql/upgrade-16.sql
+++ /dev/null
@@ -1,5 +0,0 @@
-BEGIN TRANSACTION;
-
-CREATE INDEX Builds_job_name_timestamp on Builds(job_name, timestamp);
-
-COMMIT;
diff --git a/src/sql/upgrade-17.sql b/src/sql/upgrade-17.sql
deleted file mode 100644
index 065ca5f..0000000
--- a/src/sql/upgrade-17.sql
+++ /dev/null
@@ -1,5 +0,0 @@
-BEGIN TRANSACTION;
-
-ALTER TABLE Builds ADD worker TEXT DEFAULT NULL;
-
-COMMIT;
diff --git a/src/sql/upgrade-18.sql b/src/sql/upgrade-18.sql
deleted file mode 100644
index 13b9f01..0000000
--- a/src/sql/upgrade-18.sql
+++ /dev/null
@@ -1,10 +0,0 @@
-BEGIN TRANSACTION;
-
-CREATE TABLE Workers (
- name TEXT NOT NULL PRIMARY KEY,
- address TEXT NOT NULL,
- systems TEXT NOT NULL,
- last_seen INTEGER NOT NULL
-);
-
-COMMIT;
diff --git a/src/sql/upgrade-19.sql b/src/sql/upgrade-19.sql
deleted file mode 100644
index 4213e11..0000000
--- a/src/sql/upgrade-19.sql
+++ /dev/null
@@ -1,11 +0,0 @@
-BEGIN TRANSACTION;
-
-ALTER TABLE Specifications ADD priority INTEGER NOT NULL DEFAULT 0;
-
-ALTER TABLE Builds ADD priority INTEGER NOT NULL DEFAULT 0;
-ALTER TABLE Builds ADD max_silent INTEGER NOT NULL DEFAULT 0;
-ALTER TABLE Builds ADD timeout INTEGER NOT NULL DEFAULT 0;
-
-CREATE INDEX Builds_priority_timestamp on Builds(priority DESC, timestamp ASC);
-
-COMMIT;
diff --git a/src/sql/upgrade-2.sql b/src/sql/upgrade-2.sql
deleted file mode 100644
index dfb919b..0000000
--- a/src/sql/upgrade-2.sql
+++ /dev/null
@@ -1,49 +0,0 @@
-BEGIN TRANSACTION;
-
-DROP INDEX Derivations_index;
-DROP INDEX Builds_Derivations_index;
-
-ALTER TABLE Outputs RENAME TO tmp_Outputs;
-ALTER TABLE Builds RENAME TO tmp_Builds;
-
-CREATE TABLE Builds (
- derivation TEXT NOT NULL PRIMARY KEY,
- evaluation INTEGER NOT NULL,
- job_name TEXT NOT NULL,
- system TEXT NOT NULL,
- nix_name TEXT NOT NULL,
- log TEXT NOT NULL,
- status INTEGER NOT NULL,
- timestamp INTEGER NOT NULL,
- starttime INTEGER NOT NULL,
- stoptime INTEGER NOT NULL,
- FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
-);
-
-CREATE TABLE Outputs (
- derivation TEXT NOT NULL,
- name TEXT NOT NULL,
- path TEXT NOT NULL,
- PRIMARY KEY (derivation, name),
- FOREIGN KEY (derivation) REFERENCES Builds (derivation)
-);
-
-INSERT OR IGNORE INTO Builds (derivation, evaluation, job_name, system,
nix_name, log, status, timestamp, starttime, stoptime)
-SELECT Derivations.derivation, Derivations.evaluation, Derivations.job_name,
Derivations.system, Derivations.nix_name,
- tmp_Builds.log, tmp_Builds.status, tmp_Builds.timestamp,
tmp_Builds.starttime, tmp_Builds.stoptime
-FROM Derivations
-INNER JOIN tmp_Builds ON tmp_Builds.derivation = Derivations.derivation
- AND tmp_Builds.evaluation = Derivations.evaluation;
-
-INSERT OR IGNORE INTO Outputs (derivation, name, path)
-SELECT tmp_Builds.derivation, tmp_Outputs.name, tmp_Outputs.path
-FROM tmp_Outputs
-INNER JOIN tmp_Builds on tmp_Builds.id = tmp_Outputs.build;
-
-CREATE INDEX Builds_index ON Builds(job_name, system, status ASC, timestamp
ASC, derivation, evaluation, stoptime DESC);
-
-DROP TABLE tmp_Builds;
-DROP TABLE tmp_Outputs;
-DROP TABLE Derivations;
-
-COMMIT;
diff --git a/src/sql/upgrade-3.sql b/src/sql/upgrade-3.sql
deleted file mode 100644
index 8e4a1bd..0000000
--- a/src/sql/upgrade-3.sql
+++ /dev/null
@@ -1,46 +0,0 @@
-BEGIN TRANSACTION;
-
-ALTER TABLE Evaluations RENAME TO tmp_Evaluations;
-
-CREATE TABLE Evaluations (
- id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
- specification TEXT NOT NULL,
- in_progress INTEGER NOT NULL,
- FOREIGN KEY (specification) REFERENCES Specifications (name)
-);
-
-CREATE TABLE Checkouts (
- specification TEXT NOT NULL,
- revision TEXT NOT NULL,
- evaluation INTEGER NOT NULL,
- input TEXT NOT NULL,
- directory TEXT NOT NULL,
- PRIMARY KEY (specification, revision),
- FOREIGN KEY (evaluation) REFERENCES Evaluations (id),
- FOREIGN KEY (specification) REFERENCES Specifications (name),
- FOREIGN KEY (input) REFERENCES Inputs (name)
-);
-
-INSERT INTO Evaluations (id, specification, in_progress)
-SELECT id, specification, false
-FROM tmp_Evaluations;
-
--- Copied from https://www.samuelbosch.com/2018/02/split-into-rows-sqlite.html.
-INSERT OR IGNORE INTO Checkouts (specification, revision, evaluation, input,
directory)
-WITH RECURSIVE split(id, specification, revision, rest) AS (
- SELECT id, specification, '', commits || ' ' FROM tmp_Evaluations
- UNION ALL
- SELECT id,
- specification,
- substr(rest, 0, instr(rest, ' ')),
- substr(rest, instr(rest, ' ') + 1)
- FROM split
- WHERE rest <> '')
-SELECT specification, revision, id, 'unknown', 'unknown'
- FROM split
- WHERE revision <> '';
-
-DROP TABLE tmp_Evaluations;
-DROP TABLE Stamps;
-
-COMMIT;
diff --git a/src/sql/upgrade-4.sql b/src/sql/upgrade-4.sql
deleted file mode 100644
index e567f03..0000000
--- a/src/sql/upgrade-4.sql
+++ /dev/null
@@ -1,18 +0,0 @@
-BEGIN TRANSACTION;
-
-ALTER TABLE Outputs RENAME TO tmp_Outputs;
-
-CREATE TABLE Outputs (
- derivation TEXT NOT NULL,
- name TEXT NOT NULL,
- path TEXT NOT NULL PRIMARY KEY,
- FOREIGN KEY (derivation) REFERENCES Builds (derivation)
-);
-
-INSERT OR IGNORE INTO Outputs (derivation, name, path)
-SELECT derivation, name, path
-FROM tmp_Outputs;
-
-DROP TABLE tmp_Outputs;
-
-COMMIT;
diff --git a/src/sql/upgrade-5.sql b/src/sql/upgrade-5.sql
deleted file mode 100644
index 8f30bde..0000000
--- a/src/sql/upgrade-5.sql
+++ /dev/null
@@ -1,15 +0,0 @@
-BEGIN TRANSACTION;
-
-CREATE TABLE Events (
- id INTEGER PRIMARY KEY,
- type TEXT NOT NULL,
- timestamp INTEGER NOT NULL,
- event_json TEXT NOT NULL
-);
-
-CREATE TABLE EventsOutbox (
- event_id INTEGER NOT NULL,
- FOREIGN KEY (event_id) REFERENCES Events (id)
-);
-
-COMMIT;
diff --git a/src/sql/upgrade-6.sql b/src/sql/upgrade-6.sql
deleted file mode 100644
index 0b25aa5..0000000
--- a/src/sql/upgrade-6.sql
+++ /dev/null
@@ -1,47 +0,0 @@
-BEGIN TRANSACTION;
-
-ALTER TABLE Builds RENAME TO OldBuilds;
-
-CREATE TABLE Builds (
- id INTEGER NOT NULL PRIMARY KEY,
- derivation TEXT NOT NULL UNIQUE,
- evaluation INTEGER NOT NULL,
- job_name TEXT NOT NULL,
- system TEXT NOT NULL,
- nix_name TEXT NOT NULL,
- log TEXT NOT NULL,
- status INTEGER NOT NULL,
- timestamp INTEGER NOT NULL,
- starttime INTEGER NOT NULL,
- stoptime INTEGER NOT NULL,
- FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
-);
-
-INSERT INTO Builds(
- id,
- derivation,
- evaluation,
- job_name,
- system,
- nix_name,
- log,
- status,
- timestamp,
- starttime,
- stoptime
-) SELECT rowid,
- derivation,
- evaluation,
- job_name,
- system,
- nix_name,
- log,
- status,
- timestamp,
- starttime,
- stoptime
- FROM OldBuilds;
-
-DROP TABLE OldBuilds;
-
-COMMIT;
diff --git a/src/sql/upgrade-7.sql b/src/sql/upgrade-7.sql
deleted file mode 100644
index b9bd4ff..0000000
--- a/src/sql/upgrade-7.sql
+++ /dev/null
@@ -1,15 +0,0 @@
-BEGIN TRANSACTION;
-
-CREATE TABLE BuildProducts (
- build INTEGER NOT NULL,
- type TEXT NOT NULL,
- file_size BIGINT NOT NULL,
- checksum TEXT NOT NULL,
- path TEXT NOT NULL,
- PRIMARY KEY (build, path)
- FOREIGN KEY (build) REFERENCES Builds (id) ON DELETE CASCADE
-);
-
-ALTER TABLE Specifications ADD build_outputs TEXT NOT NULL DEFAULT "()";
-
-COMMIT;
diff --git a/src/sql/upgrade-8.sql b/src/sql/upgrade-8.sql
deleted file mode 100644
index 1be3470..0000000
--- a/src/sql/upgrade-8.sql
+++ /dev/null
@@ -1,7 +0,0 @@
-BEGIN TRANSACTION;
-
-CREATE INDEX Builds_status_index ON Builds (status);
-
-CREATE INDEX Outputs_derivation_index ON Outputs (derivation);
-
-COMMIT;
diff --git a/src/sql/upgrade-9.sql b/src/sql/upgrade-9.sql
deleted file mode 100644
index 4de411a..0000000
--- a/src/sql/upgrade-9.sql
+++ /dev/null
@@ -1,9 +0,0 @@
-BEGIN TRANSACTION;
-
-ALTER TABLE Evaluations ADD timestamp INTEGER NOT NULL DEFAULT 0;
-ALTER TABLE Evaluations ADD checkouttime INTEGER NOT NULL DEFAULT 0;
-ALTER TABLE Evaluations ADD evaltime INTEGER NOT NULL DEFAULT 0;
-
-ALTER TABLE Checkouts ADD timestamp INTEGER NOT NULL DEFAULT 0;
-
-COMMIT;
diff --git a/tests/database.scm b/tests/database.scm
index d5fa060..406635b 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -21,8 +21,12 @@
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(use-modules (cuirass database)
- ((guix utils) #:select (call-with-temporary-output-file))
+ (cuirass remote)
(cuirass utils)
+ ((guix utils) #:select (call-with-temporary-output-file))
+ (squee)
+ (ice-9 match)
+ (srfi srfi-19)
(srfi srfi-64))
(define example-spec
@@ -33,15 +37,15 @@
(#:proc-file . "/tmp/gnu-system.scm")
(#:proc . hydra-jobs)
(#:proc-args (subset . "hello"))
- (#:inputs . (((#:name . "savannah")
- (#:url . "git://git.savannah.gnu.org/guix.git")
+ (#:inputs . (((#:name . "maintenance")
+ (#:url . "git://git.savannah.gnu.org/guix/maintenance.git")
(#:load-path . ".")
(#:branch . "master")
(#:tag . #f)
(#:commit . #f)
(#:no-compile? . #f))
- ((#:name . "maintenance")
- (#:url . "git://git.savannah.gnu.org/guix/maintenance.git")
+ ((#:name . "savannah")
+ (#:url . "git://git.savannah.gnu.org/guix.git")
(#:load-path . ".")
(#:branch . "master")
(#:tag . #f)
@@ -52,173 +56,353 @@
(define (make-dummy-checkouts fakesha1 fakesha2)
`(((#:commit . ,fakesha1)
- (#:input . "guix")
+ (#:input . "savannah")
(#:directory . "foo"))
((#:commit . ,fakesha2)
- (#:input . "packages")
+ (#:input . "maintenance")
(#:directory . "bar"))))
(define* (make-dummy-build drv
- #:optional (eval-id 42)
+ #:optional (eval-id 2)
#:key (outputs
`(("foo" . ,(format #f "~a.output" drv)))))
`((#:derivation . ,drv)
(#:eval-id . ,eval-id)
(#:job-name . "job")
+ (#:timestamp . ,(time-second (current-time time-utc)))
(#:system . "x86_64-linux")
(#:nix-name . "foo")
(#:log . "log")
(#:outputs . ,outputs)))
-(define-syntax-rule (with-temporary-database body ...)
- (call-with-temporary-output-file
- (lambda (file port)
- (parameterize ((%package-database file))
- (db-init file)
- (with-database
- (parameterize ((%db-writer-channel (%db-channel)))
- body ...))))))
+(define %dummy-worker
+ (worker
+ (name "worker")
+ (address "address")
+ (systems '("a" "b"))
+ (last-seen "1")))
(define %db
- ;; Global Slot for a database object.
- (make-parameter #t))
+ (make-parameter #f))
-(define database-name
- ;; Use an empty and temporary database for the tests.
- (string-append (getcwd) "/" (number->string (getpid)) "-tmp.db"))
+(define db-name "test_database")
+(%record-events? #t)
(test-group-with-cleanup "database"
(test-assert "db-init"
(begin
- (%db (db-init database-name))
+ (%db (db-open))
(%db-channel (make-worker-thread-channel
(lambda ()
(list (%db)))))
- (%db-writer-channel (%db-channel))
#t))
- (test-assert "sqlite-exec"
- (begin
- (sqlite-exec (%db) "\
-INSERT INTO Evaluations (specification, status,
-timestamp, checkouttime, evaltime) VALUES (1, 0, 0, 0, 0);")
- (sqlite-exec (%db) "\
-INSERT INTO Evaluations (specification, status,
-timestamp, checkouttime, evaltime) VALUES (2, 0, 0, 0, 0);")
- (sqlite-exec (%db) "\
-INSERT INTO Evaluations (specification, status,
-timestamp, checkouttime, evaltime) VALUES (3, 0, 0, 0, 0);")
- (sqlite-exec (%db) "SELECT * FROM Evaluations;")))
-
(test-equal "db-add-specification"
- example-spec
+ "guix"
+ (db-add-specification example-spec))
+
+ (test-assert "exec-query"
(begin
- (db-add-specification example-spec)
- (car (db-get-specifications))))
+ (exec-query (%db) "\
+INSERT INTO Evaluations (specification, status,
+timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
+ (exec-query (%db) "SELECT * FROM Evaluations;")))
(test-equal "db-get-specification"
example-spec
(db-get-specification "guix"))
+ (test-equal "db-add-evaluation"
+ '(2 3)
+ (list
+ (db-add-evaluation "guix"
+ (make-dummy-checkouts "fakesha1" "fakesha2"))
+ (db-add-evaluation "guix"
+ (make-dummy-checkouts "fakesha3" "fakesha4"))))
+
+ (test-assert "db-set-evaluation-status"
+ (db-set-evaluation-status 2 (evaluation-status started)))
+
+ (test-assert "db-set-evaluation-time"
+ (db-set-evaluation-time 2))
+
+ (test-assert "db-abort-pending-evaluations"
+ (db-abort-pending-evaluations))
+
(test-equal "db-add-build"
- #f
+ "/foo.drv"
+ (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)
+ (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"))))
+
+ (test-equal "db-get-output"
+ '((#:derivation . "/foo.drv") (#:name . "foo"))
+ (db-get-output "/foo.drv.output"))
+
+ (test-equal "db-get-outputs"
+ '(("foo" (#:path . "/foo.drv.output")))
+ (db-get-outputs "/foo.drv"))
+
+ (test-assert "db-get-time-since-previous-build"
+ (db-get-time-since-previous-build "job" "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"))))
+
+ (test-assert "db-update-build-status!"
+ (db-update-build-status! "/test.drv"
+ (build-status failed)))
- ;; Should return #f when adding a build whose derivation is already
- ;; there, see <https://bugs.gnu.org/28094>.
- (catch-sqlite-error
- (db-add-build build)
- (on SQLITE_CONSTRAINT_UNIQUE => #f))))
+ (test-assert "db-update-build-worker!"
+ (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))))
+
+ (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"))))))
+
+ (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)))
+
+ (test-equal "db-get-build"
+ "/foo.drv"
+ (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)))
+
+ (test-equal "db-get-events"
+ 'evaluation
+ (let ((event (match (db-get-events '((nr . 1)
+ (type . evaluation)))
+ ((event) event))))
+ (assoc-ref event #:type)))
+
+ (test-equal "db-delete-events-with-ids-<=-to"
+ 1
+ (db-delete-events-with-ids-<=-to 1))
+
+ (test-equal "db-get-pending-derivations"
+ '("/foo.drv")
+ (db-get-pending-derivations))
+
+ (test-assert "db-get-checkouts"
+ (equal? (db-get-checkouts 2)
+ (make-dummy-checkouts "fakesha1" "fakesha2")))
+
+ (test-equal "db-get-evaluation"
+ "guix"
+ (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)))
+
+ (test-equal "db-get-evaluations-build-summary"
+ '((0 0 0) (0 1 1))
+ (let ((summaries
+ (db-get-evaluations-build-summary "guix" 2 #f #f)))
+ (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"))
+
+ (test-equal "db-get-evaluations-id-min"
+ #f
+ (db-get-evaluations-id-min "foo"))
+
+ (test-equal "db-get-evaluations-id-max"
+ 3
+ (db-get-evaluations-id-max "guix"))
+
+ (test-equal "db-get-evaluations-id-max"
+ #f
+ (db-get-evaluations-id-max "foo"))
+
+ (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)))
+
+ (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)))
+
+ (test-equal "db-get-builds-query-min"
+ '(1)
+ (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"))
+
+ (test-equal "db-get-builds-min"
+ 3
+ (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)))
+
+ (test-equal "db-get-evaluation-specification"
+ "guix"
+ (db-get-evaluation-specification 2))
+
+ (test-equal "db-get-build-products"
+ `(((#:id . 1)
+ (#:type . "1")
+ (#:file-size . 1)
+ (#:checksum . "sum")
+ (#:path . "path")))
+ (db-get-build-products 1))
+
+ (test-equal "db-get-build-product-path"
+ "path"
+ (db-get-build-product-path 1))
+
+ (test-equal "db-add-worker"
+ 1
+ (db-add-worker %dummy-worker))
+
+ (test-equal "db-get-workers"
+ (list %dummy-worker)
+ (db-get-workers))
+
+ (test-equal "db-clear-workers"
+ '()
+ (begin
+ (db-clear-workers)
+ (db-get-workers)))
(test-equal "db-update-build-status!"
(list (build-status scheduled)
(build-status started)
(build-status succeeded)
- "/foo.drv.log")
- (with-temporary-database
- (let* ((derivation (db-add-build
- (make-dummy-build "/foo.drv" 1
- #:outputs '(("out" . "/foo")))))
- (get-status (lambda* (#:optional (key #:status))
- (assq-ref (db-get-build derivation) key))))
- (db-add-evaluation "guix" (make-dummy-checkouts "fakesha1"
- "fakesha2"))
- (db-add-specification example-spec)
-
- (let ((status0 (get-status)))
- (db-update-build-status! "/foo.drv" (build-status started))
- (let ((status1 (get-status)))
- (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! "/foo.drv" (build-status succeeded)
- #:log-file "/foo.drv.log")
-
- (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))))))))
+ "/foo2.drv.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))
+ (let ((status1 (get-status)))
+ (db-update-build-status! "/foo2.drv" (build-status succeeded)
+ #:log-file "/foo2.drv.log")
+
+ ;; Second call shouldn't make any difference.
+ (db-update-build-status! "/foo2.drv" (build-status succeeded)
+ #:log-file "/foo2.drv.log")
+
+ (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"
- #(((1 "/foo.drv") (2 "/bar.drv") (3 "/baz.drv")) ;ascending order
- ((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;descending order
- ((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
- ;; Populate the 'Builds'', 'Evaluations', and
- ;; 'Specifications' tables in a consistent way, as expected by the
- ;; 'db-get-builds' query.
- (db-add-build (make-dummy-build "/foo.drv" 1
- #:outputs `(("out" . "/foo"))))
+ '(("/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
+ (exec-query (%db) "DELETE FROM Builds;")
+ (db-add-build (make-dummy-build "/baa.drv" 2
+ #:outputs `(("out" . "/baa"))))
(db-add-build (make-dummy-build "/bar.drv" 2
#:outputs `(("out" . "/bar"))))
- (db-add-build (make-dummy-build "/baz.drv" 3
+ (db-add-build (make-dummy-build "/baz.drv" 2
#:outputs `(("out" . "/baz"))))
- (db-add-evaluation "guix" (make-dummy-checkouts "fakesha1" "fakesha2"))
- (db-add-evaluation "guix" (make-dummy-checkouts "fakesha1" "fakesha3"))
- (db-add-evaluation "guix" (make-dummy-checkouts "fakssha2" "fakesha3"))
- (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 '((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 '((order . status+submission-time))))))))
+ (assq-ref alist #:derivation))))
+ (list (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 '((order . status+submission-time))))))))
(test-equal "db-get-pending-derivations"
'("/bar.drv" "/foo.drv")
- (with-temporary-database
- ;; Populate the 'Builds', 'Evaluations', and 'Specifications' tables.
+ (begin
+ (exec-query (%db) "DELETE FROM Builds;")
(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-evaluation "guix" (make-dummy-checkouts "fakesha1" "fakesha2"))
- (db-add-evaluation "guix" (make-dummy-checkouts "fakesha1" "fakesha3"))
- (db-add-evaluation "guix" (make-dummy-checkouts "fakssha2" "fakesha3"))
- (db-add-specification example-spec)
-
(sort (db-get-pending-derivations) string<?)))
(test-assert "db-close"
- (db-close (%db)))
-
- (begin
- (%db-channel #f)
- (delete-file database-name)))
-
-;;; Local Variables:
-;;; eval: (put 'with-temporary-database 'scheme-indent-function 0)
-;;; End:
+ (begin
+ (exec-query (%db) (format #f "DROP OWNED BY CURRENT_USER;"))
+ (db-close (%db))
+ #t)))
diff --git a/tests/http.scm b/tests/http.scm
index 02f4b08..fb0d858 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -24,6 +24,7 @@
(cuirass utils)
(json)
(fibers)
+ (squee)
(web uri)
(web client)
(web response)
@@ -48,13 +49,8 @@
(define (test-cuirass-uri route)
(string-append "http://localhost:6688"; route))
-(define database-name
- ;; Use an empty and temporary database for the tests.
- (string-append (getcwd) "/" (number->string (getpid)) "-tmp.db"))
-
(define %db
- ;; Global Slot for a database object.
- (make-parameter #t))
+ (make-parameter #f))
(define build-query-result
'((#:id . 1)
@@ -111,11 +107,10 @@
(test-assert "db-init"
(begin
- (%db (db-init database-name))
+ (%db (db-open))
(%db-channel (make-worker-thread-channel
(lambda ()
(list (%db)))))
- (%db-writer-channel (%db-channel))
#t))
(test-assert "cuirass-run"
@@ -191,13 +186,13 @@
((#:commit . "fakesha3")
(#:input . "packages")
(#:directory . "dir4")))))
- (db-add-build build1)
- (db-add-build build2)
(db-add-specification specification)
(db-add-evaluation "guix" checkouts1
#:timestamp 1501347493)
(db-add-evaluation "guix" checkouts2
- #:timestamp 1501347493)))
+ #:timestamp 1501347493)
+ (db-add-build build1)
+ (db-add-build build2)))
(test-assert "/specifications"
(match (call-with-input-string
@@ -290,8 +285,7 @@
(http-get-body (test-cuirass-uri "/api/evaluations?nr=1")))))
(test-assert "db-close"
- (db-close (%db)))
-
- (begin
- (%db-channel #f)
- (delete-file database-name)))
+ (begin
+ (exec-query (%db) (format #f "DROP OWNED BY CURRENT_USER;"))
+ (db-close (%db))
+ #t)))
diff --git a/tests/metrics.scm b/tests/metrics.scm
index b957d88..efa1a8e 100644
--- a/tests/metrics.scm
+++ b/tests/metrics.scm
@@ -21,16 +21,9 @@
(cuirass metrics)
(cuirass utils)
((guix utils) #:select (call-with-temporary-output-file))
+ (squee)
(srfi srfi-64))
-(define-syntax-rule (with-temporary-database body ...)
- (call-with-temporary-output-file
- (lambda (file port)
- (parameterize ((%package-database file))
- (db-init file)
- (with-database
- body ...)))))
-
(define today
(let ((time (current-time)))
(- time (modulo time 86400))))
@@ -39,50 +32,49 @@
(- today 86400))
(define %db
- ;; Global Slot for a database object.
- (make-parameter #t))
-
-(define database-name
- ;; Use an empty and temporary database for the tests.
- (string-append (getcwd) "/" (number->string (getpid)) "-tmp.db"))
+ (make-parameter #f))
(test-group-with-cleanup "database"
(test-assert "db-init"
(begin
- (%db (db-init database-name))
+ (%db (db-open))
(%db-channel (make-worker-thread-channel
(lambda ()
(list (%db)))))
- (%db-writer-channel (%db-channel))
#t))
- (test-assert "sqlite-exec"
+ (test-assert "exec-query"
(begin
- (sqlite-exec (%db) "\
+ (exec-query (%db) "\
+INSERT INTO Specifications (name, load_path_inputs, package_path_inputs,
+proc_input, proc_file, proc, proc_args, build_outputs, priority)
+VALUES ('guix', '()', '()', 'guix',' build-aux/cuirass/gnu-system.scm',
+'cuirass-jobs', '', '', 2);")
+ (exec-query (%db) "\
INSERT INTO Evaluations (specification, status,
timestamp, checkouttime, evaltime) VALUES ('guix', -1, 1600174547, 0, 0);")
- (sqlite-exec (%db) (format #f "\
+ (exec-query (%db) (format #f "\
INSERT INTO Evaluations (specification, status,
timestamp, checkouttime, evaltime) VALUES ('guix', 0, ~a, ~a, ~a);\
" yesterday (+ yesterday 100) (+ yesterday 600)))
- (sqlite-exec (%db) "\
+ (exec-query (%db) "\
INSERT INTO Evaluations (specification, status,
timestamp, checkouttime, evaltime) VALUES ('guix', 1, 1600174547,
1600174548, 0);")
- (sqlite-exec (%db) "\
+ (exec-query (%db) "\
INSERT INTO Evaluations (specification, status,
timestamp, checkouttime, evaltime) VALUES ('guix', 1, 1600174547,
1600174548, 1600174647);")
- (sqlite-exec (%db) (format #f "\
+ (exec-query (%db) (format #f "\
INSERT INTO Builds (id, derivation, evaluation, job_name, system,
nix_name, log, status, timestamp, starttime, stoptime) VALUES
(1, '/gnu/store/1.drv', 2, '', '', '', '', 0, ~a, ~a, ~a);\
" yesterday (+ yesterday 1600) (+ yesterday 2600)))
- (sqlite-exec (%db) (format #f "\
+ (exec-query (%db) (format #f "\
INSERT INTO Builds (id, derivation, evaluation, job_name, system,
nix_name, log, status, timestamp, starttime, stoptime) VALUES
(2, '/gnu/store/2.drv', 2, '', '', '', '', -2, 0, 0, 0);"))
- (sqlite-exec (%db) (format #f "\
+ (exec-query (%db) (format #f "\
INSERT INTO Builds (id, derivation, evaluation, job_name, system,
nix_name, log, status, timestamp, starttime, stoptime) VALUES
(3, '/gnu/store/3.drv', 4, '', '', '', '', 0, 1600174451, 1600174451,
@@ -94,65 +86,60 @@ nix_name, log, status, timestamp, starttime, stoptime)
VALUES
(db-update-metric 'average-eval-duration-per-spec "guix")
(db-get-metrics-with-id 'average-eval-duration-per-spec)))
- (test-equal "builds-per-day"
- 1.0
- (begin
- (db-update-metric 'builds-per-day)
- (db-get-metric 'builds-per-day yesterday)))
-
- (test-equal "pending-builds"
- `((,today . 1.0))
- (begin
- (db-update-metric 'pending-builds)
- (db-get-metrics-with-id 'pending-builds)))
-
- (test-equal "new-derivations-per-day"
- `((,yesterday . 1.0))
- (begin
- (db-update-metric 'new-derivations-per-day)
- (db-get-metrics-with-id 'new-derivations-per-day)))
-
- (test-equal "percentage-failed-eval-per-spec"
- `(("guix" . 50.0))
- (begin
- (db-update-metric 'percentage-failed-eval-per-spec "guix")
- (db-get-metrics-with-id 'percentage-failed-eval-per-spec)))
-
- (test-equal "db-update-metrics"
- `((,today . 2.0))
- (begin
- (sqlite-exec (%db) (format #f "\
+ (test-equal "builds-per-day"
+ 1.0
+ (begin
+ (db-update-metric 'builds-per-day)
+ (db-get-metric 'builds-per-day yesterday)))
+
+ (test-equal "pending-builds"
+ `((,today . 1.0))
+ (begin
+ (db-update-metric 'pending-builds)
+ (db-get-metrics-with-id 'pending-builds)))
+
+ (test-equal "new-derivations-per-day"
+ `((,yesterday . 1.0))
+ (begin
+ (db-update-metric 'new-derivations-per-day)
+ (db-get-metrics-with-id 'new-derivations-per-day)))
+
+ (test-equal "percentage-failed-eval-per-spec"
+ `(("guix" . 50.0))
+ (begin
+ (db-update-metric 'percentage-failed-eval-per-spec "guix")
+ (db-get-metrics-with-id 'percentage-failed-eval-per-spec)))
+
+ (test-equal "db-update-metrics"
+ `((,today . 2.0))
+ (begin
+ (exec-query (%db) (format #f "\
INSERT INTO Builds (id, derivation, evaluation, job_name, system,
nix_name, log, status, timestamp, starttime, stoptime) VALUES
(4, '/gnu/store/4.drv', 1, '', '', '', '', -2, 0, 0, 0);"))
- (db-update-metrics)
- (db-get-metrics-with-id 'pending-builds)))
-
- (test-equal "average-eval-build-start-time"
- `((2 . 1000.0))
- (begin
- (db-update-metric 'average-eval-build-start-time 2)
- (db-get-metrics-with-id 'average-eval-build-start-time)))
-
- (test-equal "average-eval-build-complete-time"
- `((2 . 2000.0))
- (begin
- (db-update-metric 'average-eval-build-complete-time 2)
- (db-get-metrics-with-id 'average-eval-build-complete-time)))
-
- (test-equal "evaluation-completion-speed"
- 900.0
- (begin
- (db-update-metric 'evaluation-completion-speed 4)
- (db-get-metric 'evaluation-completion-speed 4)))
+ (db-update-metrics)
+ (db-get-metrics-with-id 'pending-builds)))
+
+ (test-equal "average-eval-build-start-time"
+ `((2 . 1000.0))
+ (begin
+ (db-update-metric 'average-eval-build-start-time 2)
+ (db-get-metrics-with-id 'average-eval-build-start-time)))
+
+ (test-equal "average-eval-build-complete-time"
+ `((2 . 2000.0))
+ (begin
+ (db-update-metric 'average-eval-build-complete-time 2)
+ (db-get-metrics-with-id 'average-eval-build-complete-time)))
+
+ (test-equal "evaluation-completion-speed"
+ 900.0
+ (begin
+ (db-update-metric 'evaluation-completion-speed 4)
+ (db-get-metric 'evaluation-completion-speed 4)))
(test-assert "db-close"
- (db-close (%db)))
-
- (begin
- (%db-channel #f)
- (delete-file database-name)))
-
-;;; Local Variables:
-;;; eval: (put 'with-temporary-database 'scheme-indent-function 0)
-;;; End:
+ (begin
+ (exec-query (%db) (format #f "DROP OWNED BY CURRENT_USER;"))
+ (db-close (%db))
+ #t)))