[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 1/2] Support publishing build events
|
From: |
Christopher Baines |
|
Subject: |
[PATCH 1/2] Support publishing build events |
|
Date: |
Mon, 28 Oct 2019 08:10:25 +0000 |
---
Makefile.am | 8 +-
bin/cuirass-send-events.in | 90 +++++++++++++++++++++++
src/cuirass/base.scm | 9 ++-
src/cuirass/database.scm | 142 +++++++++++++++++++++++++++++++++---
src/cuirass/http.scm | 24 ++++++
src/cuirass/send-events.scm | 69 ++++++++++++++++++
src/schema.sql | 12 +++
src/sql/upgrade-5.sql | 15 ++++
8 files changed, 356 insertions(+), 13 deletions(-)
create mode 100644 bin/cuirass-send-events.in
create mode 100644 src/cuirass/send-events.scm
create mode 100644 src/sql/upgrade-5.sql
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 <http://www.gnu.org/licenses/>.
-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..5f2e678
--- /dev/null
+++ b/bin/cuirass-send-events.in
@@ -0,0 +1,90 @@
+#!/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 <address@hidden>
+;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
+;;; Copyright © 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2018 Clément Lassieur <address@hidden>
+;;; Copyright © 2019 Christopher Baines <address@hidden>
+;;;
+;;; 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/>.
+
+(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
+ (run-fibers
+ (lambda ()
+ (with-database
+ (let ((exit-channel (make-channel)))
+ (spawn-fiber
+ (essential-task
+ 'send-events exit-channel
+ (lambda ()
+ (while #t
+ (send-events (option-ref opts 'target-url #f))
+ (sleep 5)))))
+ (primitive-exit (get-message exit-channel)))))
+ #:drain? #f))))))
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 2c568c9..fd10e35 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -624,7 +624,14 @@ started)."
(#:timestamp . ,cur-time)
(#:starttime . 0)
(#:stoptime . 0))))
- (db-add-build build))))
+ (if (db-add-build build)
+ (begin
+ (db-add-event 'build
+ cur-time
+ `((#:derivation . ,drv)
+ (#:event . scheduled)))
+ drv)
+ #f))))
(define derivations
(filter-map register jobs))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 8db5411..83c0c5a 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -53,6 +53,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
@@ -269,6 +273,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."
@@ -510,23 +520,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
@@ -730,6 +759,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."
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index b6a4358..35e3d7f 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -134,6 +134,21 @@ Hydra format."
(db-get-builds-by-search filters))))
(list->vector (map build->hydra-build builds))))
+(define (handle-events-request type filters)
+ "Retrieve all events of TYPE matched by FILTERS in the database."
+ (let ((events (with-time-logging
+ (simple-format #f "~A events request" type)
+ (db-get-events
+ `((type . ,type)
+ ,@filters)))))
+ `((items . ,(list->vector
+ (map (lambda (event)
+ `((id . ,(assq-ref event #:id))
+ (timestamp . ,(assq-ref event #:timestamp))
+ ,@(json-string->scm
+ (assq-ref event #:event_json))))
+ events))))))
+
(define (request-parameters request)
"Parse the REQUEST query parameters and return them under the form
'((parameter . value) ...)."
@@ -317,6 +332,15 @@ Hydra format."
,@params
(order . status+submission-time)))))
(respond-json-with-error 500 "Parameter not defined!"))))
+ (("api" "build-events")
+ (let* ((params (request-parameters request))
+ ;; 'nr parameter is mandatory to limit query size.
+ (valid-params? (assq-ref params 'nr)))
+ (if valid-params?
+ (respond-json
+ (object->json-string
+ (handle-events-request 'build params)))
+ (respond-json-with-error 500 "Parameter not defined!"))))
('()
(respond-html (html-page
"Cuirass"
diff --git a/src/cuirass/send-events.scm b/src/cuirass/send-events.scm
new file mode 100644
index 0000000..fc78eaa
--- /dev/null
+++ b/src/cuirass/send-events.scm
@@ -0,0 +1,69 @@
+;;;; http.scm -- HTTP API
+;;; Copyright © 2019 Christopher Baines <address@hidden>
+;;;
+;;; 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 (json)
+ #:use-module (srfi srfi-1)
+ #: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-in-outbox batch-limit)))
+ (unless (null? events-to-send)
+ (http-post target-url
+ #:body
+ (object->json-string
+ `((items
+ . ,(list->vector
+ (map (lambda (event)
+ `((id . ,(assq-ref event #:id))
+ (timestamp . ,(assq-ref event
#:timestamp))
+ ,@(json-string->scm
+ (assq-ref event #:event_json))))
+ events-to-send))))))
+ (db-delete-events-from-outbox-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 f #:key (retry-number 1))
+ "Run F and catch exceptions, retrying after a number of seconds that
+increases exponentially."
+ (catch
+ #t
+ f
+ (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 f #:retry-number
+ (+ retry-number 1))))))
diff --git a/src/schema.sql b/src/schema.sql
index a9e4a6a..b84b231 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -64,6 +64,18 @@ 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 TABLE EventsOutbox (
+ event_id INTEGER NOT NULL,
+ FOREIGN KEY (event_id) REFERENCES Events (id)
+);
+
-- 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;
--
2.23.0