diff options
Diffstat (limited to 'src/cuirass/database.scm')
| -rw-r--r-- | src/cuirass/database.scm | 142 |
1 files changed, 132 insertions, 10 deletions
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." |