From 1311893e2f5b6e1e16c474d018901d4ff4a31234 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 21 Oct 2019 22:43:16 +0100 Subject: Support publishing build events Add a table to store events, which have a type and a JSON blob. These can be used to record changes, this commit inserts events when new builds are created, and when the status of builds change. The EventsOutbox table is then used to track when events have been sent out. This is done through the new cuirass-send-events script. * Makefile.am (bin_SCRIPTS): Add bin/cuirass-send-events. (dist_pkgmodule_DATA): Add src/cuirass/send-events.scm. (dist_sql_DATA): Add src/sql/upgrade-5.sql. (EXTRA_DIST): bin/cuirass-send-events.in. (bin/cuirass-send-events): New rule. * bin/cuirass-send-events.in: New file. * src/cuirass/send-events.scm: New file. * src/sql/upgrade-5.sql: New file. * src/cuirass/base.scm (build-packages): Call db-add-event after db-add-build. * src/cuirass/database.scm (changes-count): New procedure. (db-update-build-status!): Call db-add-event after updating the build status. (db-add-event): New procedure. (db-get-events-in-outbox): New procedure. (db-delete-events-from-output-with-ids-<=-to): New procedure. * src/cuirass/http.scm (handle-events-request): New procedure. (url-handler): Handle /api/build-events requests. * src/schema.sql (Events, EventOutbox): New tables. --- src/cuirass/database.scm | 142 +++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 132 insertions(+), 10 deletions(-) (limited to 'src/cuirass/database.scm') diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index 523165d..8cb7465 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -54,6 +54,10 @@ db-get-builds-max db-get-builds-query-min db-get-builds-query-max + db-add-event + db-get-events + db-get-events-in-outbox + db-delete-events-from-outbox-with-ids-<=-to db-get-evaluations db-get-evaluations-build-summary db-get-evaluations-id-min @@ -270,6 +274,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." @@ -521,23 +531,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 + ";")) + (unless (eq? (changes-count db) 0) + (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 +770,99 @@ 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) + (with-db-critical-section db + (sqlite-exec db "\ +INSERT INTO Events (type, timestamp, event_json) VALUES (" + (symbol->string type) ", " + timestamp ", " + (object->json-string details) + ");") + (let ((event-id (last-insert-rowid db))) + (sqlite-exec db "\ +INSERT INTO EventsOutbox (event_id) VALUES (" event-id ");")) + #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 +CASE WHEN :borderlowtime IS NULL + OR :borderlowid IS NULL THEN Events.timestamp + ELSE -Events.timestamp +END DESC, +CASE WHEN :borderlowtime IS NULL + OR :borderlowid IS NULL THEN Events.id + ELSE -Events.id +END DESC +LIMIT :nr;") + (stmt (sqlite-prepare db stmt-text #:cache? #t))) + (sqlite-bind-arguments + stmt + #:type (symbol->string (assq-ref filters 'type)) + #: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)) + (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-get-events-in-outbox limit) + (with-db-critical-section db + (let loop ((rows (sqlite-exec + db "\ +SELECT id, type, timestamp, event_json +FROM Events +WHERE id IN ( + SELECT event_id FROM EventsOutbox +) +ORDER BY id DESC +LIMIT " limit ";")) + (events '())) + (match rows + (() 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-from-outbox-with-ids-<=-to id) + (with-db-critical-section db + (sqlite-exec + db + "DELETE FROM EventsOutbox WHERE event_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." -- cgit v1.2.3