guix
/
guix-cuirass
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git
2
0
Fork 0
Code Issues Releases Wiki Activity

Switch to PostegreSQL.

This commit is contained in:
Mathieu Othacehe 2021-01-05 10:20:34 +01:00
parent ca7a7ca989
commit cbc462679d
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
36 changed files with 1458 additions and 1729 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.dir-locals.el
View File

@ -13,9 +13,6 @@
(eval put 'test-error 'scheme-indent-function 1) (eval put 'test-error 'scheme-indent-function 1)
(eval put 'make-parameter 'scheme-indent-function 1) (eval put 'make-parameter 'scheme-indent-function 1)
(eval put 'with-database 'scheme-indent-function 0) (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 (texinfo-mode
(indent-tabs-mode) (indent-tabs-mode)
(fill-column . 72) (fill-column . 72)

26
Makefile.am
View File

@ -79,25 +79,7 @@ nodist_webobject_DATA = \
dist_pkgdata_DATA = src/schema.sql dist_pkgdata_DATA = src/schema.sql
dist_sql_DATA = \ dist_sql_DATA = \
src/sql/upgrade-1.sql \ 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
dist_css_DATA = \ dist_css_DATA = \
src/static/css/cuirass.css \ src/static/css/cuirass.css \
@ -163,12 +145,6 @@ CLEANFILES = \
$(nodist_guileobject_DATA) \ $(nodist_guileobject_DATA) \
src/cuirass/config.go src/cuirass/config.go
.PHONY: sql-check
sql-check: src/schema.sql
@echo "$<"
$(AM_V_at)sqlite3 tmp-$$$.db < $< ; \
rm tmp-$$$.db
## -------------- ## ## -------------- ##
## Distribution. ## ## Distribution. ##
## -------------- ## ## -------------- ##

78
README
View File

@ -1,8 +1,8 @@
Cuirass is a continuous integration tool using GNU Guix. It is intended as a -*- mode: org -*-
replacement for Hydra.
Requirements Cuirass is a continuous integration tool using GNU Guix.
============
* Requirements
Cuirass currently depends on the following packages: 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 Guix (and all its development dependencies)
- GNU Make - GNU Make
- Guile-JSON 3.x - Guile-JSON 3.x
- Guile-SQLite3 - Guile-Squee
- Guile-Git - Guile-Git
- Guile-zlib - Guile-zlib
- Fibers - 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 A convenient way to install those dependencies is to install Guix and execute
the following command: the following command:
#+BEGIN_EXAMPLE
$ guix environment -l build-aux/guix.scm $ guix environment -l build-aux/guix.scm
#+END_EXAMPLE
This will build and enter an environment which provides all the necessary This will build and enter an environment which provides all the necessary
dependencies. dependencies.
Build Instructions * Build Instructions
==================
When all the dependencies are available on you system, in order to build and When all the dependencies are available on you system, in order to build and
install Cuirass, you can proceed with the usual: install Cuirass, you can proceed with the usual:
#+BEGIN_EXAMPLE
$ ./configure && sudo make install $ ./configure && sudo make install
#+END_EXAMPLE
An alternative way is to directly install Cuirass in your Guix profile, using: An alternative way is to directly install Cuirass in your Guix profile, using:
#+BEGIN_EXAMPLE
$ guix package -f build-aux/guix.scm $ guix package -f build-aux/guix.scm
#+END_EXAMPLE
To build it, but not install it, run: To build it, but not install it, run:
#+BEGIN_EXAMPLE
$ guix build -f build-aux/guix.scm $ guix build -f build-aux/guix.scm
#+END_EXAMPLE
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
A quick way to manually test Cuirass is to execute: 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 This will read the file "examples/hello-singleton.scm" which contains a list
specifications and add them to the database "test.db" which is created if it of specifications and add them to the =cuirass= database.
doesn't already exist.
'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. of the specifications in order to allow users to accumulate specifications.
To resume the evaluation/build process you can execute the same command To resume the evaluation/build process you can execute the same command
without the '--specifications' option: 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: 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 See the manual for useful hacking informations, by running
#+BEGIN_EXAMPLE
info -f doc/cuirass.info "Contributing" info -f doc/cuirass.info "Contributing"
#+END_EXAMPLE

153
bin/cuirass.in
View File

@ -57,8 +57,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
-p --port=NUM Port of the HTTP server. -p --port=NUM Port of the HTTP server.
--listen=HOST Listen on the network interface for HOST --listen=HOST Listen on the network interface for HOST
-I, --interval=N Wait N seconds between each poll -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 --build-remote Use the remote build mechanism
--use-substitutes Allow usage of pre-built substitutes --use-substitutes Allow usage of pre-built substitutes
--record-events Record events for distribution --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)) (port (single-char #\p) (value #t))
(listen (value #t)) (listen (value #t))
(interval (single-char #\I) (value #t)) (interval (single-char #\I) (value #t))
(queue-size (single-char #\Q) (value #t))
(build-remote (value #f)) (build-remote (value #f))
(use-substitutes (value #f)) (use-substitutes (value #f))
(threads (value #t)) (threads (value #t))
(fallback (value #f)) (fallback (value #f))
(log-queries (value #t))
(record-events (value #f)) (record-events (value #f))
(ttl (value #t)) (ttl (value #t))
(version (single-char #\V) (value #f)) (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)) (%fallback? (option-ref opts 'fallback #f))
(%record-events? (option-ref opts 'record-events #f)) (%record-events? (option-ref opts 'record-events #f))
(%gc-root-ttl (%gc-root-ttl
(time-second (string->duration (option-ref opts 'ttl "30d")))) (time-second (string->duration (option-ref opts 'ttl "30d")))))
(%db-writer-queue-size
(string->number (option-ref opts 'queue-size "1"))))
(cond (cond
((option-ref opts 'help #f) ((option-ref opts 'help #f)
(show-help) (show-help)
@ -129,7 +123,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(host (option-ref opts 'listen "localhost")) (host (option-ref opts 'listen "localhost"))
(interval (string->number (option-ref opts 'interval "300"))) (interval (string->number (option-ref opts 'interval "300")))
(specfile (option-ref opts 'specifications #f)) (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 ;; Since our work is mostly I/O-bound, default to a maximum of 4
;; kernel threads. Going beyond that can increase overhead (GC ;; 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)))) (min (current-processor-count) 4))))
(prepare-git) (prepare-git)
(unless (option-ref opts 'web #f)
(log-message "performing database optimizations")
(db-optimize))
(log-message "running Fibers on ~a kernel threads" threads) (log-message "running Fibers on ~a kernel threads" threads)
(run-fibers (run-fibers
(lambda () (lambda ()
(with-database (with-database
(with-queue-writer-worker (and specfile
(and specfile (let ((new-specs (save-module-excursion
(let ((new-specs (save-module-excursion (lambda ()
(lambda () (set-current-module
(set-current-module (make-user-module '()))
(make-user-module '())) (primitive-load specfile)))))
(primitive-load specfile)))))
(for-each db-add-specification new-specs)))
(when queries-file (for-each db-add-specification new-specs)))
(log-message "Enable SQL query logging.")
(db-log-queries queries-file))
(if one-shot? (if one-shot?
(process-specs (db-get-specifications)) (process-specs (db-get-specifications))
(let ((exit-channel (make-channel))) (let ((exit-channel (make-channel)))
(start-watchdog) (start-watchdog)
(if (option-ref opts 'web #f) (if (option-ref opts 'web #f)
(begin (begin
(spawn-fiber (spawn-fiber
(essential-task (essential-task
'web exit-channel 'web exit-channel
(lambda () (lambda ()
(run-cuirass-server #:host host (run-cuirass-server #:host host
#:port port))) #:port port)))
#:parallel? #t) #:parallel? #t)
(spawn-fiber (spawn-fiber
(essential-task (essential-task
'monitor exit-channel 'monitor exit-channel
(lambda () (lambda ()
(while #t (while #t
(log-monitoring-stats) (log-monitoring-stats)
(sleep 600)))))) (sleep 600))))))
(begin (begin
(clear-build-queue) (clear-build-queue)
;; If Cuirass was stopped during an evaluation, ;; If Cuirass was stopped during an evaluation,
;; abort it. Builds that were not registered ;; abort it. Builds that were not registered
;; during this evaluation will be registered ;; during this evaluation will be registered
;; during the next evaluation. ;; during the next evaluation.
(db-abort-pending-evaluations) (db-abort-pending-evaluations)
;; First off, restart builds that had not ;; First off, restart builds that had not
;; completed or were not even started on a ;; completed or were not even started on a
;; previous run. ;; previous run.
(spawn-fiber (spawn-fiber
(essential-task (essential-task
'restart-builds exit-channel 'restart-builds exit-channel
(lambda () (lambda ()
(restart-builds)))) (restart-builds))))
(spawn-fiber (spawn-fiber
(essential-task (essential-task
'build exit-channel 'build exit-channel
(lambda () (lambda ()
(while #t (while #t
(process-specs (db-get-specifications)) (process-specs (db-get-specifications))
(log-message (log-message
"next evaluation in ~a seconds" interval) "next evaluation in ~a seconds" interval)
(sleep interval))))) (sleep interval)))))
(spawn-fiber (spawn-fiber
(essential-task (essential-task
'metrics exit-channel 'metrics exit-channel
(lambda () (lambda ()
(while #t (while #t
(with-time-logging (with-time-logging
"Metrics update" "Metrics update"
(db-update-metrics)) (db-update-metrics))
(sleep 3600))))) (sleep 3600)))))
(spawn-fiber (spawn-fiber
(essential-task (essential-task
'monitor exit-channel 'monitor exit-channel
(lambda () (lambda ()
(while #t (while #t
(log-monitoring-stats) (log-monitoring-stats)
(sleep 600))))))) (sleep 600)))))))
(primitive-exit (get-message exit-channel))))))) (primitive-exit (get-message exit-channel))))))
;; Most of our code is I/O so preemption doesn't matter much (it ;; 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 ;; could help while we're doing SQL requests, for instance, but it

6
build-aux/guix.scm
View File

@ -67,11 +67,11 @@
;; Wrap the 'cuirass' command to refer to the right modules. ;; Wrap the 'cuirass' command to refer to the right modules.
(let* ((out (assoc-ref outputs "out")) (let* ((out (assoc-ref outputs "out"))
(json (assoc-ref inputs "guile-json")) (json (assoc-ref inputs "guile-json"))
(sqlite (assoc-ref inputs "guile-sqlite3")) (squee (assoc-ref inputs "guile-squee"))
(zlib (assoc-ref inputs "guile-zlib")) (zlib (assoc-ref inputs "guile-zlib"))
(guix (assoc-ref inputs "guix")) (guix (assoc-ref inputs "guix"))
(mods (string-append json "/share/guile/site/3.0:" (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:" zlib "/share/guile/site/3.0:"
guix "/share/guile/site/3.0"))) guix "/share/guile/site/3.0")))
(wrap-program (string-append out "/bin/cuirass") (wrap-program (string-append out "/bin/cuirass")
@ -82,7 +82,7 @@
'("guile" '("guile"
"guile-fibers" "guile-fibers"
"guile-json" "guile-json"
"guile-sqlite3" "guile-squee"
"guile-git" "guile-git"
"guile-zlib" "guile-zlib"
"guix"))) "guix")))

2
configure.ac
View File

@ -47,7 +47,7 @@ GUILE_MODULE_REQUIRED([guix])
GUILE_MODULE_REQUIRED([guix git]) GUILE_MODULE_REQUIRED([guix git])
GUILE_MODULE_REQUIRED([git]) GUILE_MODULE_REQUIRED([git])
GUILE_MODULE_REQUIRED([json]) GUILE_MODULE_REQUIRED([json])
GUILE_MODULE_REQUIRED([sqlite3]) GUILE_MODULE_REQUIRED([squee])
GUILE_MODULE_REQUIRED([fibers]) GUILE_MODULE_REQUIRED([fibers])
GUILE_MODULE_REQUIRED([zlib]) GUILE_MODULE_REQUIRED([zlib])

14
doc/cuirass.texi
View File

@ -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 a list of them in a file and set the @code{--specifications} command
line option argument with the file name when launching the daemon line option argument with the file name when launching the daemon
(@pxref{Invocation}). The specifications are persistent (they are kept (@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 previously added specifications will remain active even if you don't
keep the @code{--specifications} option. keep the @code{--specifications} option.
@ -209,9 +209,9 @@ database before launching the evaluation and build processes.
@item --database=@var{database} @item --database=@var{database}
@itemx -D @var{database} @itemx -D @var{database}
Use @var{database} as the database containing the jobs and the past Use @var{database} as the database containing the jobs and the past
build results. Since @code{cuirass} uses SQLite as a database engine, build results. Since @code{cuirass} uses PostgreSQL as a database
@var{database} must be a file name. If the file doesn't exist, it will engine, @var{database} must be a file name. If the file doesn't exist,
be created. it will be created.
@item --ttl=@var{duration} @item --ttl=@var{duration}
Cuirass registers build results as garbage collector (GC) roots, thereby 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 @node Database
@chapter Database schema @chapter Database schema
@cindex cuirass database @cindex cuirass database
@cindex sqlite database @cindex postgresql database
@cindex persistent configuration @cindex persistent configuration
Cuirass uses a SQLite database to store information about jobs and past Cuirass uses a PostgreSQL database to store information about jobs and
build results, but also to coordinate the execution of jobs. past build results, but also to coordinate the execution of jobs.
The database contains the following tables: @code{Specifications}, The database contains the following tables: @code{Specifications},
@code{Inputs}, @code{Checkouts}, @code{Evaluations}, @code{Builds} and @code{Inputs}, @code{Checkouts}, @code{Evaluations}, @code{Builds} and

3
src/cuirass/base.scm
View File

@ -636,8 +636,7 @@ updating the database accordingly."
"Reset the status of builds in the database that are marked as \"started\". "Reset the status of builds in the database that are marked as \"started\".
This procedure is meant to be called at startup." This procedure is meant to be called at startup."
(log-message "marking stale builds as \"scheduled\"...") (log-message "marking stale builds as \"scheduled\"...")
(with-db-worker-thread db (db-clear-build-queue))
(sqlite-exec db "UPDATE Builds SET status = -2 WHERE status = -1;")))
(define (restart-builds) (define (restart-builds)
"Restart builds whose status in the database is \"pending\" (scheduled or "Restart builds whose status in the database is \"pending\" (scheduled or

1555
src/cuirass/database.scm
View File

File diff suppressed because it is too large Load Diff

4
src/cuirass/http.scm
View File

@ -250,14 +250,14 @@ Hydra format."
#:avg-eval-build-start-time #:avg-eval-build-start-time
(db-get-metrics-with-id 'average-eval-build-start-time (db-get-metrics-with-id 'average-eval-build-start-time
#:limit 100 #:limit 100
#:order "field ASC") #:order "cast(field as int) ASC")
#:builds-per-day #:builds-per-day
(db-get-metrics-with-id 'builds-per-day (db-get-metrics-with-id 'builds-per-day
#:limit 100) #:limit 100)
#:eval-completion-speed #:eval-completion-speed
(db-get-metrics-with-id 'evaluation-completion-speed (db-get-metrics-with-id 'evaluation-completion-speed
#:limit 100 #:limit 100
#:order "field ASC") #:order "cast(field as int) ASC")
#:new-derivations-per-day #:new-derivations-per-day
(db-get-metrics-with-id 'new-derivations-per-day (db-get-metrics-with-id 'new-derivations-per-day
#:limit 100) #:limit 100)

269
src/cuirass/metrics.scm
View File

@ -20,13 +20,16 @@
#:use-module (cuirass database) #:use-module (cuirass database)
#:use-module (cuirass logging) #:use-module (cuirass logging)
#:use-module (guix records) #:use-module (guix records)
#:use-module (squee)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 i18n)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (metric #:export (metric
metric? metric?
metric-id metric-id
metric-field-type
metric-proc metric-proc
%metrics %metrics
@ -47,6 +50,8 @@
metric? metric?
(id metric-id) (id metric-id)
(compute-proc metric-compute-proc) (compute-proc metric-compute-proc)
(field-type metric-field-type
(default 'int))
(field-proc metric-field-proc (field-proc metric-field-proc
(default #f))) (default #f)))
@ -55,72 +60,98 @@
;;; Database procedures. ;;; 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) (define* (db-average-eval-duration-per-spec spec #:key limit)
"Return the average evaluation duration for SPEC. Limit the average "Return the average evaluation duration for SPEC. Limit the average
computation to the most recent LIMIT records if this argument is set." computation to the most recent LIMIT records if this argument is set."
(with-db-worker-thread db (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 (SELECT (evaltime - timestamp) as duration
FROM Evaluations WHERE specification = " spec FROM Evaluations WHERE specification = :spec
" AND evaltime != 0 ORDER BY rowid DESC AND evaltime != 0 ORDER BY id DESC LIMIT ~a) m;")
LIMIT " (or limit -1) ");"))) (params `((#:spec . ,spec))))
(and=> (expect-one-row rows) (cut vector-ref <> 0))))) (return-inexact
(exec-query/bind-params db
(format #f query
(if limit
(number->string limit)
"ALL"))
params)))))
(define (db-builds-previous-day _) (define (db-builds-previous-day _)
"Return the builds count of the previous day." "Return the builds count of the previous day."
(with-db-worker-thread db (with-db-worker-thread db
(let ((rows (sqlite-exec db "SELECT COUNT(*) from Builds (return-exact
WHERE date(timestamp, 'unixepoch') = date('now', '-1 day') AND (exec-query/bind db "SELECT COUNT(*) from Builds
date(stoptime, 'unixepoch') = date('now', '-1 day');"))) WHERE to_timestamp(timestamp)::date = 'yesterday'::date AND
(and=> (expect-one-row rows) (cut vector-ref <> 0))))) to_timestamp(stoptime)::date = 'yesterday'::date;"))))
(define (db-new-derivations-previous-day _) (define (db-new-derivations-previous-day _)
"Return the new derivations count of the previous day." "Return the new derivations count of the previous day."
(with-db-worker-thread db (with-db-worker-thread db
(let ((rows (sqlite-exec db "SELECT COUNT(*) from Builds (return-exact
WHERE date(timestamp, 'unixepoch') = date('now', '-1 day');"))) (exec-query/bind db "SELECT COUNT(*) from Builds
(and=> (expect-one-row rows) (cut vector-ref <> 0))))) WHERE to_timestamp(timestamp)::date = 'yesterday'::date;"))))
(define (db-pending-builds _) (define (db-pending-builds _)
"Return the current pending builds count." "Return the current pending builds count."
(with-db-worker-thread db (with-db-worker-thread db
(let ((rows (sqlite-exec db "SELECT COUNT(*) from Builds (return-exact
WHERE status < 0;"))) (exec-query/bind db "SELECT COUNT(*) from Builds
(and=> (expect-one-row rows) (cut vector-ref <> 0))))) WHERE status < 0;"))))
(define* (db-percentage-failed-eval-per-spec spec #:key limit) (define* (db-percentage-failed-eval-per-spec spec #:key limit)
"Return the failed evaluation percentage for SPEC. If LIMIT is set, limit "Return the failed evaluation percentage for SPEC. If LIMIT is set, limit
the percentage computation to the most recent LIMIT records." the percentage computation to the most recent LIMIT records."
(with-db-worker-thread db (with-db-worker-thread db
(let ((rows (sqlite-exec db "\ (let ((query "\
SELECT 100 * CAST(SUM(status > 0) as float) / COUNT(*) FROM SELECT 100 *
(SELECT status from Evaluations WHERE specification = " spec CAST(SUM(CASE WHEN m.status > 0 THEN 1 ELSE 0 END) as float) /
" ORDER BY rowid DESC LIMIT " (or limit -1) ");"))) COUNT(*) FROM
(and=> (expect-one-row rows) (cut vector-ref <> 0))))) (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) (define* (db-average-build-start-time-per-eval eval)
"Return the average build start time for the given EVAL." "Return the average build start time for the given EVAL."
(with-db-worker-thread db (with-db-worker-thread db
(let ((rows (sqlite-exec db "\ (return-inexact
(exec-query/bind db "\
SELECT AVG(B.starttime - E.evaltime) FROM SELECT AVG(B.starttime - E.evaltime) FROM
(SELECT id, evaltime (SELECT id, evaltime
FROM Evaluations WHERE id = " eval ") E FROM Evaluations WHERE id = " eval ") E
LEFT JOIN Builds as B LEFT JOIN Builds as B
ON E.id = B.evaluation and B.starttime > 0 ON E.id = B.evaluation and B.starttime > 0
GROUP BY E.id;"))) GROUP BY E.id;"))))
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
(define* (db-average-build-complete-time-per-eval eval) (define* (db-average-build-complete-time-per-eval eval)
"Return the average build complete time for the given EVAL." "Return the average build complete time for the given EVAL."
(with-db-worker-thread db (with-db-worker-thread db
(let ((rows (sqlite-exec db "\ (return-inexact
(exec-query/bind db "\
SELECT AVG(B.stoptime - E.evaltime) FROM SELECT AVG(B.stoptime - E.evaltime) FROM
(SELECT id, evaltime (SELECT id, evaltime
FROM Evaluations WHERE id = " eval ") E FROM Evaluations WHERE id = " eval ") E
LEFT JOIN Builds as B LEFT JOIN Builds as B
ON E.id = B.evaluation and B.stoptime > 0 ON E.id = B.evaluation and B.stoptime > 0
GROUP BY E.id;"))) GROUP BY E.id;"))))
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
(define* (db-evaluation-completion-speed eval) (define* (db-evaluation-completion-speed eval)
"Return the evaluation completion speed of the given EVAL. The speed is "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 ;; evaluation_duration (seconds) = max(build_stop_time) - eval_start_time
;; If the evaluation builds are all completed. ;; If the evaluation builds are all completed.
(with-db-worker-thread db (with-db-worker-thread db
(let ((rows (sqlite-exec db "\ (return-inexact
(exec-query/bind db "\
SELECT SELECT
3600.0 * SUM(B.status = 0) / 3600.0 * SUM(CASE WHEN B.status = 0 THEN 1 ELSE 0 END) /
(CASE SUM(status < 0) (CASE SUM(CASE WHEN status < 0 THEN 1 ELSE 0 END)
WHEN 0 THEN MAX(stoptime) WHEN 0 THEN MAX(stoptime)
ELSE strftime('%s', 'now') ELSE extract(epoch from 'today'::date)
END - E.evaltime) FROM END - E.evaltime) FROM
(SELECT id, evaltime (SELECT id, evaltime
FROM Evaluations WHERE id = " eval ") E FROM Evaluations WHERE id = " eval ") E
LEFT JOIN Builds as B LEFT JOIN Builds as B
ON E.id = B.evaluation and B.stoptime > 0 ON E.id = B.evaluation and B.stoptime > 0
GROUP BY E.id;"))) GROUP BY E.id, E.evaltime;"))))
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
(define (db-previous-day-timestamp) (define (db-previous-day-timestamp)
"Return the timestamp of the previous day." "Return the timestamp of the previous day."
(with-db-worker-thread db (with-db-worker-thread db
(let ((rows (sqlite-exec db "SELECT strftime('%s', (return-exact
date('now', '-1 day'));"))) (exec-query
(and=> (expect-one-row rows) (cut vector-ref <> 0))))) db "SELECT extract(epoch from 'yesterday'::date);"))))
(define (db-current-day-timestamp) (define (db-current-day-timestamp)
"Return the timestamp of the current day." "Return the timestamp of the current day."
(with-db-worker-thread db (with-db-worker-thread db
(let ((rows (sqlite-exec db "SELECT strftime('%s', (return-exact
date('now'));"))) (exec-query
(and=> (expect-one-row rows) (cut vector-ref <> 0))))) db "SELECT extract(epoch from 'today'::date);"))))
(define* (db-latest-evaluations #:key (days 3)) (define* (db-latest-evaluations #:key (days 3))
"Return the successful evaluations added during the previous DAYS." "Return the successful evaluations added during the previous DAYS."
(with-db-worker-thread db (with-db-worker-thread db
(let ((query (format #f "SELECT id from Evaluations (let ((query (format #f "SELECT id from Evaluations
WHERE date(timestamp, 'unixepoch') > date('now', '-~a day') AND WHERE to_timestamp(timestamp)::date > 'today'::date - interval '~a day' AND
status = 0 ORDER BY rowid DESC" days))) status = 0 ORDER BY id DESC" days)))
(let loop ((rows (sqlite-exec db query)) (let loop ((rows (exec-query db query))
(evaluations '())) (evaluations '()))
(match rows (match rows
(() (reverse evaluations)) (() (reverse evaluations))
((#(id) . rest) (((id) . rest)
(loop rest (loop rest
(cons id evaluations)))))))) (cons id evaluations))))))))
@ -187,16 +218,19 @@ status = 0 ORDER BY rowid DESC" days)))
;; Average evaluation duration per specification. ;; Average evaluation duration per specification.
(metric (metric
(id 'average-10-last-eval-duration-per-spec) (id 'average-10-last-eval-duration-per-spec)
(field-type 'string)
(compute-proc (compute-proc
(cut db-average-eval-duration-per-spec <> #:limit 10))) (cut db-average-eval-duration-per-spec <> #:limit 10)))
(metric (metric
(id 'average-100-last-eval-duration-per-spec) (id 'average-100-last-eval-duration-per-spec)
(field-type 'string)
(compute-proc (compute-proc
(cut db-average-eval-duration-per-spec <> #:limit 100))) (cut db-average-eval-duration-per-spec <> #:limit 100)))
(metric (metric
(id 'average-eval-duration-per-spec) (id 'average-eval-duration-per-spec)
(field-type 'string)
(compute-proc db-average-eval-duration-per-spec)) (compute-proc db-average-eval-duration-per-spec))
;; Builds count per day. ;; Builds count per day.
@ -220,16 +254,19 @@ status = 0 ORDER BY rowid DESC" days)))
;; Percentage of failed evaluations per specification. ;; Percentage of failed evaluations per specification.
(metric (metric
(id 'percentage-failure-10-last-eval-per-spec) (id 'percentage-failure-10-last-eval-per-spec)
(field-type 'string)
(compute-proc (compute-proc
(cut db-percentage-failed-eval-per-spec <> #:limit 10))) (cut db-percentage-failed-eval-per-spec <> #:limit 10)))
(metric (metric
(id 'percentage-failure-100-last-eval-per-spec) (id 'percentage-failure-100-last-eval-per-spec)
(field-type 'string)
(compute-proc (compute-proc
(cut db-percentage-failed-eval-per-spec <> #:limit 100))) (cut db-percentage-failed-eval-per-spec <> #:limit 100)))
(metric (metric
(id 'percentage-failed-eval-per-spec) (id 'percentage-failed-eval-per-spec)
(field-type 'string)
(compute-proc db-percentage-failed-eval-per-spec)) (compute-proc db-percentage-failed-eval-per-spec))
;; Average time to start a build for an evaluation. ;; 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) (define* (db-get-metric id field)
"Return the metric with the given ID and FIELD." "Return the metric with the given ID and FIELD."
(let* ((metric (find-metric id)) (with-db-worker-thread db
(type (metric->type metric))) (let* ((metric (find-metric id))
(with-db-worker-thread db (type (metric->type metric)))
(let ((rows (sqlite-exec db "SELECT value from Metrics (return-inexact
WHERE type = " type " AND field = " field ";"))) (exec-query/bind db "SELECT value from Metrics
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))) WHERE type = " type " AND field = " field ";")))))
(define* (db-get-metrics-with-id id (define* (db-get-metrics-with-id id
#:key #:key
limit limit
(order "rowid DESC")) (order "id DESC"))
"Return the metrics with the given ID. If LIMIT is set, the resulting list "Return the metrics with the given ID. If LIMIT is set, the resulting list
if restricted to LIMIT records." if restricted to LIMIT records."
(let* ((metric (find-metric id)) (with-db-worker-thread db
(type (metric->type metric)) (let* ((metric (find-metric id))
(limit (or limit -1))) (type (metric->type metric))
(with-db-worker-thread db (field-type (metric-field-type metric))
(limit (or limit "ALL")))
(let ((query (format #f "SELECT field, value from Metrics (let ((query (format #f "SELECT field, value from Metrics
WHERE type = ? ORDER BY ~a LIMIT ~a" order limit))) WHERE type = :type ORDER BY ~a LIMIT ~a" order limit))
(let loop ((rows (%sqlite-exec db query type)) (params `((#:type . ,type))))
(let loop ((rows (exec-query/bind-params db query params))
(metrics '())) (metrics '()))
(match rows (match rows
(() (reverse metrics)) (() (reverse metrics))
((#(field value) . rest) (((field value) . rest)
(loop rest (let ((field (match field-type
`((,field . ,value) ('int (string->number field))
,@metrics))))))))) (else field))))
(loop rest
`((,field . ,(locale-string->inexact value))
,@metrics))))))))))
(define* (db-update-metric id #:optional field) (define* (db-update-metric id #:optional field)
"Compute and update the value of the metric ID in database. "Compute and update the value of the metric ID in database.
@ -306,67 +348,66 @@ for periodical metrics for instance."
(define now (define now
(time-second (current-time time-utc))) (time-second (current-time time-utc)))
(let* ((metric (find-metric id)) (with-db-worker-thread db
(field-proc (metric-field-proc metric)) (let* ((metric (find-metric id))
(field (or field (field-proc))) (field-proc (metric-field-proc metric))
(value (compute-metric metric field))) (field (or field (field-proc)))
(if value (value (compute-metric metric field)))
(begin (if value
(log-message "Updating metric ~a (~a) to ~a." (begin
(symbol->string id) field value) (log-message "Updating metric ~a (~a) to ~a."
(with-db-worker-thread db (symbol->string id) field value)
(sqlite-exec db "\ (exec-query/bind db "\
INSERT OR REPLACE INTO Metrics (field, type, value, INSERT INTO Metrics (field, type, value,
timestamp) VALUES (" timestamp) VALUES ("
field ", " field ", "
(metric->type metric) ", " (metric->type metric) ", "
value ", " value ", "
now ");") now ")
(last-insert-rowid db))) ON CONFLICT ON CONSTRAINT metrics_pkey DO
(log-message "Failed to compute metric ~a (~a)." UPDATE SET value = " value ", timestamp = " now ";"))
(symbol->string id) field)))) (log-message "Failed to compute metric ~a (~a)."
(symbol->string id) field)))))
(define (db-update-metrics) (define (db-update-metrics)
"Compute and update all available metrics in database." "Compute and update all available metrics in database."
(with-db-writer-worker-thread/force db ;; We can not update all evaluations metrics for performance reasons.
(catch-sqlite-error ;; Limit to the evaluations that were added during the past three days.
;; We can not update all evaluations metrics for performance reasons. (with-db-worker-thread db
;; Limit to the evaluations that were added during the past three days. (let ((specifications
(let ((specifications (map (cut assq-ref <> #:name) (db-get-specifications)))
(map (cut assq-ref <> #:name) (db-get-specifications))) (evaluations (db-latest-evaluations)))
(evaluations (db-latest-evaluations))) (exec-query db "BEGIN TRANSACTION;")
(sqlite-exec db "BEGIN TRANSACTION;")
(db-update-metric 'builds-per-day) (db-update-metric 'builds-per-day)
(db-update-metric 'new-derivations-per-day) (db-update-metric 'new-derivations-per-day)
(db-update-metric 'pending-builds) (db-update-metric 'pending-builds)
;; Update specification related metrics. ;; Update specification related metrics.
(for-each (lambda (spec) (for-each (lambda (spec)
(db-update-metric (db-update-metric
'average-10-last-eval-duration-per-spec spec) 'average-10-last-eval-duration-per-spec spec)
(db-update-metric (db-update-metric
'average-100-last-eval-duration-per-spec spec) 'average-100-last-eval-duration-per-spec spec)
(db-update-metric (db-update-metric
'average-eval-duration-per-spec spec) 'average-eval-duration-per-spec spec)
(db-update-metric (db-update-metric
'percentage-failure-10-last-eval-per-spec spec) 'percentage-failure-10-last-eval-per-spec spec)
(db-update-metric (db-update-metric
'percentage-failure-100-last-eval-per-spec spec) 'percentage-failure-100-last-eval-per-spec spec)
(db-update-metric (db-update-metric
'percentage-failed-eval-per-spec spec)) 'percentage-failed-eval-per-spec spec))
specifications) specifications)
;; Update evaluation related metrics. ;; Update evaluation related metrics.
(for-each (lambda (evaluation) (for-each (lambda (evaluation)
(db-update-metric (db-update-metric
'average-eval-build-start-time evaluation) 'average-eval-build-start-time evaluation)
(db-update-metric (db-update-metric
'average-eval-build-complete-time evaluation) 'average-eval-build-complete-time evaluation)
(db-update-metric (db-update-metric
'evaluation-completion-speed evaluation)) 'evaluation-completion-speed evaluation))
evaluations) evaluations)
(sqlite-exec db "COMMIT;")) (exec-query db "COMMIT;"))))
(on SQLITE_BUSY_SNAPSHOT => #f))))

2
src/cuirass/templates.scm
View File

@ -157,6 +157,7 @@ system whose names start with " (code "guile-") ":" (br)
(define (status-class status) (define (status-class status)
(cond (cond
((= (build-status submitted) status) "oi oi-clock text-warning")
((= (build-status scheduled) 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 started) status) "oi oi-reload text-warning")
((= (build-status succeeded) status) "oi oi-check text-success") ((= (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) (define (status-title status)
(cond (cond
((= (build-status submitted) status) "Submitted")
((= (build-status scheduled) status) "Scheduled") ((= (build-status scheduled) status) "Scheduled")
((= (build-status started) status) "Started") ((= (build-status started) status) "Started")
((= (build-status succeeded) status) "Succeeded") ((= (build-status succeeded) status) "Succeeded")

74
src/cuirass/utils.scm
View File

@ -23,6 +23,10 @@
#:use-module (cuirass logging) #:use-module (cuirass logging)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 threads) #: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 (rnrs bytevectors)
#:use-module (system foreign) #:use-module (system foreign)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -106,58 +110,32 @@ delimited continuations and fibers."
(make-parameter #f)) (make-parameter #f))
(define* (make-worker-thread-channel initializer (define* (make-worker-thread-channel initializer
#:key #:key (parallelism 1))
(parallelism 1)
queue-size
(queue-proc (const #t)))
"Return a channel used to offload work to a dedicated thread. ARGS are the "Return a channel used to offload work to a dedicated thread. ARGS are the
arguments of the worker thread procedure. This procedure supports deferring arguments of the worker thread procedure."
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."
(parameterize (((@@ (fibers internal) current-fiber) #f)) (parameterize (((@@ (fibers internal) current-fiber) #f))
(let ((channel (make-channel))) (let ((channel (make-channel)))
(for-each (for-each
(lambda _ (lambda _
(let ((args (initializer))) (let ((args (initializer)))
(call-with-new-thread (call-with-new-thread
(lambda () (parameterize ((current-read-waiter (lambda (port)
(parameterize ((%worker-thread-args args)) (port-poll port "r")))
(let loop ((queue '())) (current-write-waiter (lambda (port)
(match (get-message channel) (port-poll port "w"))))
(((? channel? reply) options (? procedure? proc)) (lambda ()
(put-message (parameterize ((%worker-thread-args args))
reply (let loop ()
(catch #t (match (get-message channel)
(lambda () (((? channel? reply) . (? procedure? proc))
(cond (put-message
((or (not queue-size) reply
(assq-ref options #:force?)) (catch #t
(lambda ()
(apply proc args)) (apply proc args))
(else (lambda (key . args)
(length queue)))) (cons* 'worker-thread-error key args))))))
(lambda (key . args) (loop))))))))
(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))))))))))
(iota parallelism)) (iota parallelism))
channel))) channel)))
@ -225,7 +203,6 @@ put-operation until it succeeds."
(define* (call-with-worker-thread channel proc (define* (call-with-worker-thread channel proc
#:key #:key
options
send-timeout send-timeout
send-timeout-proc send-timeout-proc
receive-timeout receive-timeout
@ -239,15 +216,12 @@ to a worker thread.
The same goes for RECEIVE-TIMEOUT and RECEIVE-TIMEOUT-PROC, except that the 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 timer expires if there is no response from the database worker PROC was sent
to. to."
OPTIONS are forwarded to the worker thread. See MAKE-WORKER-THREAD-CHANNEL
for a description of the supported options."
(let ((args (%worker-thread-args))) (let ((args (%worker-thread-args)))
(if args (if args
(apply proc args) (apply proc args)
(let* ((reply (make-channel)) (let* ((reply (make-channel))
(message (list reply options proc))) (message (cons reply proc)))
(if (and send-timeout (current-fiber)) (if (and send-timeout (current-fiber))
(put-message-with-timeout channel message (put-message-with-timeout channel message
#:seconds send-timeout #:seconds send-timeout

64
src/schema.sql
View File

@ -1,5 +1,9 @@
BEGIN TRANSACTION; BEGIN TRANSACTION;
CREATE TABLE SchemaVersion (
version INTEGER NOT NULL
);
CREATE TABLE Specifications ( CREATE TABLE Specifications (
name TEXT NOT NULL PRIMARY KEY, 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 load_path_inputs TEXT NOT NULL, -- list of input names whose load path will be in Guile's %load-path
@ -23,7 +27,17 @@ CREATE TABLE Inputs (
revision TEXT, revision TEXT,
no_compile_p INTEGER, no_compile_p INTEGER,
PRIMARY KEY (specification, name), PRIMARY KEY (specification, name),
FOREIGN KEY (specification) REFERENCES Specifications (name) FOREIGN KEY (specification) REFERENCES Specifications(name)
);
CREATE TABLE Evaluations (
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)
); );
CREATE TABLE Checkouts ( CREATE TABLE Checkouts (
@ -34,30 +48,13 @@ CREATE TABLE Checkouts (
directory TEXT NOT NULL, directory TEXT NOT NULL,
timestamp INTEGER NOT NULL, timestamp INTEGER NOT NULL,
PRIMARY KEY (specification, revision), PRIMARY KEY (specification, revision),
FOREIGN KEY (evaluation) REFERENCES Evaluations (id), FOREIGN KEY (evaluation) REFERENCES Evaluations(id),
FOREIGN KEY (specification) REFERENCES Specifications (name), FOREIGN KEY (specification) REFERENCES Specifications(name),
FOREIGN KEY (input) REFERENCES Inputs (name) FOREIGN KEY (specification, input) REFERENCES Inputs(specification, name)
);
CREATE TABLE Evaluations (
id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
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)
);
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 Builds ( CREATE TABLE Builds (
id INTEGER NOT NULL PRIMARY KEY, id SERIAL PRIMARY KEY,
derivation TEXT NOT NULL UNIQUE, derivation TEXT NOT NULL UNIQUE,
evaluation INTEGER NOT NULL, evaluation INTEGER NOT NULL,
job_name TEXT NOT NULL, job_name TEXT NOT NULL,
@ -72,11 +69,19 @@ CREATE TABLE Builds (
timestamp INTEGER NOT NULL, timestamp INTEGER NOT NULL,
starttime INTEGER NOT NULL, starttime INTEGER NOT NULL,
stoptime 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 ( CREATE TABLE Metrics (
field INTEGER NOT NULL, id SERIAL,
field TEXT NOT NULL,
type INTEGER NOT NULL, type INTEGER NOT NULL,
value DOUBLE PRECISION NOT NULL, value DOUBLE PRECISION NOT NULL,
timestamp INTEGER NOT NULL, timestamp INTEGER NOT NULL,
@ -84,17 +89,18 @@ CREATE TABLE Metrics (
); );
CREATE TABLE BuildProducts ( CREATE TABLE BuildProducts (
id SERIAL,
build INTEGER NOT NULL, build INTEGER NOT NULL,
type TEXT NOT NULL, type TEXT NOT NULL,
file_size BIGINT NOT NULL, file_size BIGINT NOT NULL,
checksum TEXT NOT NULL, checksum TEXT NOT NULL,
path TEXT NOT NULL, path TEXT NOT NULL,
PRIMARY KEY (build, path) PRIMARY KEY (build, path),
FOREIGN KEY (build) REFERENCES Builds (id) ON DELETE CASCADE FOREIGN KEY (build) REFERENCES Builds(id) ON DELETE CASCADE
); );
CREATE TABLE Events ( CREATE TABLE Events (
id INTEGER PRIMARY KEY, id SERIAL PRIMARY KEY,
type TEXT NOT NULL, type TEXT NOT NULL,
timestamp INTEGER NOT NULL, timestamp INTEGER NOT NULL,
event_json TEXT 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_status_index ON Builds (status);
CREATE INDEX Builds_evaluation_index ON Builds (evaluation, status); CREATE INDEX Builds_evaluation_index ON Builds (evaluation, status);
CREATE INDEX Builds_job_name_timestamp on Builds(job_name, timestamp); 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_timestamp_stoptime on Builds(timestamp, stoptime);
CREATE INDEX Builds_stoptime on Builds(stoptime DESC); CREATE INDEX Builds_stoptime on Builds(stoptime DESC);
CREATE INDEX Builds_stoptime_id on Builds(stoptime DESC, id 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_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_status_index ON Evaluations (id, status);
CREATE INDEX Evaluations_specification_index ON Evaluations (specification, id DESC); CREATE INDEX Evaluations_specification_index ON Evaluations (specification, id DESC);

75
src/sql/upgrade-1.sql
View File

@ -1,78 +1,3 @@
BEGIN TRANSACTION; 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; COMMIT;

12
src/sql/upgrade-10.sql
View File

@ -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;

11
src/sql/upgrade-11.sql
View File

@ -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;

7
src/sql/upgrade-12.sql
View File

@ -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;

5
src/sql/upgrade-13.sql
View File

@ -1,5 +0,0 @@
BEGIN TRANSACTION;
CREATE INDEX Builds_nix_name ON Builds (nix_name COLLATE NOCASE);
COMMIT;

5
src/sql/upgrade-14.sql
View File

@ -1,5 +0,0 @@
BEGIN TRANSACTION;
CREATE INDEX Builds_timestamp_stoptime on Builds(timestamp, stoptime);
COMMIT;

7
src/sql/upgrade-15.sql
View File

@ -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;

5
src/sql/upgrade-16.sql
View File

@ -1,5 +0,0 @@
BEGIN TRANSACTION;
CREATE INDEX Builds_job_name_timestamp on Builds(job_name, timestamp);
COMMIT;

5
src/sql/upgrade-17.sql
View File

@ -1,5 +0,0 @@
BEGIN TRANSACTION;
ALTER TABLE Builds ADD worker TEXT DEFAULT NULL;
COMMIT;

10
src/sql/upgrade-18.sql
View File

@ -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;

11
src/sql/upgrade-19.sql
View File

@ -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;

49
src/sql/upgrade-2.sql
View File

@ -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;

46
src/sql/upgrade-3.sql
View File

@ -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;

18
src/sql/upgrade-4.sql
View File

@ -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;

15
src/sql/upgrade-5.sql
View File

@ -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;

47
src/sql/upgrade-6.sql
View File

@ -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;

15
src/sql/upgrade-7.sql
View File

@ -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;

7
src/sql/upgrade-8.sql
View File

@ -1,7 +0,0 @@
BEGIN TRANSACTION;
CREATE INDEX Builds_status_index ON Builds (status);
CREATE INDEX Outputs_derivation_index ON Outputs (derivation);
COMMIT;

9
src/sql/upgrade-9.sql
View File

@ -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;

414
tests/database.scm
View File

@ -21,8 +21,12 @@
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>. ;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(use-modules (cuirass database) (use-modules (cuirass database)
((guix utils) #:select (call-with-temporary-output-file)) (cuirass remote)
(cuirass utils) (cuirass utils)
((guix utils) #:select (call-with-temporary-output-file))
(squee)
(ice-9 match)
(srfi srfi-19)
(srfi srfi-64)) (srfi srfi-64))
(define example-spec (define example-spec
@ -33,15 +37,15 @@
(#:proc-file . "/tmp/gnu-system.scm") (#:proc-file . "/tmp/gnu-system.scm")
(#:proc . hydra-jobs) (#:proc . hydra-jobs)
(#:proc-args (subset . "hello")) (#:proc-args (subset . "hello"))
(#:inputs . (((#:name . "savannah") (#:inputs . (((#:name . "maintenance")
(#:url . "git://git.savannah.gnu.org/guix.git") (#:url . "git://git.savannah.gnu.org/guix/maintenance.git")
(#:load-path . ".") (#:load-path . ".")
(#:branch . "master") (#:branch . "master")
(#:tag . #f) (#:tag . #f)
(#:commit . #f) (#:commit . #f)
(#:no-compile? . #f)) (#:no-compile? . #f))
((#:name . "maintenance") ((#:name . "savannah")
(#:url . "git://git.savannah.gnu.org/guix/maintenance.git") (#:url . "git://git.savannah.gnu.org/guix.git")
(#:load-path . ".") (#:load-path . ".")
(#:branch . "master") (#:branch . "master")
(#:tag . #f) (#:tag . #f)
@ -52,173 +56,353 @@
(define (make-dummy-checkouts fakesha1 fakesha2) (define (make-dummy-checkouts fakesha1 fakesha2)
`(((#:commit . ,fakesha1) `(((#:commit . ,fakesha1)
(#:input . "guix") (#:input . "savannah")
(#:directory . "foo")) (#:directory . "foo"))
((#:commit . ,fakesha2) ((#:commit . ,fakesha2)
(#:input . "packages") (#:input . "maintenance")
(#:directory . "bar")))) (#:directory . "bar"))))
(define* (make-dummy-build drv (define* (make-dummy-build drv
#:optional (eval-id 42) #:optional (eval-id 2)
#:key (outputs #:key (outputs
`(("foo" . ,(format #f "~a.output" drv))))) `(("foo" . ,(format #f "~a.output" drv)))))
`((#:derivation . ,drv) `((#:derivation . ,drv)
(#:eval-id . ,eval-id) (#:eval-id . ,eval-id)
(#:job-name . "job") (#:job-name . "job")
(#:timestamp . ,(time-second (current-time time-utc)))
(#:system . "x86_64-linux") (#:system . "x86_64-linux")
(#:nix-name . "foo") (#:nix-name . "foo")
(#:log . "log") (#:log . "log")
(#:outputs . ,outputs))) (#:outputs . ,outputs)))
(define-syntax-rule (with-temporary-database body ...) (define %dummy-worker
(call-with-temporary-output-file (worker
(lambda (file port) (name "worker")
(parameterize ((%package-database file)) (address "address")
(db-init file) (systems '("a" "b"))
(with-database (last-seen "1")))
(parameterize ((%db-writer-channel (%db-channel)))
body ...))))))
(define %db (define %db
;; Global Slot for a database object. (make-parameter #f))
(make-parameter #t))
(define database-name (define db-name "test_database")
;; Use an empty and temporary database for the tests. (%record-events? #t)
(string-append (getcwd) "/" (number->string (getpid)) "-tmp.db"))
(test-group-with-cleanup "database" (test-group-with-cleanup "database"
(test-assert "db-init" (test-assert "db-init"
(begin (begin
(%db (db-init database-name)) (%db (db-open))
(%db-channel (make-worker-thread-channel (%db-channel (make-worker-thread-channel
(lambda () (lambda ()
(list (%db))))) (list (%db)))))
(%db-writer-channel (%db-channel))
#t)) #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" (test-equal "db-add-specification"
example-spec "guix"
(db-add-specification example-spec))
(test-assert "exec-query"
(begin (begin
(db-add-specification example-spec) (exec-query (%db) "\
(car (db-get-specifications)))) 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" (test-equal "db-get-specification"
example-spec example-spec
(db-get-specification "guix")) (db-get-specification "guix"))
(test-equal "db-add-build" (test-equal "db-add-evaluation"
#f '(2 3)
(let ((build (make-dummy-build "/foo.drv"))) (list
(db-add-build build) (db-add-evaluation "guix"
(make-dummy-checkouts "fakesha1" "fakesha2"))
(db-add-evaluation "guix"
(make-dummy-checkouts "fakesha3" "fakesha4"))))
;; Should return #f when adding a build whose derivation is already (test-assert "db-set-evaluation-status"
;; there, see <https://bugs.gnu.org/28094>. (db-set-evaluation-status 2 (evaluation-status started)))
(catch-sqlite-error
(db-add-build build) (test-assert "db-set-evaluation-time"
(on SQLITE_CONSTRAINT_UNIQUE => #f)))) (db-set-evaluation-time 2))
(test-assert "db-abort-pending-evaluations"
(db-abort-pending-evaluations))
(test-equal "db-add-build"
"/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)))
(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)))
(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!" (test-equal "db-update-build-status!"
(list (build-status scheduled) (list (build-status scheduled)
(build-status started) (build-status started)
(build-status succeeded) (build-status succeeded)
"/foo.drv.log") "/foo2.drv.log")
(with-temporary-database (let* ((derivation (db-add-build
(let* ((derivation (db-add-build (make-dummy-build "/foo2.drv" 2
(make-dummy-build "/foo.drv" 1 #:outputs '(("out" . "/foo")))))
#:outputs '(("out" . "/foo"))))) (get-status (lambda* (#:optional (key #:status))
(get-status (lambda* (#:optional (key #:status)) (assq-ref (db-get-build derivation) key))))
(assq-ref (db-get-build derivation) key)))) (let ((status0 (get-status)))
(db-add-evaluation "guix" (make-dummy-checkouts "fakesha1" (db-update-build-status! "/foo2.drv" (build-status started))
"fakesha2")) (let ((status1 (get-status)))
(db-add-specification example-spec) (db-update-build-status! "/foo2.drv" (build-status succeeded)
#:log-file "/foo2.drv.log")
(let ((status0 (get-status))) ;; Second call shouldn't make any difference.
(db-update-build-status! "/foo.drv" (build-status started)) (db-update-build-status! "/foo2.drv" (build-status succeeded)
(let ((status1 (get-status))) #:log-file "/foo2.drv.log")
(db-update-build-status! "/foo.drv" (build-status succeeded)
#:log-file "/foo.drv.log")
;; Second call shouldn't make any difference. (let ((status2 (get-status))
(db-update-build-status! "/foo.drv" (build-status succeeded) (start (get-status #:starttime))
#:log-file "/foo.drv.log") (end (get-status #:stoptime))
(log (get-status #:log)))
(let ((status2 (get-status)) (and (> start 0) (>= end start)
(start (get-status #:starttime)) (list status0 status1 status2 log)))))))
(end (get-status #:stoptime))
(log (get-status #:log)))
(and (> start 0) (>= end start)
(list status0 status1 status2 log))))))))
(test-equal "db-get-builds" (test-equal "db-get-builds"
#(((1 "/foo.drv") (2 "/bar.drv") (3 "/baz.drv")) ;ascending order '(("/baa.drv" "/bar.drv" "/baz.drv") ;ascending order
((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;descending order ("/baz.drv" "/bar.drv" "/baa.drv") ;descending order
((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto ("/baz.drv" "/bar.drv" "/baa.drv") ;ditto
((3 "/baz.drv")) ;nr = 1 ("/baz.drv") ;nr = 1
((2 "/bar.drv") (1 "/foo.drv") (3 "/baz.drv"))) ;status+submission-time ("/bar.drv" "/baa.drv" "/baz.drv")) ;status+submission-time
(with-temporary-database (begin
;; Populate the 'Builds'', 'Evaluations', and (exec-query (%db) "DELETE FROM Builds;")
;; 'Specifications' tables in a consistent way, as expected by the (db-add-build (make-dummy-build "/baa.drv" 2
;; 'db-get-builds' query. #:outputs `(("out" . "/baa"))))
(db-add-build (make-dummy-build "/foo.drv" 1
#:outputs `(("out" . "/foo"))))
(db-add-build (make-dummy-build "/bar.drv" 2 (db-add-build (make-dummy-build "/bar.drv" 2
#:outputs `(("out" . "/bar")))) #:outputs `(("out" . "/bar"))))
(db-add-build (make-dummy-build "/baz.drv" 3 (db-add-build (make-dummy-build "/baz.drv" 2
#:outputs `(("out" . "/baz")))) #: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) (db-update-build-status! "/bar.drv" (build-status started)
#:log-file "/bar.drv.log") #:log-file "/bar.drv.log")
(let ((summarize (lambda (alist) (let ((summarize (lambda (alist)
(list (assq-ref alist #:id) (assq-ref alist #:derivation))))
(assq-ref alist #:derivation))))) (list (map summarize (db-get-builds '((nr . 3) (order . build-id))))
(vector (map summarize (db-get-builds '((nr . 3) (order . build-id)))) (map summarize (db-get-builds '()))
(map summarize (db-get-builds '())) (map summarize (db-get-builds '((jobset . "guix"))))
(map summarize (db-get-builds '((jobset . "guix")))) (map summarize (db-get-builds '((nr . 1))))
(map summarize (db-get-builds '((nr . 1)))) (map summarize
(map summarize (db-get-builds '((order . status+submission-time))))))))
(db-get-builds '((order . status+submission-time))))))))
(test-equal "db-get-pending-derivations" (test-equal "db-get-pending-derivations"
'("/bar.drv" "/foo.drv") '("/bar.drv" "/foo.drv")
(with-temporary-database (begin
;; Populate the 'Builds', 'Evaluations', and 'Specifications' tables. (exec-query (%db) "DELETE FROM Builds;")
(db-add-build (make-dummy-build "/foo.drv" 1 (db-add-build (make-dummy-build "/foo.drv" 1
#:outputs `(("out" . "/foo")))) #:outputs `(("out" . "/foo"))))
(db-add-build (make-dummy-build "/bar.drv" 2 (db-add-build (make-dummy-build "/bar.drv" 2
#:outputs `(("out" . "/bar")))) #: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<?))) (sort (db-get-pending-derivations) string<?)))
(test-assert "db-close" (test-assert "db-close"
(db-close (%db))) (begin
(exec-query (%db) (format #f "DROP OWNED BY CURRENT_USER;"))
(begin (db-close (%db))
(%db-channel #f) #t)))
(delete-file database-name)))
;;; Local Variables:
;;; eval: (put 'with-temporary-database 'scheme-indent-function 0)
;;; End:

26
tests/http.scm
View File

@ -24,6 +24,7 @@
(cuirass utils) (cuirass utils)
(json) (json)
(fibers) (fibers)
(squee)
(web uri) (web uri)
(web client) (web client)
(web response) (web response)
@ -48,13 +49,8 @@
(define (test-cuirass-uri route) (define (test-cuirass-uri route)
(string-append "http://localhost:6688" 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 (define %db
;; Global Slot for a database object. (make-parameter #f))
(make-parameter #t))
(define build-query-result (define build-query-result
'((#:id . 1) '((#:id . 1)
@ -111,11 +107,10 @@
(test-assert "db-init" (test-assert "db-init"
(begin (begin
(%db (db-init database-name)) (%db (db-open))
(%db-channel (make-worker-thread-channel (%db-channel (make-worker-thread-channel
(lambda () (lambda ()
(list (%db))))) (list (%db)))))
(%db-writer-channel (%db-channel))
#t)) #t))
(test-assert "cuirass-run" (test-assert "cuirass-run"
@ -191,13 +186,13 @@
((#:commit . "fakesha3") ((#:commit . "fakesha3")
(#:input . "packages") (#:input . "packages")
(#:directory . "dir4"))))) (#:directory . "dir4")))))
(db-add-build build1)
(db-add-build build2)
(db-add-specification specification) (db-add-specification specification)
(db-add-evaluation "guix" checkouts1 (db-add-evaluation "guix" checkouts1
#:timestamp 1501347493) #:timestamp 1501347493)
(db-add-evaluation "guix" checkouts2 (db-add-evaluation "guix" checkouts2
#:timestamp 1501347493))) #:timestamp 1501347493)
(db-add-build build1)
(db-add-build build2)))
(test-assert "/specifications" (test-assert "/specifications"
(match (call-with-input-string (match (call-with-input-string
@ -290,8 +285,7 @@
(http-get-body (test-cuirass-uri "/api/evaluations?nr=1"))))) (http-get-body (test-cuirass-uri "/api/evaluations?nr=1")))))
(test-assert "db-close" (test-assert "db-close"
(db-close (%db))) (begin
(exec-query (%db) (format #f "DROP OWNED BY CURRENT_USER;"))
(begin (db-close (%db))
(%db-channel #f) #t)))
(delete-file database-name)))

135
tests/metrics.scm
View File

@ -21,16 +21,9 @@
(cuirass metrics) (cuirass metrics)
(cuirass utils) (cuirass utils)
((guix utils) #:select (call-with-temporary-output-file)) ((guix utils) #:select (call-with-temporary-output-file))
(squee)
(srfi srfi-64)) (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 (define today
(let ((time (current-time))) (let ((time (current-time)))
(- time (modulo time 86400)))) (- time (modulo time 86400))))
@ -39,50 +32,49 @@
(- today 86400)) (- today 86400))
(define %db (define %db
;; Global Slot for a database object. (make-parameter #f))
(make-parameter #t))
(define database-name
;; Use an empty and temporary database for the tests.
(string-append (getcwd) "/" (number->string (getpid)) "-tmp.db"))
(test-group-with-cleanup "database" (test-group-with-cleanup "database"
(test-assert "db-init" (test-assert "db-init"
(begin (begin
(%db (db-init database-name)) (%db (db-open))
(%db-channel (make-worker-thread-channel (%db-channel (make-worker-thread-channel
(lambda () (lambda ()
(list (%db))))) (list (%db)))))
(%db-writer-channel (%db-channel))
#t)) #t))
(test-assert "sqlite-exec" (test-assert "exec-query"
(begin (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, INSERT INTO Evaluations (specification, status,
timestamp, checkouttime, evaltime) VALUES ('guix', -1, 1600174547, 0, 0);") timestamp, checkouttime, evaltime) VALUES ('guix', -1, 1600174547, 0, 0);")
(sqlite-exec (%db) (format #f "\ (exec-query (%db) (format #f "\
INSERT INTO Evaluations (specification, status, INSERT INTO Evaluations (specification, status,
timestamp, checkouttime, evaltime) VALUES ('guix', 0, ~a, ~a, ~a);\ timestamp, checkouttime, evaltime) VALUES ('guix', 0, ~a, ~a, ~a);\
" yesterday (+ yesterday 100) (+ yesterday 600))) " yesterday (+ yesterday 100) (+ yesterday 600)))
(sqlite-exec (%db) "\ (exec-query (%db) "\
INSERT INTO Evaluations (specification, status, INSERT INTO Evaluations (specification, status,
timestamp, checkouttime, evaltime) VALUES ('guix', 1, 1600174547, timestamp, checkouttime, evaltime) VALUES ('guix', 1, 1600174547,
1600174548, 0);") 1600174548, 0);")
(sqlite-exec (%db) "\ (exec-query (%db) "\
INSERT INTO Evaluations (specification, status, INSERT INTO Evaluations (specification, status,
timestamp, checkouttime, evaltime) VALUES ('guix', 1, 1600174547, timestamp, checkouttime, evaltime) VALUES ('guix', 1, 1600174547,
1600174548, 1600174647);") 1600174548, 1600174647);")
(sqlite-exec (%db) (format #f "\ (exec-query (%db) (format #f "\
INSERT INTO Builds (id, derivation, evaluation, job_name, system, INSERT INTO Builds (id, derivation, evaluation, job_name, system,
nix_name, log, status, timestamp, starttime, stoptime) VALUES nix_name, log, status, timestamp, starttime, stoptime) VALUES
(1, '/gnu/store/1.drv', 2, '', '', '', '', 0, ~a, ~a, ~a);\ (1, '/gnu/store/1.drv', 2, '', '', '', '', 0, ~a, ~a, ~a);\
" yesterday (+ yesterday 1600) (+ yesterday 2600))) " yesterday (+ yesterday 1600) (+ yesterday 2600)))
(sqlite-exec (%db) (format #f "\ (exec-query (%db) (format #f "\
INSERT INTO Builds (id, derivation, evaluation, job_name, system, INSERT INTO Builds (id, derivation, evaluation, job_name, system,
nix_name, log, status, timestamp, starttime, stoptime) VALUES nix_name, log, status, timestamp, starttime, stoptime) VALUES
(2, '/gnu/store/2.drv', 2, '', '', '', '', -2, 0, 0, 0);")) (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, INSERT INTO Builds (id, derivation, evaluation, job_name, system,
nix_name, log, status, timestamp, starttime, stoptime) VALUES nix_name, log, status, timestamp, starttime, stoptime) VALUES
(3, '/gnu/store/3.drv', 4, '', '', '', '', 0, 1600174451, 1600174451, (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-update-metric 'average-eval-duration-per-spec "guix")
(db-get-metrics-with-id 'average-eval-duration-per-spec))) (db-get-metrics-with-id 'average-eval-duration-per-spec)))
(test-equal "builds-per-day" (test-equal "builds-per-day"
1.0 1.0
(begin (begin
(db-update-metric 'builds-per-day) (db-update-metric 'builds-per-day)
(db-get-metric 'builds-per-day yesterday))) (db-get-metric 'builds-per-day yesterday)))
(test-equal "pending-builds" (test-equal "pending-builds"
`((,today . 1.0)) `((,today . 1.0))
(begin (begin
(db-update-metric 'pending-builds) (db-update-metric 'pending-builds)
(db-get-metrics-with-id 'pending-builds))) (db-get-metrics-with-id 'pending-builds)))
(test-equal "new-derivations-per-day" (test-equal "new-derivations-per-day"
`((,yesterday . 1.0)) `((,yesterday . 1.0))
(begin (begin
(db-update-metric 'new-derivations-per-day) (db-update-metric 'new-derivations-per-day)
(db-get-metrics-with-id 'new-derivations-per-day))) (db-get-metrics-with-id 'new-derivations-per-day)))
(test-equal "percentage-failed-eval-per-spec" (test-equal "percentage-failed-eval-per-spec"
`(("guix" . 50.0)) `(("guix" . 50.0))
(begin (begin
(db-update-metric 'percentage-failed-eval-per-spec "guix") (db-update-metric 'percentage-failed-eval-per-spec "guix")
(db-get-metrics-with-id 'percentage-failed-eval-per-spec))) (db-get-metrics-with-id 'percentage-failed-eval-per-spec)))
(test-equal "db-update-metrics" (test-equal "db-update-metrics"
`((,today . 2.0)) `((,today . 2.0))
(begin (begin
(sqlite-exec (%db) (format #f "\ (exec-query (%db) (format #f "\
INSERT INTO Builds (id, derivation, evaluation, job_name, system, INSERT INTO Builds (id, derivation, evaluation, job_name, system,
nix_name, log, status, timestamp, starttime, stoptime) VALUES nix_name, log, status, timestamp, starttime, stoptime) VALUES
(4, '/gnu/store/4.drv', 1, '', '', '', '', -2, 0, 0, 0);")) (4, '/gnu/store/4.drv', 1, '', '', '', '', -2, 0, 0, 0);"))
(db-update-metrics) (db-update-metrics)
(db-get-metrics-with-id 'pending-builds))) (db-get-metrics-with-id 'pending-builds)))
(test-equal "average-eval-build-start-time" (test-equal "average-eval-build-start-time"
`((2 . 1000.0)) `((2 . 1000.0))
(begin (begin
(db-update-metric 'average-eval-build-start-time 2) (db-update-metric 'average-eval-build-start-time 2)
(db-get-metrics-with-id 'average-eval-build-start-time))) (db-get-metrics-with-id 'average-eval-build-start-time)))
(test-equal "average-eval-build-complete-time" (test-equal "average-eval-build-complete-time"
`((2 . 2000.0)) `((2 . 2000.0))
(begin (begin
(db-update-metric 'average-eval-build-complete-time 2) (db-update-metric 'average-eval-build-complete-time 2)
(db-get-metrics-with-id 'average-eval-build-complete-time))) (db-get-metrics-with-id 'average-eval-build-complete-time)))
(test-equal "evaluation-completion-speed" (test-equal "evaluation-completion-speed"
900.0 900.0
(begin (begin
(db-update-metric 'evaluation-completion-speed 4) (db-update-metric 'evaluation-completion-speed 4)
(db-get-metric 'evaluation-completion-speed 4))) (db-get-metric 'evaluation-completion-speed 4)))
(test-assert "db-close" (test-assert "db-close"
(db-close (%db))) (begin
(exec-query (%db) (format #f "DROP OWNED BY CURRENT_USER;"))
(begin (db-close (%db))
(%db-channel #f) #t)))
(delete-file database-name)))
;;; Local Variables:
;;; eval: (put 'with-temporary-database 'scheme-indent-function 0)
;;; End: