From cbc462679d2647ecc897231cc78781a90fa2441a Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 5 Jan 2021 10:20:34 +0100 Subject: [PATCH] Switch to PostegreSQL. --- .dir-locals.el | 3 - Makefile.am | 26 +- README | 78 +- bin/cuirass.in | 153 ++-- build-aux/guix.scm | 6 +- configure.ac | 2 +- doc/cuirass.texi | 14 +- src/cuirass/base.scm | 3 +- src/cuirass/database.scm | 1555 +++++++++++++++++-------------------- src/cuirass/http.scm | 4 +- src/cuirass/metrics.scm | 269 ++++--- 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 | 135 ++-- 36 files changed, 1458 insertions(+), 1729 deletions(-) delete mode 100644 src/sql/upgrade-10.sql delete mode 100644 src/sql/upgrade-11.sql delete mode 100644 src/sql/upgrade-12.sql delete mode 100644 src/sql/upgrade-13.sql delete mode 100644 src/sql/upgrade-14.sql delete mode 100644 src/sql/upgrade-15.sql delete mode 100644 src/sql/upgrade-16.sql delete mode 100644 src/sql/upgrade-17.sql delete mode 100644 src/sql/upgrade-18.sql delete mode 100644 src/sql/upgrade-19.sql delete mode 100644 src/sql/upgrade-2.sql delete mode 100644 src/sql/upgrade-3.sql delete mode 100644 src/sql/upgrade-4.sql delete mode 100644 src/sql/upgrade-5.sql delete mode 100644 src/sql/upgrade-6.sql delete mode 100644 src/sql/upgrade-7.sql delete mode 100644 src/sql/upgrade-8.sql delete mode 100644 src/sql/upgrade-9.sql 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..b67d23b 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 -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: - ./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))) + (and specfile + (let ((new-specs (save-module-excursion + (lambda () + (set-current-module + (make-user-module '())) + (primitive-load specfile))))) - (when queries-file - (log-message "Enable SQL query logging.") - (db-log-queries queries-file)) + (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) + (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)))))) + (spawn-fiber + (essential-task + 'monitor exit-channel + (lambda () + (while #t + (log-monitoring-stats) + (sleep 600)))))) - (begin - (clear-build-queue) + (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) + ;; 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)))) + ;; 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 + '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 + '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))))))) + (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)) +(define (%exec-query db query args) + (exec-query db query args)) - (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 (normalize obj) + (if (string? obj) + obj + (and obj (object->string obj)))) -(define-syntax sqlite-exec/bind +(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 ...))))) + (with-syntax ((query + (interleave-arguments + (append (syntax->datum #'(strings ...)) + (list (syntax->datum #'tail)))))) + #'(%exec-query db query (map normalize (list args ...)))))))) -(define-syntax-rule (sqlite-exec db query args ...) - "Execute the specific QUERY with the given ARGS. Uses of 'sqlite-exec' +(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 ...)) +parameters matches the number of arguments to bind." + (%exec-query/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))))))) +(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: - ;; . - - ;; 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 ). -;; 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))))))))) +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 query) +(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))))) +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 query) +(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;") + ;; 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) + (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) + ;; 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) + (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) + ;; 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)))) + (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,7 +27,17 @@ CREATE TABLE Inputs ( revision TEXT, no_compile_p INTEGER, 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 ( @@ -34,30 +48,13 @@ CREATE TABLE Checkouts ( 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) -); - -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) + 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 . (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-build" - #f - (let ((build (make-dummy-build "/foo.drv"))) - (db-add-build build) + (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")))) - ;; Should return #f when adding a build whose derivation is already - ;; there, see . - (catch-sqlite-error - (db-add-build build) - (on SQLITE_CONSTRAINT_UNIQUE => #f)))) + (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" + "/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!" (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) + "/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") - (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! "/foo2.drv" (build-status succeeded) + #:log-file "/foo2.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)))))))) + (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) stringstring (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 "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 "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 "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 "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 "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))) + (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-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 "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-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)))