[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Support publishing build events
|
From: |
Christopher Baines |
|
Subject: |
[PATCH] Support publishing build events |
|
Date: |
Sun, 20 Oct 2019 08:49:52 +0100 |
---
Makefile.am | 8 ++-
bin/cuirass-send-events.in | 90 ++++++++++++++++++++++++
src/cuirass/base.scm | 6 +-
src/cuirass/database.scm | 135 +++++++++++++++++++++++++++++++++---
src/cuirass/http.scm | 16 +++++
src/cuirass/send-events.scm | 39 +++++++++++
src/schema.sql | 13 ++++
src/sql/upgrade-5.sql | 16 +++++
8 files changed, 310 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..4ebf6ee
--- /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 "Run build jobs from internal database.
+
+ -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-build-events exit-channel
+ (lambda ()
+ (while #t
+ (send-build-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..8cd48d8 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -624,7 +624,11 @@ started)."
(#:timestamp . ,cur-time)
(#:starttime . 0)
(#:stoptime . 0))))
- (db-add-build build))))
+ (if (db-add-build build)
+ (begin
+ (db-add-build-event drv cur-time "scheduled")
+ drv)
+ #f))))
(define derivations
(filter-map register jobs))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 8db5411..fb54ed6 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-build-event
+ db-get-build-events
+ db-get-build-events-in-outbox
+ db-delete-build-events-from-outbox-with-ids-<=-to
db-get-evaluations
db-get-evaluations-build-summary
db-get-evaluations-id-min
@@ -269,6 +273,10 @@ database object."
(vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
0))
+(define (changes-count db)
+ (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."
@@ -512,21 +520,36 @@ log file for DRV."
(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-build-event drv
+ now
+ "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-build-event
+ drv
+ now
+ (cond
+ ((= status (build-status succeeded)) "succeeded")
+ ((= status (build-status failed)) "failed")
+ ((= status (build-status failed-dependency)) "failed
(dependency)")
+ ((= status (build-status failed-other)) "failed (other)")
+ ((= status (build-status canceled)) "canceled"))))))))
(define (db-get-outputs derivation)
"Retrieve the OUTPUTS of the build identified by DERIVATION in the
@@ -730,6 +753,98 @@ 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-build-event derivation timestamp event)
+ (with-db-critical-section db
+ (sqlite-exec db "\
+INSERT INTO BuildEvents (derivation, timestamp, event) VALUES ("
+ derivation ", " timestamp ", " event ");")
+ (let ((build-event-id (last-insert-rowid db)))
+ (sqlite-exec db "\
+INSERT INTO BuildEventsOutbox (build_event_id) VALUES (" build-event-id ");"))
+ #t))
+
+(define (db-get-build-events filters)
+ (with-db-critical-section db
+ (let* ((stmt-text "\
+SELECT BuildEvents.id,
+ BuildEvents.derivation,
+ BuildEvents.timestamp,
+ BuildEvents.event
+FROM BuildEvents
+WHERE (:derivation IS NULL OR (:derivation = BuildEvents.derivation))
+ AND (:event IS NULL OR :event = BuildEvents.event)
+ AND (:borderlowtime IS NULL OR
+ :borderlowid IS NULL OR
+ ((:borderlowtime, :borderlowid) <
+ (BuildEvents.timestamp, BuildEvents.id)))
+ AND (:borderhightime IS NULL OR
+ :borderhighid IS NULL OR
+ ((:borderhightime, :borderhighid) >
+ (BuildEvents.timestamp, BuildEvents.id)))
+ORDER BY
+CASE WHEN :borderlowtime IS NULL
+ OR :borderlowid IS NULL THEN BuildEvents.timestamp
+ ELSE -BuildEvents.timestamp
+END DESC,
+CASE WHEN :borderlowtime IS NULL
+ OR :borderlowid IS NULL THEN BuildEvents.id
+ ELSE -BuildEvents.id
+END DESC
+LIMIT :nr;")
+ (stmt (sqlite-prepare db stmt-text #:cache? #t)))
+ (sqlite-bind-arguments
+ stmt
+ #:derivation (assq-ref filters 'derivation)
+ #:event (assq-ref filters 'event)
+ #: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))
+ (build-events '()))
+ (match rows
+ (() (reverse build-events))
+ ((#(id derivation timestamp event) . rest)
+ (loop rest
+ (cons `((#:id . ,id)
+ (#:derivation . ,derivation)
+ (#:timestamp . ,timestamp)
+ (#:event . ,event))
+ build-events))))))))
+
+(define (db-get-build-events-in-outbox limit)
+ (with-db-critical-section db
+ (let loop ((rows (sqlite-exec
+ db "\
+SELECT id, derivation, timestamp, event
+FROM BuildEvents
+WHERE id IN (
+ SELECT build_event_id FROM BuildEventsOutbox
+)
+ORDER BY id DESC
+LIMIT " limit ";"))
+ (build-events '()))
+ (match rows
+ (() build-events)
+ ((#(id derivation timestamp event)
+ . rest)
+ (loop rest
+ (cons `((#:id . ,id)
+ (#:derivation . ,derivation)
+ (#:timestamp . ,timestamp)
+ (#:event . ,event))
+ build-events)))))))
+
+(define (db-delete-build-events-from-outbox-with-ids-<=-to id)
+ (with-db-critical-section db
+ (sqlite-exec
+ db
+ "DELETE FROM BuildEventsOutbox WHERE build_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..f1b1d30 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -134,6 +134,12 @@ Hydra format."
(db-get-builds-by-search filters))))
(list->vector (map build->hydra-build builds))))
+(define (handle-build-events-request filters)
+ "Retrieve all build events matched by FILTERS in the database."
+ (let ((build-events (with-time-logging "build events request"
+ (db-get-build-events filters))))
+ (list->vector build-events)))
+
(define (request-parameters request)
"Parse the REQUEST query parameters and return them under the form
'((parameter . value) ...)."
@@ -317,6 +323,16 @@ 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?
+ ;; Limit results to builds that are "done".
+ (respond-json
+ (object->json-string
+ (handle-build-events-request 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..db02a9a
--- /dev/null
+++ b/src/cuirass/send-events.scm
@@ -0,0 +1,39 @@
+;;;; 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-build-events))
+
+(define* (send-build-events target-url
+ #:key (batch-limit 100))
+ (let ((events-to-send
+ (db-get-build-events-in-outbox batch-limit)))
+ (unless (null? events-to-send)
+ (http-post target-url
+ #:body (object->json-string
+ `((events . ,(list->vector events-to-send)))))
+ (db-delete-build-events-from-outbox-with-ids-<=-to
+ (peek (assq-ref (last events-to-send) #:id)))
+ (simple-format #t "Sent ~A events\n" (length events-to-send)))))
diff --git a/src/schema.sql b/src/schema.sql
index a9e4a6a..7137e83 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -64,6 +64,19 @@ CREATE TABLE Builds (
FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
);
+CREATE TABLE BuildEvents (
+ id INTEGER PRIMARY KEY,
+ derivation TEXT NOT NULL,
+ timestamp INTEGER NOT NULL,
+ event TEXT NOT NULL,
+ FOREIGN KEY (derivation) REFERENCES Builds (derivation)
+);
+
+CREATE TABLE BuildEventsOutbox (
+ build_event_id INTEGER NOT NULL,
+ FOREIGN KEY (build_event_id) REFERENCES BuildEvents (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..3da688a
--- /dev/null
+++ b/src/sql/upgrade-5.sql
@@ -0,0 +1,16 @@
+BEGIN TRANSACTION;
+
+CREATE TABLE BuildEvents (
+ id INTEGER PRIMARY KEY,
+ derivation TEXT NOT NULL,
+ timestamp INTEGER NOT NULL,
+ event TEXT NOT NULL,
+ FOREIGN KEY (derivation) REFERENCES Builds (derivation)
+);
+
+CREATE TABLE BuildEventsOutbox (
+ build_event_id INTEGER NOT NULL,
+ FOREIGN KEY (build_event_id) REFERENCES BuildEvents (id)
+);
+
+COMMIT;
--
2.23.0