diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/cuirass/database.scm | 119 | ||||
| -rw-r--r-- | src/cuirass/send-events.scm | 91 | ||||
| -rw-r--r-- | src/schema.sql | 7 | ||||
| -rw-r--r-- | src/sql/upgrade-5.sql | 15 |
4 files changed, 221 insertions, 11 deletions
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index 523165d..9cd2e8f 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -54,6 +54,9 @@ 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 @@ -67,6 +70,7 @@ %package-database %package-schema-file %db-channel + %record-events? ;; Macros. with-db-critical-section with-database)) @@ -164,6 +168,9 @@ specified." (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 @@ -270,6 +277,12 @@ database object." (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." @@ -504,7 +517,15 @@ VALUES (" (if (null? new-outputs) (begin (sqlite-exec db "ROLLBACK;") #f) - (begin (sqlite-exec db "COMMIT;") + (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 @@ -521,23 +542,42 @@ 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)) - (sqlite-exec db "UPDATE Builds SET starttime=" now ", status=" - status "WHERE derivation=" drv ";") + (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. - (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 - ";"))))) + (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-outputs derivation) "Retrieve the OUTPUTS of the build identified by DERIVATION in the @@ -741,6 +781,63 @@ ORDER BY ~a, rowid ASC;" order)) (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." diff --git a/src/cuirass/send-events.scm b/src/cuirass/send-events.scm new file mode 100644 index 0000000..3ff5295 --- /dev/null +++ b/src/cuirass/send-events.scm @@ -0,0 +1,91 @@ +;;;; http.scm -- HTTP API +;;; Copyright © 2019 Christopher Baines <mail@cbaines.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 send-events) + #:use-module (cuirass config) + #:use-module (cuirass database) + #:use-module (cuirass utils) + #:use-module (cuirass logging) + #:use-module (web client) + #:use-module (web response) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 textual-ports) + #:export (send-events)) + +(define* (send-events target-url + #:key (batch-limit 100)) + "Send up to BATCH-LIMIT events to TARGET-URL" + (with-exponential-backoff-upon-error + (lambda () + (let ((events-to-send + (db-get-events `((nr . ,batch-limit))))) + (unless (null? events-to-send) + (let ((body + (object->json-string + `((items + . ,(list->vector + (map (lambda (event) + (let ((event-json + (json-string->scm + (assq-ref event #:event_json)))) + `((id . ,(assq-ref event #:id)) + (type . ,(assq-ref event #:type)) + (timestamp . ,(assq-ref event #:timestamp)) + ,@event-json))) + events-to-send))))))) + (let*-values + (((response body) + (http-post target-url + #:body body + ;; Guile doesn't treat JSON as text, so decode the + ;; body manually + #:decode-body? #f)) + ((code) + (response-code response))) + (unless (and (>= code 200) + (< code 300)) + (throw + 'request-failure + (simple-format #f "code: ~A response: ~A" + code + (utf8->string body)))))) + (db-delete-events-with-ids-<=-to + (assq-ref (last events-to-send) #:id)) + (simple-format #t "Sent ~A events\n" (length events-to-send))))))) + +(define* (with-exponential-backoff-upon-error thunk #:key (retry-number 1)) + "Call THUNK and catch exceptions, retrying after a number of seconds that +increases exponentially." + (catch + #t + thunk + (lambda (key . args) + (simple-format (current-error-port) + "Failure sending events (try ~A)\n" + retry-number) + (print-exception (current-error-port) #f key args) + (let ((sleep-length (integer-expt 2 retry-number))) + (simple-format (current-error-port) + "\nWaiting for ~A seconds\n" + sleep-length) + (sleep sleep-length) + (with-exponential-backoff-upon-error thunk #:retry-number + (+ retry-number 1)))))) diff --git a/src/schema.sql b/src/schema.sql index a9e4a6a..cd67530 100644 --- a/src/schema.sql +++ b/src/schema.sql @@ -64,6 +64,13 @@ CREATE TABLE Builds ( FOREIGN KEY (evaluation) REFERENCES Evaluations (id) ); +CREATE TABLE Events ( + id INTEGER PRIMARY KEY, + type TEXT NOT NULL, + timestamp INTEGER NOT NULL, + event_json TEXT NOT NULL +); + -- Create indexes to speed up common queries, in particular those -- corresponding to /api/latestbuilds and /api/queue HTTP requests. CREATE INDEX Builds_index ON Builds(job_name, system, status ASC, timestamp ASC, derivation, evaluation, stoptime DESC); diff --git a/src/sql/upgrade-5.sql b/src/sql/upgrade-5.sql new file mode 100644 index 0000000..8f30bde --- /dev/null +++ b/src/sql/upgrade-5.sql @@ -0,0 +1,15 @@ +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; |