;;; database.scm -- store evaluation and build results ;;; Copyright © 2016, 2017 Mathieu Lirzin ;;; Copyright © 2017, 2020 Mathieu Othacehe ;;; Copyright © 2018, 2020 Ludovic Courtès ;;; Copyright © 2018 Clément Lassieur ;;; Copyright © 2018 Tatiana Sholokhova ;;; Copyright © 2019, 2020 Ricardo Wurmus ;;; ;;; 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 . (define-module (cuirass database) #:use-module (cuirass logging) #: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) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 threads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (system foreign) #:use-module (rnrs bytevectors) #:export (;; Procedures. db-init db-open db-close 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 db-add-evaluation db-abort-pending-evaluations db-set-evaluation-status db-set-evaluation-time 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-build-products db-get-builds-by-search 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-add-worker db-get-workers db-clear-workers db-clear-build-queue ;; Parameters. %create-database? %package-database %package-schema-file %db-channel %record-events? ;; Macros. exec-query/bind with-database with-db-worker-thread)) ;; Maximum priority for a Build or Specification. (define max-priority 9) (define (%exec-query db query args) (exec-query db query args)) (define (normalize obj) (if (string? obj) obj (and obj (object->string obj)))) (define-syntax %exec-query/bind (lambda (s) ;; Expand to an '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 ...) #'(%exec-query/bind db (bindings ... (str arg)) tail rest ...)) ((_ db (bindings ...) tail str) #'(%exec-query/bind db (bindings ...) str)) ((_ db ((strings args) ...) tail) ;; Optimized case: only string literals. (with-syntax ((query (interleave-arguments (append (syntax->datum #'(strings ...)) (list (syntax->datum #'tail)))))) #'(%exec-query db query (map normalize (list args ...)))))))) (define-syntax-rule (exec-query/bind db query args ...) "Execute the specific QUERY with the given ARGS. Uses of 'exec-query/bind' typically look like this: (exec-query/bind db \"SELECT * FROM Foo WHERE x = \" x \"AND Y=\" y \";\") 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 parameters matches the number of arguments to bind." (%exec-query/bind db () "" query args ...)) (define (exec-query/bind-params db query params) (define param-regex (make-regexp ":[a-zA-Z]+")) (define (argument-indexes arguments) (let loop ((res '()) (bindings '()) (counter 1) (arguments arguments)) (if (null? arguments) (reverse res) (let* ((arg (car arguments)) (index (assoc-ref bindings arg))) (if index (loop (cons index res) bindings counter (cdr arguments)) (loop (cons counter res) `((,arg . ,counter) ,@bindings) (1+ counter) (cdr arguments))))))) (let* ((args (reverse (fold-matches param-regex query '() (lambda (m p) (cons (match:substring m) p))))) (indexes (argument-indexes args)) (proc (lambda (m) (let ((index (car indexes))) (set! indexes (cdr indexes)) (string-append "$" (number->string index))))) (query (regexp-substitute/global #f param-regex query 'pre proc 'post)) (params (map (lambda (arg) (let ((symbol (symbol->keyword (string->symbol (substring arg 1))))) (assoc-ref params symbol))) (delete-duplicates args)))) (exec-query db query (map normalize params)))) (define %create-database? (make-parameter #f)) (define %package-database (make-parameter #f)) (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-database body ...) "Run BODY with %DB-CHANNEL being dynamically bound to a channel providing a worker thread that allows database operations to run without interfering with fibers." (parameterize ((%db-channel (make-worker-thread-channel (lambda () (list (db-open))) #:parallelism (min (current-processor-count) 8)))) body ...)) (define-syntax-rule (with-db-worker-thread db exp ...) "Evaluate EXP... in the critical section corresponding to %DB-CHANNEL. DB is bound to the argument of that critical section: the database connection. This must only be used for reading queries, i.e SELECT queries." (let ((send-timeout 2) (receive-timeout 5) (caller-name (frame-procedure-name (stack-ref (make-stack #t) 1)))) (call-with-worker-thread (%db-channel) (lambda (db) exp ...) #:send-timeout send-timeout #:send-timeout-proc (lambda () (log-message (format #f "No available database workers for ~a seconds." (number->string send-timeout)))) #:receive-timeout receive-timeout #:receive-timeout-proc (lambda () (log-message (format #f "Database worker unresponsive for ~a seconds (~a)." (number->string receive-timeout) caller-name)))))) (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 (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 exec-query db <>) (read-sql-file schema))) (define (db-schema-version db) (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) (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 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 db #:key (schema (%package-schema-file))) "Open the database to store and read jobs and builds informations. Return a database object." (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 #:key (database (%package-database))) "Open database to store or read jobs and builds informations. Return a database object." (let* ((param (or database (format #f "dbname=~a host=~a" (getenv "CUIRASS_DATABASE") (getenv "CUIRASS_HOST")))) (db (connect-to-postgres-paramstring param))) (when (%create-database?) (match (db-schema-version db) (#f (db-init db)) (else (db-upgrade db)))) db)) (define (db-close db) "Close database object DB." (pg-conn-finish db)) (define (db-add-input spec-name input) (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) ") 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-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) ") 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-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) ") 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-worker-thread db (exec-query db "BEGIN TRANSACTION;") (exec-query/bind db "\ DELETE FROM Inputs WHERE specification=" name ";") (exec-query/bind db "\ DELETE FROM Specifications WHERE name=" name ";") (exec-query db "COMMIT;"))) (define (db-get-inputs spec-name) (with-db-worker-thread db (let loop ((rows (exec-query/bind db "SELECT * FROM Inputs WHERE specification=" spec-name "ORDER BY name;")) (inputs '())) (match rows (() (reverse 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? (string->number no-compile-p)))) inputs))))))) (define (db-get-specification name) "Retrieve a specification in the database with the given NAME." (expect-one-row (db-get-specifications name))) (define* (db-get-specifications #:optional name) (with-db-worker-thread db (let loop ((rows (if name (exec-query/bind db " SELECT * FROM Specifications WHERE name =" name ";") (exec-query db " SELECT * FROM Specifications ORDER BY name ASC;"))) (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) (succeeded 0) (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) (evaltime 0) timestamp) "Add a new evaluation for SPEC-NAME only if one of the CHECKOUTS is new. Otherwise, return #f." (define now (or timestamp (time-second (current-time time-utc)))) (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 ") RETURNING id;")) ((id) (string->number id)))) (new-checkouts (filter-map (cut db-add-checkout spec-name eval-id <>) checkouts))) (if (null? new-checkouts) (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))) (exec-query db "COMMIT;") eval-id))))) (define (db-abort-pending-evaluations) (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-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-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 ;; Cuirass' own extensions. (submitted -3) (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." (with-db-worker-thread db (match output ((name . path) (exec-query/bind db "\ INSERT INTO Outputs (derivation, name, path) VALUES (" 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-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)) ", " (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-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) ");"))) (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) (let ((new-outputs (filter-map (match-lambda ((name . path) (let ((drv (db-get-output path))) (and (not drv) path)))) outputs))) (not (null? new-outputs)))) (define (build-priority priority) (let ((spec-priority (assq-ref specification #:priority))) (+ (* spec-priority 10) priority))) (define (register job) (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)) (log (assq-ref job #:log)) (period (assq-ref job #:period)) (priority (or (assq-ref job #:priority) max-priority)) (max-silent (assq-ref job #:max-silent-time)) (timeout (assq-ref job #:timeout)) (outputs (assq-ref job #:outputs)) (cur-time (time-second (current-time time-utc)))) (and (new-outputs? outputs) (let ((build `((#:derivation . ,drv) (#:eval-id . ,eval-id) (#:job-name . ,job-name) (#:system . ,system) (#:nix-name . ,nix-name) ;; XXX: We'd leave LOG to #f (i.e., NULL) but that ;; currently violates the non-NULL constraint. (#:log . ,(or log "")) (#:status . ,(build-status scheduled)) (#:priority . ,(build-priority priority)) (#:max-silent . ,max-silent) (#:timeout . ,timeout) (#:outputs . ,outputs) (#:timestamp . ,cur-time) (#:starttime . 0) (#:stoptime . 0)))) (if period (let* ((spec (assq-ref specification #:name)) (time (db-get-time-since-previous-build job-name spec)) (add-build? (cond ((not time) #t) ((> time period) #t) (else #f)))) (and add-build? (db-add-build build))) (db-add-build build)))))) ;; 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-worker-thread db (log-message "Registering builds for evaluation ~a." eval-id) (exec-query db "BEGIN TRANSACTION;") (let ((derivations (filter-map register jobs))) (exec-query db "COMMIT;") derivations))) (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-worker-thread db (if (= status (build-status started)) (begin (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) (#: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 (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-worker-thread db (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." (define status-values `(("success" . ,(build-status succeeded)) ("failed" . ,(build-status failed)) ("failed-dependency" . ,(build-status failed-dependency)) ("failed-other" . ,(build-status failed-other)) ("canceled" . ,(build-status canceled)))) (let ((args (map (lambda (token) (match (string-split token #\:) (("system" system) `(#:system . ,system)) (("spec" spec) `(#:spec . ,spec)) (("status" 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 #\%) "") "%"))))) (string-tokenize query-string)))) ;; Normalize arguments (fold (lambda (key acc) (if (assq key acc) 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* ((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 ((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.id ELSE -Builds.id END DESC LIMIT :nr;")) (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. FILTERS is an assoc list whose possible keys are 'derivation | 'id | 'jobset | 'job | 'system | 'nr | 'order | 'status | 'evaluation." ;; XXX: Make sure that all filters are covered by an index. (define (filters->order filters) (lambda (inner) (match (assq 'order filters) (('order . 'build-id) "Builds.id ASC") (('order . 'finish-time) "stoptime DESC") (('order . 'finish-time+build-id) (if inner "CASE WHEN CAST(:borderlowid AS integer) IS NULL THEN stoptime ELSE -stoptime END 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.id ASC") (('order . 'priority+timestamp) "Builds.priority ASC, Builds.timestamp DESC") (_ "Builds.id DESC")))) ;; XXX: Make sure that all filters are covered by an index. (define (where-conditions filters) (define filter-name->sql `((id . "Builds.id = :id") (jobset . "Specifications.name = :jobset") (derivation . "Builds.derivation = :derivation") (job . "Builds.job_name = :job") (system . "Builds.system = :system") (worker . "Builds.worker = :worker") (evaluation . "Builds.evaluation = :evaluation") (status . ,(match (assq-ref filters 'status) (#f #f) ('done "Builds.status >= 0") ('scheduled "Builds.status = -2") ('started "Builds.status = -1") ('pending "Builds.status < 0") ('succeeded "Builds.status = 0") ('failed "Builds.status > 0"))) (border-low-time . "(((:borderlowtime, :borderlowid) < (Builds.stoptime, Builds.id)) OR :borderlowtime IS NULL OR :borderlowid IS NULL)") (border-high-time . "(((:borderhightime, :borderhighid) > (Builds.stoptime, Builds.id)) OR :borderhightime IS NULL OR :borderhighid IS NULL)"))) (filter string? (fold (lambda (filter-name where-condition-parts) (if (assq-ref filters filter-name) (cons (assq-ref filter-name->sql filter-name) where-condition-parts) where-condition-parts)) '() (map car filters)))) (define (format-outputs names paths) (map (lambda (name path) `(,name . ((#:path . ,path)))) (string-split names #\,) (string-split paths #\,))) (define (format-build-products ids types file-sizes checksums paths) (define (split list) (if list (string-split list #\,) '())) (map (lambda (id type file-size checksum path) `((#:id . ,(string->number id)) (#:type . ,type) (#:file-size . ,(string->number file-size)) (#:checksum . ,checksum) (#:path . ,path))) (split ids) (split types) (split file-sizes) (split checksums) (split paths))) (with-db-worker-thread db (let* ((order (filters->order filters)) (where (match (where-conditions filters) (() "") ((condition) (string-append "WHERE " condition "\n")) ((first-condition rest ...) (string-append "WHERE " first-condition "\n AND " (string-join rest " AND "))))) (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.id 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) 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))) (params (map (match-lambda ((name . value) (cons (symbol->keyword (or (assq-ref '((border-low-time . borderlowtime) (border-high-time . borderhightime) (border-low-id . borderlowid) (border-high-id . borderhighid)) name) name)) (match name ('nr (or value -1)) ('order #f) ; Doesn't need binding. ('status #f) ; Doesn't need binding. (else 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." (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* ((query "\ SELECT Events.id, Events.type, Events.timestamp, Events.event_json FROM Events 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;") (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-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)) (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 (exec-query/bind db "SELECT revision, input, directory FROM Checkouts WHERE evaluation =" eval-id ";")) (checkouts '())) (match rows (() (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 (exec-query/bind db "SELECT id, specification, status, timestamp, checkouttime, evaltime FROM Evaluations WHERE id = " id) (() #f) ((evaluation) (parse-evaluation evaluation))))) (define (db-get-evaluations limit) (with-db-worker-thread db (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)) ((evaluation . rest) (loop rest (cons (parse-evaluation evaluation) evaluations))))))) (define (db-get-evaluations-build-summary spec limit border-low border-high) (with-db-worker-thread db (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 (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, 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 (match (expect-one-row (exec-query/bind db " SELECT MIN(id) FROM Evaluations 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 (match (expect-one-row (exec-query/bind db " SELECT MAX(id) FROM Evaluations WHERE specification=" spec)) ((max) (and max (string->number max)))))) (define (db-get-evaluation-summary id) (with-db-worker-thread db (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 = Evaluations.id WHERE Evaluations.id = " id "GROUP BY Evaluations.id ORDER BY Evaluations.id ASC;")) ((id status timestamp checkouttime evaltime total succeeded failed scheduled) `((#:id . ,(string->number id)) (#:status . ,(string->number status)) (#:total . ,(or (string->number total) 0)) (#:timestamp . ,(string->number timestamp)) (#:checkouttime . ,(string->number checkouttime)) (#:evaltime . ,(string->number evaltime)) (#:succeeded . ,(or (string->number succeeded) 0)) (#:failed . ,(or (string->number failed) 0)) (#:scheduled . ,(or (string->number scheduled) 0)))) (else #f)))) (define (db-get-builds-query-min filters) "Return the smallest build row identifier matching QUERY." (with-db-worker-thread db (let* ((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 (Builds.status = :status OR :status IS NULL) AND (Specifications.name = :spec OR :spec IS NULL) AND (Builds.system = :system OR :system IS NULL);") (params (query->bind-arguments filters))) (match (expect-one-row (exec-query/bind-params db query params)) ((min) (and min (list (string->number min)))))))) (define (db-get-builds-query-max filters) "Return the largest build row identifier matching QUERY." (with-db-worker-thread db (let* ((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 (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 ((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 ((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 (match (expect-one-row (exec-query/bind db " SELECT specification FROM Evaluations 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 (match (expect-one-row (exec-query/bind db " SELECT path FROM BuildProducts WHERE id = " id)) ((path) path) (else #f)))) (define (db-add-worker worker) "Insert WORKER into Worker table." (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) ");"))) (define (db-get-workers) "Return the workers in Workers table." (with-db-worker-thread 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) . rest) (loop rest (cons (worker (name name) (address address) (systems (string-split systems #\,)) (last-seen last-seen)) workers))))))) (define (db-clear-workers) "Remove all workers from Workers table." (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: