guix/guix-cuirass
2
0
Fork 0
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git synced 2023-12-14 06:03:04 +01:00
Code Issues Releases Wiki Activity
guix-cuirass/src/cuirass/database.scm
Christopher Baines 46f73b6b7c Support returning build information by output. 
Being able to take a derivation and query the build information is useful, but
in cases where there are multiple derivations that produce the same outputs,
the probability of getting the data back from Cuirass is reduced.

This is because Cuirass might not have build the exact derivation you have,
but a different derivation that produces the same outputs (this can commonly
happen when a related fixed output derivation changes).

Cuirass doesn't store derivations if they produce the same outputs as a
derivation it already knows about, so it can't determine if this is the
case. Therefore, provide a way of querying build results by output, rather
than derivation.

The motivation behind this is to make it easier to import build information in
to the Guix Data Service.

* src/cuirass/database.scm (db-get-output): New procedure.
* src/cuirass/http.scm (respond-output-not-found): New procedure.
(request-path-components): Handle /output/… requests.
* doc/cuirass.texi (Build information): Mention that you can get build
information by output.
2020-01-16 08:33:03 +00:00

1061 lines
42 KiB
Scheme
Raw Blame History

;;; database.scm -- store evaluation and build results
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of Cuirass.
;;;
;;; Cuirass is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Cuirass is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(define-module (cuirass database)
#:use-module (cuirass config)
#:use-module (cuirass utils)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 ftw)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (sqlite3)
#:export (;; Procedures.
db-init
db-open
db-close
db-add-specification
db-remove-specification
db-get-specifications
db-add-evaluation
db-set-evaluations-done
db-set-evaluation-done
db-get-pending-derivations
build-status
db-add-build
db-update-build-status!
db-get-output
db-get-build
db-get-builds
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-events
db-delete-events-with-ids-<=-to
db-get-evaluations
db-get-evaluations-build-summary
db-get-evaluations-id-min
db-get-evaluations-id-max
db-get-evaluation-specification
db-get-evaluation-summary
read-sql-file
read-quoted-string
sqlite-exec
;; Parameters.
%package-database
%package-schema-file
%db-channel
%record-events?
;; Macros.
with-db-critical-section
with-database))
(define (%sqlite-exec db sql . args)
"Evaluate the given SQL query with the given ARGS. Return the list of
rows."
(define (normalize arg)
;; Turn ARG into a string, unless it's a primitive SQL datatype.
(if (or (null? arg) (pair? arg) (vector? arg))
(object->string arg)
arg))
(let ((stmt (sqlite-prepare db sql #:cache? #t)))
(for-each (lambda (arg index)
(sqlite-bind stmt index (normalize arg)))
args (iota (length args) 1))
(let ((result (sqlite-fold-right cons '() stmt)))
(sqlite-finalize stmt)
result)))
(define-syntax sqlite-exec/bind
(lambda (s)
;; Expand to an '%sqlite-exec' call where the query string has
;; interspersed question marks and the argument list is separate.
(define (string-literal? s)
(string? (syntax->datum s)))
(syntax-case s ()
((_ db (bindings ...) tail str arg rest ...)
#'(sqlite-exec/bind db
(bindings ... (str arg))
tail
rest ...))
((_ db (bindings ...) tail str)
#'(sqlite-exec/bind db (bindings ...) str))
((_ db ((strings args) ...) tail)
(and (every string-literal? #'(strings ...))
(string-literal? #'tail))
;; Optimized case: only string literals.
(with-syntax ((query (string-join
(append (syntax->datum #'(strings ...))
(list (syntax->datum #'tail)))
"? ")))
#'(%sqlite-exec db query args ...)))
((_ db ((strings args) ...) tail)
;; Fallback case: some of the strings aren't literals.
#'(%sqlite-exec db (string-join (list strings ... tail) "? ")
args ...)))))
(define-syntax-rule (sqlite-exec db query args ...)
"Execute the specific QUERY with the given ARGS. Uses of 'sqlite-exec'
typically look like this:
(sqlite-exec 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.
This ensures that (1) SQL injection is impossible, and (2) the number of
question marks matches the number of arguments to bind."
(sqlite-exec/bind db () "" query args ...))
(define-syntax catch-sqlite-error
(syntax-rules (on =>)
"Run EXP..., catching SQLite error and handling the given code as
specified."
((_ exp ... (on error => handle ...))
(catch 'sqlite-error
(lambda ()
exp ...)
(lambda (key who code message . rest)
(if (= code error)
(begin handle ...)
(apply throw key who code message rest)))))))
(define %package-database
;; Define to the database file name of this package.
(make-parameter (string-append %localstatedir "/lib/" %package
"/" %package ".db")))
(define %package-schema-file
;; Define to the database schema file of this package.
(make-parameter (string-append (or (getenv "CUIRASS_DATADIR")
(string-append %datadir "/" %package))
"/schema.sql")))
(define %package-sql-dir
;; Define to the directory containing the SQL files.
(make-parameter (string-append (or (getenv "CUIRASS_DATADIR")
(string-append %datadir "/" %package))
"/sql")))
(define %db-channel
(make-parameter #f))
(define %record-events?
(make-parameter #f))
(define-syntax-rule (with-db-critical-section db exp ...)
"Evaluate EXP... in the critical section corresponding to %DB-CHANNEL.
DB is bound to the argument of that critical section: the database
connection."
(call-with-critical-section (%db-channel)
(lambda (db) exp ...)))
(define (read-sql-file file-name)
"Return a list of string containing SQL instructions from FILE-NAME."
(call-with-input-file file-name
(lambda (port)
(let loop ((insts '()))
(let ((inst (read-delimited ";" port 'concat)))
(if (or (eof-object? inst)
;; Don't cons the spaces after the last instructions.
(string-every char-whitespace? inst))
(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;")
db)
(define (db-load db schema)
"Evaluate the file SCHEMA, which may contain SQL queries, into DB."
(for-each (cut sqlite-exec db <>)
(read-sql-file schema)))
(define (db-schema-version db)
(vector-ref (car (sqlite-exec db "PRAGMA user_version;")) 0))
(define (db-set-schema-version db version)
(sqlite-exec db (format #f "PRAGMA user_version = ~d;" version)))
(define (latest-db-schema-version)
"Return the version to which the schema should be upgraded, based on the
upgrade-n.sql files, or 0 if there are no such files."
(reduce max 0
(map (compose string->number (cut match:substring <> 1))
(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)))
"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))
(define (schema-upgrade-file version)
"Return the file containing the SQL instructions that upgrade the schema
from VERSION-1 to VERSION."
(in-vicinity (%package-sql-dir) (format #f "upgrade-~a.sql" version)))
(define (db-upgrade db)
"Upgrade database DB based on its current version and the available
upgrade-n.sql files."
(for-each (lambda (version)
(db-load db (schema-upgrade-file version))
(db-set-schema-version db version))
(let ((current (db-schema-version db)))
(iota (- (latest-db-schema-version) current) (1+ current))))
db)
(define* (db-open #:optional (db (%package-database)))
"Open database to store or read jobs and builds informations. Return a
database object."
;; Use "write-ahead log" mode because it improves concurrency and should
;; avoid SQLITE_LOCKED errors when we have several readers:
;; <https://www.sqlite.org/wal.html>.
;; SQLITE_OPEN_NOMUTEX disables mutexing on database connection and prepared
;; statement objects, thus making us responsible for serializing access to
;; database connections and prepared statements.
(set-db-options (if (file-exists? db)
(db-upgrade
(sqlite-open db (logior SQLITE_OPEN_READWRITE
SQLITE_OPEN_NOMUTEX)))
(db-init db))))
(define (db-close db)
"Close database object DB."
(sqlite-close db))
(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)))
(define (db-add-input spec-name input)
(with-db-critical-section db
(sqlite-exec db "\
INSERT OR IGNORE 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) ");")
(last-insert-rowid db)))
(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-critical-section db
(catch-sqlite-error
(sqlite-exec db "\
INSERT INTO Checkouts (specification, revision, evaluation, input,
directory) VALUES ("
spec-name ", "
(assq-ref checkout #:commit) ", "
eval-id ", "
(assq-ref checkout #:input) ", "
(assq-ref checkout #:directory) ");")
(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))))
(define (db-add-specification spec)
"Store SPEC in database the database. SPEC inputs are stored in the INPUTS
table."
(with-db-critical-section db
(sqlite-exec db "\
INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \
package_path_inputs, proc_input, proc_file, proc, proc_args) \
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) ");")
(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)))
(define (db-remove-specification name)
"Remove the specification matching NAME from the database and its inputs."
(with-db-critical-section db
(sqlite-exec db "BEGIN TRANSACTION;")
(sqlite-exec db "\
DELETE FROM Inputs WHERE specification=" name ";")
(sqlite-exec db "\
DELETE FROM Specifications WHERE name=" name ";")
(sqlite-exec db "COMMIT;")))
(define (db-get-inputs spec-name)
(with-db-critical-section db
(let loop ((rows (sqlite-exec
db "SELECT * FROM Inputs WHERE specification="
spec-name ";"))
(inputs '()))
(match rows
(() inputs)
((#(specification name url load-path branch tag revision no-compile-p)
. rest)
(loop rest
(cons `((#:name . ,name)
(#:url . ,url)
(#:load-path . ,load-path)
(#:branch . ,branch)
(#:tag . ,tag)
(#:commit . ,revision)
(#:no-compile? . ,(positive? no-compile-p)))
inputs)))))))
(define (db-get-specifications)
(with-db-critical-section db
(let loop ((rows (sqlite-exec db "SELECT * FROM Specifications ORDER BY name DESC;"))
(specs '()))
(match rows
(() specs)
((#(name load-path-inputs package-path-inputs proc-input proc-file proc
proc-args)
. 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)))
specs)))))))
(define (db-add-evaluation spec-name checkouts)
"Add a new evaluation for SPEC-NAME only if one of the CHECKOUTS is new.
Otherwise, return #f."
(with-db-critical-section db
(sqlite-exec db "BEGIN TRANSACTION;")
(sqlite-exec db "INSERT INTO Evaluations (specification, in_progress)
VALUES (" spec-name ", true);")
(let* ((eval-id (last-insert-rowid db))
(new-checkouts (filter-map
(cut db-add-checkout spec-name eval-id <>)
checkouts)))
(if (null? new-checkouts)
(begin (sqlite-exec 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;")
eval-id)))))
(define (db-set-evaluations-done)
(with-db-critical-section db
(sqlite-exec db "UPDATE Evaluations SET in_progress = false;")))
(define (db-set-evaluation-done eval-id)
(with-db-critical-section db
(sqlite-exec db "UPDATE Evaluations SET in_progress = false
WHERE id = " eval-id ";")
(db-add-event 'evaluation
(time-second (current-time time-utc))
`((#:evaluation . ,eval-id)
(#:in_progress . #f)))))
(define-syntax-rule (with-database body ...)
"Run BODY with %DB-CHANNEL being dynamically bound to a channel implementing
a critical section that allows database operations to be serialized."
;; XXX: We don't install an unwind handler to play well with delimited
;; continuations and fibers. But as a consequence, we leak DB when BODY
;; raises an exception.
(let ((db (db-open)))
(unwind-protect
;; Process database queries sequentially in a thread. We need this
;; because otherwise we would need to use the SQLite multithreading
;; feature for which it is required to wait until the database is
;; available, and the waiting would happen in non-cooperative and
;; non-resumable code that blocks the fibers scheduler. Now the database
;; access blocks on PUT-MESSAGE, which allows the scheduler to schedule
;; another fiber. Also, creating one new handle for each request would
;; be costly and may defeat statement caching.
(parameterize ((%db-channel (make-critical-section db)))
body ...)
(db-close db))))
(define* (read-quoted-string #:optional (port (current-input-port)))
"Read all of the characters out of PORT and return them as a SQL quoted
string."
(let loop ((chars '()))
(let ((char (read-char port)))
(cond ((eof-object? char) (list->string (reverse! chars)))
((char=? char #\') (loop (cons* char char chars)))
(else (loop (cons char chars)))))))
;; Extended error codes (see <sqlite3.h>).
;; XXX: This should be defined by (sqlite3).
(define SQLITE_CONSTRAINT 19)
(define SQLITE_CONSTRAINT_PRIMARYKEY
(logior SQLITE_CONSTRAINT (ash 6 8)))
(define SQLITE_CONSTRAINT_UNIQUE
(logior SQLITE_CONSTRAINT (ash 8 8)))
(define-enumeration build-status
;; Build status as expected by Hydra's API. Note: the negative values are
;; Cuirass' own extensions.
(scheduled -2)
(started -1)
(succeeded 0)
(failed 1)
(failed-dependency 2)
(failed-other 3)
(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-critical-section db
(catch-sqlite-error
(match output
((name . path)
(sqlite-exec 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))))
(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-critical-section db
(catch-sqlite-error
(sqlite-exec db "BEGIN TRANSACTION;")
(sqlite-exec db "
INSERT INTO Builds (derivation, evaluation, job_name, system, nix_name, log,
status, 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)) ", "
(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)))
(if (null? new-outputs)
(begin (sqlite-exec db "ROLLBACK;")
#f)
(begin (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)))
(sqlite-exec db "COMMIT;")
derivation)))
;; If we get a unique-constraint-failed error, that means we have
;; already inserted the same build. That happens when several jobs
;; produce the same derivation, and we can ignore it.
(on SQLITE_CONSTRAINT_PRIMARYKEY
=>
(sqlite-exec db "ROLLBACK;") #f))))
(define* (db-update-build-status! drv status #:key log-file)
"Update the database so that DRV's status is STATUS. This also updates the
'starttime' or 'stoptime' fields. If LOG-FILE is true, record it as the build
log file for DRV."
(define now
(time-second (current-time time-utc)))
(define status-names
`((,(build-status succeeded) . "succeeded")
(,(build-status failed) . "failed")
(,(build-status failed-dependency) . "failed (dependency)")
(,(build-status failed-other) . "failed (other)")
(,(build-status canceled) . "canceled")))
(with-db-critical-section db
(if (= status (build-status started))
(begin
(sqlite-exec db "UPDATE Builds SET starttime=" now ", status="
status "WHERE derivation=" drv ";")
(db-add-event 'build
now
`((#:derivation . ,drv)
(#:event . started))))
;; Update only if we're switching to a different status; otherwise
;; leave things unchanged. This ensures that 'stoptime' remains valid
;; 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)))))))))
(define (db-get-output path)
"Retrieve the OUTPUT for PATH."
(with-db-critical-section 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-critical-section 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)))))))
(define (filters->order filters)
(match (assq 'order filters)
(('order . 'build-id) "rowid ASC")
(('order . 'decreasing-build-id) "rowid DESC")
(('order . 'finish-time) "stoptime DESC")
(('order . 'finish-time+build-id) "stoptime DESC, rowid DESC")
(('order . 'start-time) "starttime DESC")
(('order . 'submission-time) "timestamp DESC")
;; With this order, builds in 'running' state (-1) appear
;; before those in 'scheduled' state (-2).
(('order . 'status+submission-time) "status DESC, timestamp DESC")
(_ "rowid DESC")))
(define (query->bind-arguments query-string)
"Return a list of keys to query strings by parsing QUERY-STRING."
(let ((args (append-map
(lambda (token)
(match (string-split token #\:)
(("system" system)
`(#:system ,system))
(("spec" spec)
`(#:spec ,spec))
((_ invalid) '()) ; ignore
((query)
`(#:query
,(fold
(lambda (transform val)
(match transform
((pred modify-true modify-false)
((if (pred val) modify-true modify-false) val))))
query
;; Process special characters ^ and $.
(list (list (cut string-prefix? "^" <>)
(cut string-drop <> 1)
(cut string-append "%" <>))
(list (cut string-suffix? "$" <>)
(cut string-drop-right <> 1)
(cut string-append <> "%"))))))))
(string-tokenize query-string))))
;; Normalize arguments
(fold (lambda (key acc)
(if (member key acc)
acc
(append (list key #f) acc)))
args '(#:spec #:system))))
(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-critical-section db
(let* ((stmt-text (format #f "SELECT * FROM (
SELECT Builds.rowid, 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 (: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))
ORDER BY
CASE WHEN :borderlowid IS NULL THEN Builds.rowid
ELSE -Builds.rowid
END DESC
LIMIT :nr)
ORDER BY rowid DESC;"))
(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))))
(sqlite-reset stmt)
(let loop ((rows (sqlite-fold-right cons '() stmt))
(builds '()))
(match rows
(() (reverse builds))
((#(id timestamp starttime stoptime log status job-name
system nix-name specification) . rest)
(loop rest
(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))
builds))))))))
(define (db-get-builds filters)
"Retrieve all builds in the database which are matched by given FILTERS.
FILTERS is an assoc list whose possible keys are 'derivation | 'id | 'jobset |
'job | 'system | 'nr | 'order | 'status | 'evaluation."
(with-db-critical-section db
(let* ((order (filters->order filters))
(stmt-text (format #f "SELECT * FROM (
SELECT Builds.derivation, Builds.rowid, 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 (:id IS NULL OR (:id = Builds.rowid))
AND (:derivation IS NULL OR (:derivation = Builds.derivation))
AND (:jobset IS NULL OR (:jobset = Specifications.name))
AND (:job IS NULL OR (:job = Builds.job_name))
AND (:system IS NULL OR (:system = Builds.system))
AND (:evaluation IS NULL OR (:evaluation = Builds.evaluation))
AND (:status IS NULL OR (:status = 'done' AND Builds.status >= 0)
OR (:status = 'pending' AND Builds.status < 0)
OR (:status = 'succeeded' AND Builds.status = 0)
OR (:status = 'failed' AND Builds.status > 0))
AND (:borderlowtime IS NULL OR :borderlowid IS NULL
OR ((:borderlowtime, :borderlowid) < (Builds.stoptime, Builds.rowid)))
AND (:borderhightime IS NULL OR :borderhighid IS NULL
OR ((:borderhightime, :borderhighid) > (Builds.stoptime, Builds.rowid)))
ORDER BY
CASE WHEN :borderlowtime IS NULL
OR :borderlowid IS NULL THEN Builds.stoptime
ELSE -Builds.stoptime
END DESC,
CASE WHEN :borderlowtime IS NULL
OR :borderlowid IS NULL THEN Builds.rowid
ELSE -Builds.rowid
END DESC
LIMIT :nr)
ORDER BY ~a, rowid ASC;" order))
(stmt (sqlite-prepare db stmt-text #:cache? #t)))
(sqlite-bind-arguments
stmt
#:derivation (assq-ref filters 'derivation)
#:id (assq-ref filters 'id)
#:jobset (assq-ref filters 'jobset)
#:job (assq-ref filters 'job)
#:evaluation (assq-ref filters 'evaluation)
#:system (assq-ref filters 'system)
#:status (and=> (assq-ref filters 'status) object->string)
#:borderlowid (assq-ref filters 'border-low-id)
#:borderhighid (assq-ref filters 'border-high-id)
#:borderlowtime (assq-ref filters 'border-low-time)
#:borderhightime (assq-ref filters 'border-high-time)
#:nr (match (assq-ref filters 'nr)
(#f -1)
(x x)))
(sqlite-reset stmt)
(let loop ((rows (sqlite-fold-right cons '() stmt))
(builds '()))
(match rows
(() (reverse builds))
((#(derivation id timestamp starttime stoptime log status job-name
system nix-name specification) . rest)
(loop rest
(cons `((#:derivation . ,derivation)
(#:id . ,id)
(#:timestamp . ,timestamp)
(#:starttime . ,starttime)
(#:stoptime . ,stoptime)
(#:log . ,log)
(#:status . ,status)
(#:job-name . ,job-name)
(#:system . ,system)
(#:nix-name . ,nix-name)
(#:specification . ,specification)
(#:outputs . ,(db-get-outputs derivation)))
builds))))))))
(define (db-get-build derivation-or-id)
"Retrieve a build in the database which corresponds to DERIVATION-OR-ID."
(with-db-critical-section db
(let ((key (if (number? derivation-or-id) 'id 'derivation)))
(expect-one-row (db-get-builds `((,key . ,derivation-or-id)))))))
(define (db-add-event type timestamp details)
(when (%record-events?)
(with-db-critical-section db
(sqlite-exec db "\
INSERT INTO Events (type, timestamp, event_json) VALUES ("
(symbol->string type) ", "
timestamp ", "
(object->json-string details)
");")
#t)))
(define (db-get-events filters)
(with-db-critical-section db
(let* ((stmt-text "\
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)))
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)))
(sqlite-reset stmt)
(let loop ((rows (sqlite-fold-right cons '() stmt))
(events '()))
(match rows
(() (reverse events))
((#(id type timestamp event_json) . rest)
(loop rest
(cons `((#:id . ,id)
(#:type . ,type)
(#:timestamp . ,timestamp)
(#:event_json . ,event_json))
events))))))))
(define (db-delete-events-with-ids-<=-to id)
(with-db-critical-section db
(sqlite-exec
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-critical-section db
(map (match-lambda (#(drv) drv))
(sqlite-exec db "
SELECT derivation FROM Builds WHERE Builds.status < 0;"))))
(define (db-get-checkouts eval-id)
(with-db-critical-section db
(let loop ((rows (sqlite-exec
db "SELECT revision, input, directory FROM Checkouts
WHERE evaluation =" eval-id ";"))
(checkouts '()))
(match rows
(() checkouts)
((#(revision input directory)
. rest)
(loop rest
(cons `((#:commit . ,revision)
(#:input . ,input)
(#:directory . ,directory))
checkouts)))))))
(define (db-get-evaluations limit)
(with-db-critical-section db
(let loop ((rows (sqlite-exec db "SELECT id, specification, in_progress
FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
(evaluations '()))
(match rows
(() (reverse evaluations))
((#(id specification in-progress)
. rest)
(loop rest
(cons `((#:id . ,id)
(#:specification . ,specification)
(#:in-progress . ,in-progress)
(#:checkouts . ,(db-get-checkouts id)))
evaluations)))))))
(define (db-get-evaluations-build-summary spec limit border-low border-high)
(with-db-critical-section db
(let loop ((rows (sqlite-exec db "
SELECT E.id, E.in_progress, B.succeeded, B.failed, B.scheduled
FROM
(SELECT id, in_progress
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
LEFT JOIN
(SELECT rowid, evaluation, SUM(status=0) as succeeded,
SUM(status>0) as failed, SUM(status<0) as scheduled
FROM Builds
GROUP BY evaluation) B
ON B.evaluation=E.id
ORDER BY E.id ASC;"))
(evaluations '()))
(match rows
(() evaluations)
((#(id in-progress succeeded failed scheduled) . rest)
(loop rest
(cons `((#:id . ,id)
(#:in-progress . ,in-progress)
(#:checkouts . ,(db-get-checkouts id))
(#:succeeded . ,(or succeeded 0))
(#:failed . ,(or failed 0))
(#:scheduled . ,(or scheduled 0)))
evaluations)))))))
(define (db-get-evaluations-id-min spec)
"Return the min id of evaluations for the given specification SPEC."
(with-db-critical-section db
(let ((rows (sqlite-exec db "
SELECT MIN(id) FROM Evaluations
WHERE specification=" spec)))
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
(define (db-get-evaluations-id-max spec)
"Return the max id of evaluations for the given specification SPEC."
(with-db-critical-section db
(let ((rows (sqlite-exec db "
SELECT MAX(id) FROM Evaluations
WHERE specification=" spec)))
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
(define (db-get-evaluation-summary id)
(with-db-critical-section db
(let ((rows (sqlite-exec db "
SELECT E.id, E.in_progress, B.total, B.succeeded, B.failed, B.scheduled
FROM
(SELECT id, in_progress
FROM Evaluations
WHERE (id=" id ")) E
LEFT JOIN
(SELECT rowid, evaluation, SUM(status=0) as succeeded,
SUM(status>0) as failed, SUM(status<0) as scheduled, SUM(status>-100) as total
FROM Builds
GROUP BY evaluation) B
ON B.evaluation=E.id
ORDER BY E.id ASC;")))
(and=> (expect-one-row rows)
(match-lambda
(#(id in-progress total succeeded failed scheduled)
`((#:id . ,id)
(#:in-progress . ,in-progress)
(#:total . ,(or total 0))
(#:succeeded . ,(or succeeded 0))
(#:failed . ,(or failed 0))
(#:scheduled . ,(or scheduled 0)))))))))
(define (db-get-builds-query-min query)
"Return the smallest build row identifier matching QUERY."
(with-db-critical-section db
(let* ((stmt-text "SELECT MIN(Builds.rowid) 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 (: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))
(sqlite-reset stmt)
(let ((rows (sqlite-fold-right cons '() stmt)))
(sqlite-finalize stmt)
(and=> (expect-one-row rows) vector->list)))))
(define (db-get-builds-query-max query)
"Return the largest build row identifier matching QUERY."
(with-db-critical-section db
(let* ((stmt-text "SELECT MAX(Builds.rowid) 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 (: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))
(sqlite-reset stmt)
(let ((rows (sqlite-fold-right cons '() stmt)))
(sqlite-finalize stmt)
(and=> (expect-one-row rows) vector->list)))))
(define (db-get-builds-min eval status)
"Return the min build (stoptime, rowid) pair for the given evaluation EVAL
and STATUS."
(with-db-critical-section db
(let ((rows (sqlite-exec db "
SELECT stoptime, MIN(rowid) FROM
(SELECT rowid, stoptime FROM Builds
WHERE evaluation=" eval "
AND stoptime = (SELECT MIN(stoptime)
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))))")))
(and=> (expect-one-row rows) vector->list))))
(define (db-get-builds-max eval status)
"Return the max build (stoptime, rowid) pair for the given evaluation EVAL
and STATUS."
(with-db-critical-section db
(let ((rows (sqlite-exec db "
SELECT stoptime, MAX(rowid) FROM
(SELECT rowid, stoptime FROM Builds
WHERE evaluation=" eval " AND
stoptime = (SELECT MAX(stoptime)
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))))")))
(and=> (expect-one-row rows) vector->list))))
(define (db-get-evaluation-specification eval)
"Return specification of evaluation with id EVAL."
(with-db-critical-section db
(let ((rows (sqlite-exec db "
SELECT specification FROM Evaluations
WHERE id = " eval)))
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
View git blame Copy permalink