diff --git a/.gitignore b/.gitignore
index 3bc363b..beabf29 100644
--- a/.gitignore
+++ b/.gitignore
@@ -10,6 +10,7 @@
/aclocal.m4
/autom4te.cache/
/bin/cuirass
+/bin/cuirass-send-events
/bin/evaluate
/build-aux/config.guess
/build-aux/config.sub
diff --git a/Makefile.am b/Makefile.am
index 7cea2ff..5448420 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -21,7 +21,7 @@
# You should have received a copy of the GNU General Public License
# along with Cuirass. If not, see .
-bin_SCRIPTS = bin/cuirass bin/evaluate
+bin_SCRIPTS = bin/cuirass bin/cuirass-send-events bin/evaluate
noinst_SCRIPTS = pre-inst-env
guilesitedir = $(datarootdir)/guile/site/@GUILE_EFFECTIVE_VERSION@
@@ -45,6 +45,7 @@ dist_pkgmodule_DATA = \
src/cuirass/database.scm \
src/cuirass/http.scm \
src/cuirass/logging.scm \
+ src/cuirass/send-events.scm \
src/cuirass/ui.scm \
src/cuirass/utils.scm \
src/cuirass/templates.scm
@@ -68,7 +69,8 @@ dist_sql_DATA = \
src/sql/upgrade-1.sql \
src/sql/upgrade-2.sql \
src/sql/upgrade-3.sql \
- src/sql/upgrade-4.sql
+ src/sql/upgrade-4.sql \
+ src/sql/upgrade-5.sql
dist_css_DATA = \
src/static/css/bootstrap.css \
@@ -143,6 +145,7 @@ sql-check: src/schema.sql
EXTRA_DIST = \
.dir-locals.el \
bin/cuirass.in \
+ bin/cuirass-send-events.in \
bin/evaluate.in \
bootstrap \
build-aux/guix.scm \
@@ -202,6 +205,7 @@ generate_file = \
# These files depend on Makefile so they are rebuilt if $(VERSION),
# $(datadir) or other do_subst'ituted variables change.
bin/cuirass: $(srcdir)/bin/cuirass.in
+bin/cuirass-send-events: $(srcdir)/bin/cuirass-send-events.in
bin/evaluate: $(srcdir)/bin/evaluate.in
$(bin_SCRIPTS): Makefile
$(generate_file); chmod +x $@
diff --git a/bin/cuirass-send-events.in b/bin/cuirass-send-events.in
new file mode 100644
index 0000000..2373e46
--- /dev/null
+++ b/bin/cuirass-send-events.in
@@ -0,0 +1,80 @@
+#!/bin/sh
+# -*- scheme -*-
+# @configure_input@
+#GUILE_LOAD_PATH="@PACKAGE_LOAD_PATH@${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
+#GUILE_LOAD_COMPILED_PATH="@PACKAGE_LOAD_COMPILED_PATH@${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
+exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
+!#
+;;;; cuirass -- continuous integration tool
+;;; Copyright © 2016 Mathieu Lirzin
+;;; Copyright © 2017 Mathieu Othacehe
+;;; Copyright © 2018 Ludovic Courtès
+;;; Copyright © 2018 Clément Lassieur
+;;; Copyright © 2019 Christopher Baines
+;;;
+;;; 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 .
+
+(use-modules (cuirass)
+ (cuirass ui)
+ (cuirass logging)
+ (cuirass utils)
+ (cuirass send-events)
+ (guix ui)
+ (fibers)
+ (fibers channels)
+ (srfi srfi-19)
+ (ice-9 getopt-long))
+
+(define (show-help)
+ (format #t "Usage: ~a [OPTIONS]~%" (%program-name))
+ (display "Send events to the target URL.
+
+ -T --target-url=URL Send events to URL.
+ -D --database=DB Use DB to store build results.
+ -h, --help Display this help message")
+ (newline)
+ (show-package-information))
+
+(define %options
+ '((target-url (single-char #\T) (value #t))
+ (database (single-char #\D) (value #t))
+ (help (single-char #\h) (value #f))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define* (main #:optional (args (command-line)))
+
+ ;; Always have stdout/stderr line-buffered.
+ (setvbuf (current-output-port) 'line)
+ (setvbuf (current-error-port) 'line)
+
+ (let ((opts (getopt-long args %options)))
+ (parameterize
+ ((%program-name (car args))
+ (%package-database (option-ref opts 'database (%package-database)))
+ (%package-cachedir
+ (option-ref opts 'cache-directory (%package-cachedir))))
+ (cond
+ ((option-ref opts 'help #f)
+ (show-help)
+ (exit 0))
+ (else
+ (while #t
+ (send-events (option-ref opts 'target-url #f))
+ (sleep 5)))))))
diff --git a/bin/cuirass.in b/bin/cuirass.in
index 81ce9fe..fbc7c3c 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -54,6 +54,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
--listen=HOST Listen on the network interface for HOST
-I, --interval=N Wait N seconds between each poll
--use-substitutes Allow usage of pre-built substitutes
+ --record-events Record events for distribution
--threads=N Use up to N kernel threads
-V, --version Display version
-h, --help Display this help message")
@@ -72,6 +73,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(use-substitutes (value #f))
(threads (value #t))
(fallback (value #f))
+ (record-events (value #f))
(ttl (value #t))
(version (single-char #\V) (value #f))
(help (single-char #\h) (value #f))))
@@ -95,6 +97,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(option-ref opts 'cache-directory (%package-cachedir)))
(%use-substitutes? (option-ref opts 'use-substitutes #f))
(%fallback? (option-ref opts 'fallback #f))
+ (%record-events? (option-ref opts 'record-events #f))
(%gc-root-ttl
(time-second (string->duration (option-ref opts 'ttl "30d")))))
(cond
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
+;;;
+;;; 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 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;