* [PATCH] Support publishing build events
2019-10-20 7:41 Getting build information in to the Guix Data Service (draft patch) Christopher Baines
@ 2019-10-20 7:49 ` Christopher Baines via Development of GNU Guix and the GNU System distribution.
2019-10-21 9:31 ` Mathieu Othacehe
2019-10-23 14:39 ` Getting build information in to the Guix Data Service (draft patch) Ludovic Courtès
` (2 subsequent siblings)
3 siblings, 1 reply; 36+ messages in thread
From: Christopher Baines via Development of GNU Guix and the GNU System distribution. @ 2019-10-20 7:49 UTC (permalink / raw)
To: guix-devel
---
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 <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; 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))))
+
+\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 <mail@cbaines.net>
+;;;
+;;; 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
^ permalink raw reply related [flat|nested] 36+ messages in thread* Re: [PATCH] Support publishing build events
2019-10-20 7:49 ` [PATCH] Support publishing build events Christopher Baines via Development of GNU Guix and the GNU System distribution.
@ 2019-10-21 9:31 ` Mathieu Othacehe
2019-10-21 21:47 ` Christopher Baines
0 siblings, 1 reply; 36+ messages in thread
From: Mathieu Othacehe @ 2019-10-21 9:31 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel
Hello Christopher,
> +(define* (main #:optional (args (command-line)))
> +
> + ;; Always have stdout/stderr line-buffered.
> + (setvbuf (current-output-port) 'line)
> + (setvbuf (current-error-port) 'line)
I must admit I've not been following very closely your work on Guix Data
Service. However, I must admit that being able to have an overview of
the status of all packages of a given branch is something that would
really be nice.
On this patch more specifically, is this really necessary to create a
separate process? Could the task of pushing events be done in the main
cuirass binary, periodically in a separate thread/fiber?
Thanks,
Mathieu
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH] Support publishing build events
2019-10-21 9:31 ` Mathieu Othacehe
@ 2019-10-21 21:47 ` Christopher Baines
0 siblings, 0 replies; 36+ messages in thread
From: Christopher Baines @ 2019-10-21 21:47 UTC (permalink / raw)
To: guix-devel
[-- Attachment #1: Type: text/plain, Size: 1297 bytes --]
Mathieu Othacehe <m.othacehe@gmail.com> writes:
> Hello Christopher,
>
>> +(define* (main #:optional (args (command-line)))
>> +
>> + ;; Always have stdout/stderr line-buffered.
>> + (setvbuf (current-output-port) 'line)
>> + (setvbuf (current-error-port) 'line)
>
> I must admit I've not been following very closely your work on Guix Data
> Service. However, I must admit that being able to have an overview of
> the status of all packages of a given branch is something that would
> really be nice.
>
> On this patch more specifically, is this really necessary to create a
> separate process? Could the task of pushing events be done in the main
> cuirass binary, periodically in a separate thread/fiber?
No, I think it would be possible to do this as part of the cuirass
process that takes care of builds, and that even might have some
advantages as you'd potentially able to avoid some delays associated
with polling.
However, I don't really understand fibers in Guile yet, so I didn't have
a good idea of how to add new functionality in to the mix of the
existing process. So I went for a simpler implementation. I'm quite
happy to work on changing it, but it would be good to have some input
from someone that has a better idea of the Cuirass internals.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: Getting build information in to the Guix Data Service (draft patch)
2019-10-20 7:41 Getting build information in to the Guix Data Service (draft patch) Christopher Baines
2019-10-20 7:49 ` [PATCH] Support publishing build events Christopher Baines via Development of GNU Guix and the GNU System distribution.
@ 2019-10-23 14:39 ` Ludovic Courtès
2019-10-23 23:32 ` Christopher Baines
2019-12-28 19:05 ` [PATCH v3 1/2] Support publishing build events Christopher Baines
2019-12-28 19:54 ` [PATCH v4 1/2] Support publishing build events Christopher Baines
3 siblings, 1 reply; 36+ messages in thread
From: Ludovic Courtès @ 2019-10-23 14:39 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel
Hi Chris,
Christopher Baines <mail@cbaines.net> skribis:
> This is what I've currently tried to implement. The patch I'll send adds
> two new tables to the Cuirass database, one to store events relating to
> builds (like it being scheduled, or succeeding), and another to store
> the ids of events which haven't yet been sent out. The code relating to
> builds is then adjusted to populate these tables, and a new binary is
> added to query for unsent events, and then send them out to some URL.
So every event only has two states (sent/unsent), which means we assume
there’s a single subscriber, right? (Not a limitation because we could
use a dedicated hub on top of that like you write, but I want to make
sure I understand correctly.)
> In the short term, the destination would be the Guix Data Service. In
> the longer term, I think it would be better to send events to a WebSub
> style hub, which then would distribute the events to one or more
> subscribers.
That sounds great.
> Now that I've actually dug in to the Cuirass database to write this, I'm
> more aware of the data model it uses, and the limitations this places on
> what information it can provide. I'd assumed for a while that Cuirass
> not showing complete information for each evaluation was a UI thing, but
> as I understand it, the database only contains a record of what
> derivations each evaluation has that no other evaluation in the
> currently in the database has.
>
> Maybe that's something to improve on within Cuirass, but at least by
> getting the build information in to the Guix Data Service, it will be
> feasible to look at the status of derivations for a revision of Guix (as
> the Guix Data Service knows all the derivations associated with a
> specific revision).
Yeah, though perhaps we should fix that in Cuirass itself, too…
> ---
> 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
[...]
> +(define (show-help)
> + (format #t "Usage: ~a [OPTIONS]~%" (%program-name))
> + (display "Run build jobs from internal database.
Not correct. :-)
> +(define (changes-count db)
> + (vector-ref (car (sqlite-exec db "SELECT changes();"))
> + 0))
Not sure what that does, could you add a docstring?
> +(define* (send-build-events target-url
> + #:key (batch-limit 100))
Docstring! :-)
> +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)
> +);
This assumes build events are necessarily related to a derivation,
though one could imagine events having to do with evaluations, jobsets,
etc.
Should ‘BuildEvents’ be more generic and have ‘event’ be an sexp or JSON
string that could describe any kind of event?
If we did that, we could keep ‘derivation’ but remove “NOT NULL” so that
non-derivation events can exist but we can still query
derivation-related events quickly. Does that make sense?
> +CREATE TABLE BuildEventsOutbox (
> + build_event_id INTEGER NOT NULL,
> + FOREIGN KEY (build_event_id) REFERENCES BuildEvents (id)
> +);
These are events that have not yet been sent, right?
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: Getting build information in to the Guix Data Service (draft patch)
2019-10-23 14:39 ` Getting build information in to the Guix Data Service (draft patch) Ludovic Courtès
@ 2019-10-23 23:32 ` Christopher Baines
2019-10-28 8:10 ` [PATCH 1/2] Support publishing build events Christopher Baines
2019-10-28 8:33 ` Getting build information in to the Guix Data Service (draft patch) Christopher Baines
0 siblings, 2 replies; 36+ messages in thread
From: Christopher Baines @ 2019-10-23 23:32 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 3097 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Christopher Baines <mail@cbaines.net> skribis:
>
>> This is what I've currently tried to implement. The patch I'll send adds
>> two new tables to the Cuirass database, one to store events relating to
>> builds (like it being scheduled, or succeeding), and another to store
>> the ids of events which haven't yet been sent out. The code relating to
>> builds is then adjusted to populate these tables, and a new binary is
>> added to query for unsent events, and then send them out to some URL.
>
> So every event only has two states (sent/unsent), which means we assume
> there’s a single subscriber, right? (Not a limitation because we could
> use a dedicated hub on top of that like you write, but I want to make
> sure I understand correctly.)
Yep, and that state is tracked through the BuildEventsOutbox table. An
entry in there means the event hasn't been sent out yet.
>> In the short term, the destination would be the Guix Data Service. In
>> the longer term, I think it would be better to send events to a WebSub
>> style hub, which then would distribute the events to one or more
>> subscribers.
>
> That sounds great.
Good good :)
...
>> +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)
>> +);
>
> This assumes build events are necessarily related to a derivation,
> though one could imagine events having to do with evaluations, jobsets,
> etc.
>
> Should ‘BuildEvents’ be more generic and have ‘event’ be an sexp or JSON
> string that could describe any kind of event?
>
> If we did that, we could keep ‘derivation’ but remove “NOT NULL” so that
> non-derivation events can exist but we can still query
> derivation-related events quickly. Does that make sense?
Yep, that makes sense.
This seems to be the general decision about the way you use a relational
database, do you have specific tables (types) for the data, or do you
have a more freeform structure (columns containing sexp or JSON).
There's quite a few factors to consider here, the internals of Cuirass,
how these events are exposed through the HTTP API, how these events one
day might be published to a WebSub hub and then what kind of
subscriptions you might support in Cuirass (events for an individual
derivation, all builds for an evaluation, all builds, ...). I'll think
about it further and see if I can form an opinion either way.
>> +CREATE TABLE BuildEventsOutbox (
>> + build_event_id INTEGER NOT NULL,
>> + FOREIGN KEY (build_event_id) REFERENCES BuildEvents (id)
>> +);
>
> These are events that have not yet been sent, right?
Yep, exactly.
> Thanks!
Thanks for taking a look. I'll neaten up the patch a bit, add in some
error handling and retrying for sending out the events, and think a bit
more about the data model, then hopefully send an updated patch soon!
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* [PATCH 1/2] Support publishing build events
2019-10-23 23:32 ` Christopher Baines
@ 2019-10-28 8:10 ` Christopher Baines
2019-10-28 8:10 ` [PATCH 2/2] Support publishing evaluation events Christopher Baines
2019-11-16 21:39 ` [PATCH 1/2] Support publishing build events Ludovic Courtès
2019-10-28 8:33 ` Getting build information in to the Guix Data Service (draft patch) Christopher Baines
1 sibling, 2 replies; 36+ messages in thread
From: Christopher Baines @ 2019-10-28 8:10 UTC (permalink / raw)
To: guix-devel
---
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 <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; 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))))
+
+\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 <mail@cbaines.net>
+;;;
+;;; 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
^ permalink raw reply related [flat|nested] 36+ messages in thread* [PATCH 2/2] Support publishing evaluation events
2019-10-28 8:10 ` [PATCH 1/2] Support publishing build events Christopher Baines
@ 2019-10-28 8:10 ` Christopher Baines
2019-11-16 21:41 ` Ludovic Courtès
2019-11-16 21:39 ` [PATCH 1/2] Support publishing build events Ludovic Courtès
1 sibling, 1 reply; 36+ messages in thread
From: Christopher Baines @ 2019-10-28 8:10 UTC (permalink / raw)
To: guix-devel
---
src/cuirass/base.scm | 5 +++++
src/cuirass/database.scm | 6 +++++-
src/cuirass/http.scm | 9 +++++++++
3 files changed, 19 insertions(+), 1 deletion(-)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index fd10e35..943a4f2 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -724,6 +724,11 @@ started)."
(checkouts (fetch-inputs spec))
(eval-id (db-add-evaluation name checkouts)))
(when eval-id
+ (db-add-event 'evaluation
+ (time-second (current-time time-utc))
+ `((#:evalutaion . ,eval-id)
+ (#:specification . ,name)
+ (#:in_progress . #t)))
(compile-checkouts spec (filter compile? checkouts))
(spawn-fiber
(lambda ()
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 83c0c5a..05382d7 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -408,7 +408,11 @@ VALUES (" spec-name ", true);")
(define (db-set-evaluation-done eval-id)
(with-db-critical-section db
(sqlite-exec db "UPDATE Evaluations SET in_progress = false
-WHERE id = " eval-id ";")))
+WHERE id = " eval-id ";")
+ (db-add-event 'evaluation
+ (time-second (current-time time-utc))
+ `((#:evaluation . ,eval-id)
+ (#:in_progress . #f)))))
(define-syntax-rule (with-database body ...)
"Run BODY with %DB-CHANNEL being dynamically bound to a channel implementing
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 35e3d7f..4a3214d 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -347,6 +347,15 @@ Hydra format."
(specifications-table
(db-get-specifications))
'())))
+ (("api" "evaluation-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 'evaluation params)))
+ (respond-json-with-error 500 "Parameter not defined!"))))
(("jobset" name)
(respond-html
--
2.23.0
^ permalink raw reply related [flat|nested] 36+ messages in thread* Re: [PATCH 2/2] Support publishing evaluation events
2019-10-28 8:10 ` [PATCH 2/2] Support publishing evaluation events Christopher Baines
@ 2019-11-16 21:41 ` Ludovic Courtès
2019-11-16 23:34 ` Christopher Baines
0 siblings, 1 reply; 36+ messages in thread
From: Ludovic Courtès @ 2019-11-16 21:41 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel
Christopher Baines <mail@cbaines.net> skribis:
> ---
> src/cuirass/base.scm | 5 +++++
> src/cuirass/database.scm | 6 +++++-
> src/cuirass/http.scm | 9 +++++++++
> 3 files changed, 19 insertions(+), 1 deletion(-)
>
> diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
> index fd10e35..943a4f2 100644
> --- a/src/cuirass/base.scm
> +++ b/src/cuirass/base.scm
> @@ -724,6 +724,11 @@ started)."
> (checkouts (fetch-inputs spec))
> (eval-id (db-add-evaluation name checkouts)))
> (when eval-id
> + (db-add-event 'evaluation
> + (time-second (current-time time-utc))
> + `((#:evalutaion . ,eval-id)
^^^
Typo.
> + (#:specification . ,name)
> + (#:in_progress . #t)))
^
Should it be a hyphen?
Otherwise LGTM.
I think we should eventually use records everywhere instead of alists,
as that would catch such typos. We could use an approach similar to
that of ‘define-json-mapping’ to factorize
serialization/deserialization.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 36+ messages in thread* Re: [PATCH 2/2] Support publishing evaluation events
2019-11-16 21:41 ` Ludovic Courtès
@ 2019-11-16 23:34 ` Christopher Baines
0 siblings, 0 replies; 36+ messages in thread
From: Christopher Baines @ 2019-11-16 23:34 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 1621 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Christopher Baines <mail@cbaines.net> skribis:
>
>> ---
>> src/cuirass/base.scm | 5 +++++
>> src/cuirass/database.scm | 6 +++++-
>> src/cuirass/http.scm | 9 +++++++++
>> 3 files changed, 19 insertions(+), 1 deletion(-)
>>
>> diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
>> index fd10e35..943a4f2 100644
>> --- a/src/cuirass/base.scm
>> +++ b/src/cuirass/base.scm
>> @@ -724,6 +724,11 @@ started)."
>> (checkouts (fetch-inputs spec))
>> (eval-id (db-add-evaluation name checkouts)))
>> (when eval-id
>> + (db-add-event 'evaluation
>> + (time-second (current-time time-utc))
>> + `((#:evalutaion . ,eval-id)
> ^^^
> Typo.
Hmm, I remember testing this, but I guess it just sent out a JSON object
with that typo in it.
>> + (#:specification . ,name)
>> + (#:in_progress . #t)))
> ^
> Should it be a hyphen?
This'll end up being part of the JSON object sent out. It looks like the
existing /api/evaluations reponse uses in-progress, so this should
probably also be a hyphen for consistency.
> Otherwise LGTM.
>
> I think we should eventually use records everywhere instead of alists,
> as that would catch such typos. We could use an approach similar to
> that of ‘define-json-mapping’ to factorize
> serialization/deserialization.
That sounds like a good idea :)
Thanks,
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH 1/2] Support publishing build events
2019-10-28 8:10 ` [PATCH 1/2] Support publishing build events Christopher Baines
2019-10-28 8:10 ` [PATCH 2/2] Support publishing evaluation events Christopher Baines
@ 2019-11-16 21:39 ` Ludovic Courtès
2019-11-16 23:13 ` Christopher Baines
` (2 more replies)
1 sibling, 3 replies; 36+ messages in thread
From: Ludovic Courtès @ 2019-11-16 21:39 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel
Hi Chris,
Christopher Baines <mail@cbaines.net> skribis:
> ---
> 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
Sorry for the delay. It LGTM, thank you!
Please add a commit log :-), and let us know when you’d like to test
with the instance on berlin or that on bayfront.
IIUC, the ‘send-events’ program is provided as a debugging aid, right?
I mean it’s not used anywhere in the code.
If you can think of ways to tests parts of this, that’d also be great,
but it shouldn’t block it.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 36+ messages in thread* Re: [PATCH 1/2] Support publishing build events
2019-11-16 21:39 ` [PATCH 1/2] Support publishing build events Ludovic Courtès
@ 2019-11-16 23:13 ` Christopher Baines
2019-11-17 21:26 ` Ludovic Courtès
2019-11-28 18:36 ` Christopher Baines
2019-11-28 18:48 ` Christopher Baines
2 siblings, 1 reply; 36+ messages in thread
From: Christopher Baines @ 2019-11-16 23:13 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 1839 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hi Chris,
>
> Christopher Baines <mail@cbaines.net> skribis:
>
>> ---
>> 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
>
> Sorry for the delay. It LGTM, thank you!
>
> Please add a commit log :-), and let us know when you’d like to test
> with the instance on berlin or that on bayfront.
Great :)
I have access to bayfront already, so I think that's the place to try
this out initially.
> IIUC, the ‘send-events’ program is provided as a debugging aid, right?
> I mean it’s not used anywhere in the code.
Well, it would be potentially better to send the events from the same
Cuirass process that manages the builds, as then the events could be
sent out immediately.
However, I don't really know how fibers work, so I went with a separate
process to make it easier to manually test, and to reduce any risk of
interfering with other Cuirass functions.
> If you can think of ways to tests parts of this, that’d also be great,
> but it shouldn’t block it.
Ok. I'll hopefully have some time in the next week or two to take
another look. I'll add change logs to the commits, do some more manual
testing, and have a look at writing some automated tests.
Thanks,
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH 1/2] Support publishing build events
2019-11-16 23:13 ` Christopher Baines
@ 2019-11-17 21:26 ` Ludovic Courtès
2019-11-18 8:53 ` Christopher Baines
0 siblings, 1 reply; 36+ messages in thread
From: Ludovic Courtès @ 2019-11-17 21:26 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel
Hi!
Christopher Baines <mail@cbaines.net> skribis:
> I have access to bayfront already, so I think that's the place to try
> this out initially.
Sounds good.
>> IIUC, the ‘send-events’ program is provided as a debugging aid, right?
>> I mean it’s not used anywhere in the code.
>
> Well, it would be potentially better to send the events from the same
> Cuirass process that manages the builds, as then the events could be
> sent out immediately.
>
> However, I don't really know how fibers work, so I went with a separate
> process to make it easier to manually test, and to reduce any risk of
> interfering with other Cuirass functions.
Hmm, am I right that the ‘send-events’ program is not used at all by
Cuirass itself? Or did I overlook something?
However, I saw a fiber of the main ‘cuirass’ process that calls the
‘send-events’ procedure, and to me it’s good this way.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH 1/2] Support publishing build events
2019-11-17 21:26 ` Ludovic Courtès
@ 2019-11-18 8:53 ` Christopher Baines
0 siblings, 0 replies; 36+ messages in thread
From: Christopher Baines @ 2019-11-18 8:53 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 1446 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hi!
>
> Christopher Baines <mail@cbaines.net> skribis:
>
>>> IIUC, the ‘send-events’ program is provided as a debugging aid, right?
>>> I mean it’s not used anywhere in the code.
>>
>> Well, it would be potentially better to send the events from the same
>> Cuirass process that manages the builds, as then the events could be
>> sent out immediately.
>>
>> However, I don't really know how fibers work, so I went with a separate
>> process to make it easier to manually test, and to reduce any risk of
>> interfering with other Cuirass functions.
>
> Hmm, am I right that the ‘send-events’ program is not used at all by
> Cuirass itself? Or did I overlook something?
You're right in that the send-events program isn't run by Cuirass, it's
another process that you'd run alongside the main Cuirass process.
> However, I saw a fiber of the main ‘cuirass’ process that calls the
> ‘send-events’ procedure, and to me it’s good this way.
Yeah, the process that takes care of performing the builds adds events,
and entries to the outbox table as well.
I'm still not sure if this is the ideal long term architecture, maybe
all the functionality should be handled in a single process. But for
now, I do think having a separate process makes this new events stuff
easier to test, and less likely to break other aspects of Cuirass.
Thanks,
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* [PATCH 1/2] Support publishing build events
2019-11-16 21:39 ` [PATCH 1/2] Support publishing build events Ludovic Courtès
2019-11-16 23:13 ` Christopher Baines
@ 2019-11-28 18:36 ` Christopher Baines
2019-11-28 18:36 ` [PATCH 2/2] Support publishing evaluation events Christopher Baines
` (2 more replies)
2019-11-28 18:48 ` Christopher Baines
2 siblings, 3 replies; 36+ messages in thread
From: Christopher Baines @ 2019-11-28 18:36 UTC (permalink / raw)
To: guix-devel
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.
---
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 | 91 +++++++++++++++++++++++
src/schema.sql | 12 +++
src/sql/upgrade-5.sql | 15 ++++
8 files changed, 378 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 <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; 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))))
+
+\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 143bc2e..e7c2597 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -670,7 +670,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 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."
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 7579e1a..2a4113f 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -136,6 +136,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) ...)."
@@ -366,6 +381,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!"))))
(('GET)
(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..2b7dd9c
--- /dev/null
+++ b/src/cuirass/send-events.scm
@@ -0,0 +1,91 @@
+;;;; http.scm -- HTTP API
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; 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 (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-in-outbox 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-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.24.0
^ permalink raw reply related [flat|nested] 36+ messages in thread* [PATCH 2/2] Support publishing evaluation events
2019-11-28 18:36 ` Christopher Baines
@ 2019-11-28 18:36 ` Christopher Baines
2019-11-30 14:10 ` Clément Lassieur
2019-11-30 14:08 ` [PATCH 1/2] Support publishing build events Clément Lassieur
2019-11-30 14:23 ` Clément Lassieur
2 siblings, 1 reply; 36+ messages in thread
From: Christopher Baines @ 2019-11-28 18:36 UTC (permalink / raw)
To: guix-devel
* src/cuirass/base.scm (process-specs): Record the creation of new
evaluations as events.
* src/cuirass/database.scm (db-set-evaluation-done): Record when evaluations
finish as an event.
* src/cuirass/http.scm (url-handler): Add a new /api/evaluation-events page.
---
src/cuirass/base.scm | 5 +++++
src/cuirass/database.scm | 6 +++++-
src/cuirass/http.scm | 9 +++++++++
3 files changed, 19 insertions(+), 1 deletion(-)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index e7c2597..471a15e 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -770,6 +770,11 @@ started)."
(checkouts (fetch-inputs spec))
(eval-id (db-add-evaluation name checkouts)))
(when eval-id
+ (db-add-event 'evaluation
+ (time-second (current-time time-utc))
+ `((#:evaluation . ,eval-id)
+ (#:specification . ,name)
+ (#:in_progress . #t)))
(compile-checkouts spec (filter compile? checkouts))
(spawn-fiber
(lambda ()
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 8cb7465..02f9f9c 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -419,7 +419,11 @@ VALUES (" spec-name ", true);")
(define (db-set-evaluation-done eval-id)
(with-db-critical-section db
(sqlite-exec db "UPDATE Evaluations SET in_progress = false
-WHERE id = " eval-id ";")))
+WHERE id = " eval-id ";")
+ (db-add-event 'evaluation
+ (time-second (current-time time-utc))
+ `((#:evaluation . ,eval-id)
+ (#:in_progress . #f)))))
(define-syntax-rule (with-database body ...)
"Run BODY with %DB-CHANNEL being dynamically bound to a channel implementing
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 2a4113f..7d36945 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -396,6 +396,15 @@ Hydra format."
(specifications-table
(db-get-specifications))
'())))
+ (("api" "evaluation-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 'evaluation params)))
+ (respond-json-with-error 500 "Parameter not defined!"))))
(('GET "jobset" name)
(respond-html
--
2.24.0
^ permalink raw reply related [flat|nested] 36+ messages in thread* Re: [PATCH 2/2] Support publishing evaluation events
2019-11-28 18:36 ` [PATCH 2/2] Support publishing evaluation events Christopher Baines
@ 2019-11-30 14:10 ` Clément Lassieur
2019-12-03 0:21 ` Christopher Baines
0 siblings, 1 reply; 36+ messages in thread
From: Clément Lassieur @ 2019-11-30 14:10 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel
Christopher Baines <mail@cbaines.net> writes:
> * src/cuirass/base.scm (process-specs): Record the creation of new
> evaluations as events.
> * src/cuirass/database.scm (db-set-evaluation-done): Record when evaluations
> finish as an event.
> * src/cuirass/http.scm (url-handler): Add a new /api/evaluation-events page.
> ---
> src/cuirass/base.scm | 5 +++++
> src/cuirass/database.scm | 6 +++++-
> src/cuirass/http.scm | 9 +++++++++
> 3 files changed, 19 insertions(+), 1 deletion(-)
>
> diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
> index e7c2597..471a15e 100644
> --- a/src/cuirass/base.scm
> +++ b/src/cuirass/base.scm
> @@ -770,6 +770,11 @@ started)."
> (checkouts (fetch-inputs spec))
> (eval-id (db-add-evaluation name checkouts)))
> (when eval-id
> + (db-add-event 'evaluation
> + (time-second (current-time time-utc))
> + `((#:evaluation . ,eval-id)
> + (#:specification . ,name)
> + (#:in_progress . #t)))
Same comment as with the other patch: I think this could go to
database.scm, so that everything is done at the same level.
Thanks,
Clément
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH 2/2] Support publishing evaluation events
2019-11-30 14:10 ` Clément Lassieur
@ 2019-12-03 0:21 ` Christopher Baines
0 siblings, 0 replies; 36+ messages in thread
From: Christopher Baines @ 2019-12-03 0:21 UTC (permalink / raw)
To: Clément Lassieur; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 1380 bytes --]
Clément Lassieur <clement@lassieur.org> writes:
> Christopher Baines <mail@cbaines.net> writes:
>
>> * src/cuirass/base.scm (process-specs): Record the creation of new
>> evaluations as events.
>> * src/cuirass/database.scm (db-set-evaluation-done): Record when evaluations
>> finish as an event.
>> * src/cuirass/http.scm (url-handler): Add a new /api/evaluation-events page.
>> ---
>> src/cuirass/base.scm | 5 +++++
>> src/cuirass/database.scm | 6 +++++-
>> src/cuirass/http.scm | 9 +++++++++
>> 3 files changed, 19 insertions(+), 1 deletion(-)
>>
>> diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
>> index e7c2597..471a15e 100644
>> --- a/src/cuirass/base.scm
>> +++ b/src/cuirass/base.scm
>> @@ -770,6 +770,11 @@ started)."
>> (checkouts (fetch-inputs spec))
>> (eval-id (db-add-evaluation name checkouts)))
>> (when eval-id
>> + (db-add-event 'evaluation
>> + (time-second (current-time time-utc))
>> + `((#:evaluation . ,eval-id)
>> + (#:specification . ,name)
>> + (#:in_progress . #t)))
>
> Same comment as with the other patch: I think this could go to
> database.scm, so that everything is done at the same level.
Right, I'll have a look at moving this.
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH 1/2] Support publishing build events
2019-11-28 18:36 ` Christopher Baines
2019-11-28 18:36 ` [PATCH 2/2] Support publishing evaluation events Christopher Baines
@ 2019-11-30 14:08 ` Clément Lassieur
2019-12-03 0:12 ` Christopher Baines
2019-11-30 14:23 ` Clément Lassieur
2 siblings, 1 reply; 36+ messages in thread
From: Clément Lassieur @ 2019-11-30 14:08 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel
Hi Christopher,
This is a small review :)
Christopher Baines <mail@cbaines.net> writes:
> 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.
Why is it a JSON blob? I mean, why do we need it to be JSON if we use
JSON-STRING->SCM everytime we need to access it? If it's just to
normalize the scheme object, I think it's already done by %SQLITE-EXEC.
It converts the scheme object to a string. I can't see how a JSON
object is better than a string.
> The EventsOutbox table is then used to track when events have been sent
> out. This is done through the new cuirass-send-events script.
So the Events table will grow a lot. And once its content has been sent
out, we don't use it anymore if I understand well. Would it be possible
to just use the Events table, that would be emptied upon successful
send? That way, the whole mechanism would be simpler, and that table
wouldn't grow.
Unless there is a need to fetch events that have already been sent out?
But in that case, why not fetch them from the Guix Data Service?
Now that I think about it, I don't understand the point the HTTP API
("build-events", "evaluation-events"). If events are sent from Cuirass
to the Guix Data Service, why would anyone need to fetch those events
from Cuirass? Wouldn't it make more sense to fetch them from the Guix
Data Service?
Another thing: Cuirass instances that aren't bound to the Guix Data
Service will still have their Events table grow. So it would be great
if DB-ADD-EVENT can be enabled through a Cuirass parameter. And by
default it would be disabled.
> * Makefile.am (bin_SCRIPTS): Add bin/cuirass-send-events.
^
Could you please add it to .gitignore?
> +;;;
> +;;; 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
^
Why do we need to use a fiber, if there is only one? A fiber is a
lightweight thread. They are useful if we need to do several things in
the same time, but if there is only one thing to do, I don't understand
the point.
> diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
> index 143bc2e..e7c2597 100644
> --- a/src/cuirass/base.scm
> +++ b/src/cuirass/base.scm
> @@ -670,7 +670,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))))
Could this be moved into the DB-ADD-BUILD procedure, in database.scm?
This way everyting would be done at the same (lower) level. The higher
level base.scm module doesn't need to know about it. And it'd adds
consistency.
> (define derivations
> (filter-map register jobs))
> 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
[...]
> + (unless (eq? (changes-count db) 0)
^
(when (positive? (changes-count db))
> diff --git a/src/cuirass/send-events.scm b/src/cuirass/send-events.scm
> new file mode 100644
> index 0000000..2b7dd9c
> --- /dev/null
> +++ b/src/cuirass/send-events.scm
> @@ -0,0 +1,91 @@
[...]
> +(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)
> + (let* ((body
^
let
> + (object->json-string
> + `((items
> + . ,(list->vector
> + (map (lambda (event)
> + (let ((event-json
> + (json-string->scm
[...]
> +(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."
Here, could you use common Guile conventions to write the docstring?
There are nice examples in ports.scm[1]. F would be a THUNK for
example. And "call" would be used instead of "run".
Also, a small wrapper macro (as it is done with (@@ (guix gnu machine
ssh) with-roll-back)) would allow to avoid typing (lambda () ...) and
remove an indentation level. You could prefix the procedure with
'call-', and add something like:
(define-syntax-rule (with-exponential-backoff-upon-error body ...)
(call-with-exponential-backoff-upon-error
(lambda ()
body ...)))
(untested)
Thank you!
Clément
[1]: https://github.com/ilovezfs/guile/blob/master/module/ice-9/ports.scm
^ permalink raw reply [flat|nested] 36+ messages in thread* Re: [PATCH 1/2] Support publishing build events
2019-11-30 14:08 ` [PATCH 1/2] Support publishing build events Clément Lassieur
@ 2019-12-03 0:12 ` Christopher Baines
2019-12-03 11:25 ` Clément Lassieur
0 siblings, 1 reply; 36+ messages in thread
From: Christopher Baines @ 2019-12-03 0:12 UTC (permalink / raw)
To: Clément Lassieur; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 7684 bytes --]
Clément Lassieur <clement@lassieur.org> writes:
> Hi Christopher,
>
> This is a small review :)
>
> Christopher Baines <mail@cbaines.net> writes:
>
>> 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.
>
> Why is it a JSON blob? I mean, why do we need it to be JSON if we use
> JSON-STRING->SCM everytime we need to access it? If it's just to
> normalize the scheme object, I think it's already done by %SQLITE-EXEC.
> It converts the scheme object to a string. I can't see how a JSON
> object is better than a string.
I guess so… I was probably just thinking about JSON from JSON fields
in PostgreSQL, but we're not using PostgreSQL here.
The one advantage I can think of is that not every Scheme object can be
converted to JSON (at least with guile-json), so by storing the JSON
representation, you're guaranteed to have a valid value. If you stored a
scheme object, there's a chance that you could store something that was
invalid, or at least didn't convert to JSON.
>> The EventsOutbox table is then used to track when events have been sent
>> out. This is done through the new cuirass-send-events script.
>
> So the Events table will grow a lot. And once its content has been sent
> out, we don't use it anymore if I understand well. Would it be possible
> to just use the Events table, that would be emptied upon successful
> send? That way, the whole mechanism would be simpler, and that table
> wouldn't grow.
>
> Unless there is a need to fetch events that have already been sent out?
There are API endpoints that expose events, like /api/build-events,
which requires storing the events.
> But in that case, why not fetch them from the Guix Data Service?
I'm still not sure what the ideal scope and architecture for the Guix
Data Service, or Cuirass is, but at the moment I've been trying to avoid
making one dependent on the other.
Also, I've been thinking about WebSub when trying to provide a way to
subscribe to events, which I'll say more about shortly…
> Now that I think about it, I don't understand the point the HTTP API
> ("build-events", "evaluation-events"). If events are sent from Cuirass
> to the Guix Data Service, why would anyone need to fetch those events
> from Cuirass? Wouldn't it make more sense to fetch them from the Guix
> Data Service?
So, while this work is trying to copy data from Cuirass to the Guix Data
Service, I'm still thinking about them separately. I guess if you're
running your own instance of Cuirass, you might want to fetch events
from it, without having to setup an instance of the Guix Data Service.
> Another thing: Cuirass instances that aren't bound to the Guix Data
> Service will still have their Events table grow. So it would be great
> if DB-ADD-EVENT can be enabled through a Cuirass parameter. And by
> default it would be disabled.
I think that's a good idea, I'll have a look at implementing it.
>> * Makefile.am (bin_SCRIPTS): Add bin/cuirass-send-events.
> ^
> Could you please add it to .gitignore?
Ah, yep, will do.
>> +;;;
>> +;;; 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
> ^
> Why do we need to use a fiber, if there is only one? A fiber is a
> lightweight thread. They are useful if we need to do several things in
> the same time, but if there is only one thing to do, I don't understand
> the point.
If I remember correctly, the way Cuirass accesses the database is tied
up with fibers, so it's to make the database access work here.
>> diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
>> index 143bc2e..e7c2597 100644
>> --- a/src/cuirass/base.scm
>> +++ b/src/cuirass/base.scm
>> @@ -670,7 +670,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))))
>
> Could this be moved into the DB-ADD-BUILD procedure, in database.scm?
> This way everyting would be done at the same (lower) level. The higher
> level base.scm module doesn't need to know about it. And it'd adds
> consistency.
I'll have a look at doing this, along with storing events configurable.
>> (define derivations
>> (filter-map register jobs))
>> 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
>
> [...]
>
>> + (unless (eq? (changes-count db) 0)
> ^
> (when (positive? (changes-count db))
Cool, that does look better :)
>> diff --git a/src/cuirass/send-events.scm b/src/cuirass/send-events.scm
>> new file mode 100644
>> index 0000000..2b7dd9c
>> --- /dev/null
>> +++ b/src/cuirass/send-events.scm
>> @@ -0,0 +1,91 @@
>
> [...]
>
>> +(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)
>> + (let* ((body
> ^
> let
Ah, good spot.
>> + (object->json-string
>> + `((items
>> + . ,(list->vector
>> + (map (lambda (event)
>> + (let ((event-json
>> + (json-string->scm
>
> [...]
>
>> +(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."
>
> Here, could you use common Guile conventions to write the docstring?
> There are nice examples in ports.scm[1]. F would be a THUNK for
> example. And "call" would be used instead of "run".
Ok, I'll have a look at doing this.
> Also, a small wrapper macro (as it is done with (@@ (guix gnu machine
> ssh) with-roll-back)) would allow to avoid typing (lambda () ...) and
> remove an indentation level. You could prefix the procedure with
> 'call-', and add something like:
>
> (define-syntax-rule (with-exponential-backoff-upon-error body ...)
> (call-with-exponential-backoff-upon-error
> (lambda ()
> body ...)))
I'm not that comfortable with macros, but I'll have a look at doing
this.
Thanks,
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread* Re: [PATCH 1/2] Support publishing build events
2019-12-03 0:12 ` Christopher Baines
@ 2019-12-03 11:25 ` Clément Lassieur
2019-12-03 19:44 ` Christopher Baines
0 siblings, 1 reply; 36+ messages in thread
From: Clément Lassieur @ 2019-12-03 11:25 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel
Hi Christopher!
Christopher Baines <mail@cbaines.net> writes:
> I guess so… I was probably just thinking about JSON from JSON fields
> in PostgreSQL, but we're not using PostgreSQL here.
>
> The one advantage I can think of is that not every Scheme object can be
> converted to JSON (at least with guile-json), so by storing the JSON
> representation, you're guaranteed to have a valid value. If you stored a
> scheme object, there's a chance that you could store something that was
> invalid, or at least didn't convert to JSON.
Do you know any Scheme object that cannot be converted to JSON? Even
procedures can.
>> But in that case, why not fetch them from the Guix Data Service?
>
> I'm still not sure what the ideal scope and architecture for the Guix
> Data Service, or Cuirass is, but at the moment I've been trying to avoid
> making one dependent on the other.
Well, if we want to keep our softwares (GDS and Cuirass) as simple as
they can be, there should be a clear delimitation about what each of
them does, and they should not implement the same features, in my
opinion.
Also, I can't see how GDS wouldn't be dependent on Cuirass.
So maybe I'm wrong, but if GDS stores the events, I think it's a bad
idea that Cuirass stores them too.
> Also, I've been thinking about WebSub when trying to provide a way to
> subscribe to events, which I'll say more about shortly…
I'd love to understand what WebSub is too!
>> Now that I think about it, I don't understand the point the HTTP API
>> ("build-events", "evaluation-events"). If events are sent from Cuirass
>> to the Guix Data Service, why would anyone need to fetch those events
>> from Cuirass? Wouldn't it make more sense to fetch them from the Guix
>> Data Service?
>
> So, while this work is trying to copy data from Cuirass to the Guix Data
> Service, I'm still thinking about them separately. I guess if you're
> running your own instance of Cuirass, you might want to fetch events
> from it, without having to setup an instance of the Guix Data Service.
Is there any use of having raw Cuirass events without the Guix Data
Service to interpret them?
>> Why do we need to use a fiber, if there is only one? A fiber is a
>> lightweight thread. They are useful if we need to do several things in
>> the same time, but if there is only one thing to do, I don't understand
>> the point.
>
> If I remember correctly, the way Cuirass accesses the database is tied
> up with fibers, so it's to make the database access work here.
It's not tied up with fibers. There is a database server in another
thread, and WITH-DB-CRITICAL-SECTION will allow you to communicate with
that server through channels. But you don't need to be in a fiber to
communicate through channels, being in the main thread is good enough.
Clément
PS: sorry to have sent my review so late, I couldn't find the time
before.
^ permalink raw reply [flat|nested] 36+ messages in thread* Re: [PATCH 1/2] Support publishing build events
2019-12-03 11:25 ` Clément Lassieur
@ 2019-12-03 19:44 ` Christopher Baines
2019-12-04 13:59 ` Clément Lassieur
0 siblings, 1 reply; 36+ messages in thread
From: Christopher Baines @ 2019-12-03 19:44 UTC (permalink / raw)
To: Clément Lassieur; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 5200 bytes --]
Clément Lassieur <clement@lassieur.org> writes:
> Christopher Baines <mail@cbaines.net> writes:
>
>> I guess so… I was probably just thinking about JSON from JSON fields
>> in PostgreSQL, but we're not using PostgreSQL here.
>>
>> The one advantage I can think of is that not every Scheme object can be
>> converted to JSON (at least with guile-json), so by storing the JSON
>> representation, you're guaranteed to have a valid value. If you stored a
>> scheme object, there's a chance that you could store something that was
>> invalid, or at least didn't convert to JSON.
>
> Do you know any Scheme object that cannot be converted to JSON? Even
> procedures can.
I was thinking of something like this:
scheme@(guile-user)> (scm->json-string '(()))
json/builder.scm:91:21: In procedure build-object-pair:
In procedure car: Wrong type argument in position 1 (expecting pair): ()
>>> But in that case, why not fetch them from the Guix Data Service?
>>
>> I'm still not sure what the ideal scope and architecture for the Guix
>> Data Service, or Cuirass is, but at the moment I've been trying to avoid
>> making one dependent on the other.
>
> Well, if we want to keep our softwares (GDS and Cuirass) as simple as
> they can be, there should be a clear delimitation about what each of
> them does, and they should not implement the same features, in my
> opinion.
At least in my mind, this is an important issue, but something I'm very
uncertian about. The biggest existing overlap in my mind is that the
Guix Data Service and Cuirass compute and store derivations.
> Also, I can't see how GDS wouldn't be dependent on Cuirass.
Maybe dependent wasn't the best way to phrase it. What I've been
thinking about is you should be able to run Cuirass without the Guix
Data Service, and this might be very applicable for small deployments.
> So maybe I'm wrong, but if GDS stores the events, I think it's a bad
> idea that Cuirass stores them too.
…
>> Also, I've been thinking about WebSub when trying to provide a way to
>> subscribe to events, which I'll say more about shortly…
>
> I'd love to understand what WebSub is too!
So I meant to say more in my last email, but I obviously forgot to
elaborate!
So WebSub is W3C recommendation standard (that doesn't carry much weight
with me, but I was looking for some kind of standard or interoperable
way of doing things). In it's model, I've been thinking of Cuirass as a
"Publisher" [1].
1: https://www.w3.org/TR/websub/#conformance-classes
WebSub describes subscripting to topics, through their URL. Which is why
I created URLs to serve the build and evaluation events. I also think
some people may want to just fetch the events, rather than subscribing
to them.
>>> Now that I think about it, I don't understand the point the HTTP API
>>> ("build-events", "evaluation-events"). If events are sent from Cuirass
>>> to the Guix Data Service, why would anyone need to fetch those events
>>> from Cuirass? Wouldn't it make more sense to fetch them from the Guix
>>> Data Service?
>>
>> So, while this work is trying to copy data from Cuirass to the Guix Data
>> Service, I'm still thinking about them separately. I guess if you're
>> running your own instance of Cuirass, you might want to fetch events
>> from it, without having to setup an instance of the Guix Data Service.
So adding a bit to what I say here, I added the API endpoints also to
keep somewhat aligned with WebSub.
> Is there any use of having raw Cuirass events without the Guix Data
> Service to interpret them?
I think so, you could hook them up to an IRC bot for example, to post in
some channel when events happen to builds.
It's true that the information in the events table can also be found
elsewhere in the database, it's just not in an ideal form to send out to
some receiver.
I'm still interested in getting Cuirass to publish events to a WebSub
hub, at which point a topic URL for build events would be necessary (at
least in terms of WebSub) to subscribe to events.
However, at the moment, I'm trying to do something minimal to get data
from Cuirass in to the Guix Data Service, and I haven't set up the hub
needed for WebSub.
Maybe it would be simpler to remove the API endpoints for now, and they
can possibly come back once there's a WebSub hub involved.
>>> Why do we need to use a fiber, if there is only one? A fiber is a
>>> lightweight thread. They are useful if we need to do several things in
>>> the same time, but if there is only one thing to do, I don't understand
>>> the point.
>>
>> If I remember correctly, the way Cuirass accesses the database is tied
>> up with fibers, so it's to make the database access work here.
>
> It's not tied up with fibers. There is a database server in another
> thread, and WITH-DB-CRITICAL-SECTION will allow you to communicate with
> that server through channels. But you don't need to be in a fiber to
> communicate through channels, being in the main thread is good enough.
Ok, I'll have another look at how fibers are used when sending out
events.
Thanks,
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread* Re: [PATCH 1/2] Support publishing build events
2019-12-03 19:44 ` Christopher Baines
@ 2019-12-04 13:59 ` Clément Lassieur
2019-12-28 20:17 ` Christopher Baines
0 siblings, 1 reply; 36+ messages in thread
From: Clément Lassieur @ 2019-12-04 13:59 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel
Christopher Baines <mail@cbaines.net> writes:
> Clément Lassieur <clement@lassieur.org> writes:
>
>> Christopher Baines <mail@cbaines.net> writes:
>>
>>> I guess so… I was probably just thinking about JSON from JSON fields
>>> in PostgreSQL, but we're not using PostgreSQL here.
>>>
>>> The one advantage I can think of is that not every Scheme object can be
>>> converted to JSON (at least with guile-json), so by storing the JSON
>>> representation, you're guaranteed to have a valid value. If you stored a
>>> scheme object, there's a chance that you could store something that was
>>> invalid, or at least didn't convert to JSON.
>>
>> Do you know any Scheme object that cannot be converted to JSON? Even
>> procedures can.
>
> I was thinking of something like this:
>
> scheme@(guile-user)> (scm->json-string '(()))
> json/builder.scm:91:21: In procedure build-object-pair:
> In procedure car: Wrong type argument in position 1 (expecting pair): ()
Oh right, got it!
>>>> But in that case, why not fetch them from the Guix Data Service?
>>>
>>> I'm still not sure what the ideal scope and architecture for the Guix
>>> Data Service, or Cuirass is, but at the moment I've been trying to avoid
>>> making one dependent on the other.
>>
>> Well, if we want to keep our softwares (GDS and Cuirass) as simple as
>> they can be, there should be a clear delimitation about what each of
>> them does, and they should not implement the same features, in my
>> opinion.
>
> At least in my mind, this is an important issue, but something I'm very
> uncertian about. The biggest existing overlap in my mind is that the
> Guix Data Service and Cuirass compute and store derivations.
>
>> Also, I can't see how GDS wouldn't be dependent on Cuirass.
>
> Maybe dependent wasn't the best way to phrase it. What I've been
> thinking about is you should be able to run Cuirass without the Guix
> Data Service, and this might be very applicable for small deployments.
Oh yes, of course, I see. That's why I was talking about an option to
enable/disable DB-ADD-EVENT in my other email.
[...]
>>> Also, I've been thinking about WebSub when trying to provide a way to
>>> subscribe to events, which I'll say more about shortly…
>>
>> I'd love to understand what WebSub is too!
>
> So I meant to say more in my last email, but I obviously forgot to
> elaborate!
>
> So WebSub is W3C recommendation standard (that doesn't carry much weight
> with me, but I was looking for some kind of standard or interoperable
> way of doing things). In it's model, I've been thinking of Cuirass as a
> "Publisher" [1].
>
> 1: https://www.w3.org/TR/websub/#conformance-classes
>
> WebSub describes subscripting to topics, through their URL. Which is why
> I created URLs to serve the build and evaluation events. I also think
> some people may want to just fetch the events, rather than subscribing
> to them.
Great, thank you for the explanations!
>>>> Now that I think about it, I don't understand the point the HTTP API
>>>> ("build-events", "evaluation-events"). If events are sent from Cuirass
>>>> to the Guix Data Service, why would anyone need to fetch those events
>>>> from Cuirass? Wouldn't it make more sense to fetch them from the Guix
>>>> Data Service?
>>>
>>> So, while this work is trying to copy data from Cuirass to the Guix Data
>>> Service, I'm still thinking about them separately. I guess if you're
>>> running your own instance of Cuirass, you might want to fetch events
>>> from it, without having to setup an instance of the Guix Data Service.
>
> So adding a bit to what I say here, I added the API endpoints also to
> keep somewhat aligned with WebSub.
>
>> Is there any use of having raw Cuirass events without the Guix Data
>> Service to interpret them?
>
> I think so, you could hook them up to an IRC bot for example, to post in
> some channel when events happen to builds.
>
> It's true that the information in the events table can also be found
> elsewhere in the database, it's just not in an ideal form to send out to
> some receiver.
But can that wanted form be made out of what we already have, with an
SQL select query? What are we missing?
My main worry is to have redundant tables that keep growing. So if we
already have all the informations we need, wouldn't it be better to find
a smart way to use them?
> I'm still interested in getting Cuirass to publish events to a WebSub
> hub, at which point a topic URL for build events would be necessary (at
> least in terms of WebSub) to subscribe to events.
>
> However, at the moment, I'm trying to do something minimal to get data
> from Cuirass in to the Guix Data Service, and I haven't set up the hub
> needed for WebSub.
>
> Maybe it would be simpler to remove the API endpoints for now, and they
> can possibly come back once there's a WebSub hub involved.
I agree, going step by step seems like a good idea.
>>>> Why do we need to use a fiber, if there is only one? A fiber is a
>>>> lightweight thread. They are useful if we need to do several things in
>>>> the same time, but if there is only one thing to do, I don't understand
>>>> the point.
>>>
>>> If I remember correctly, the way Cuirass accesses the database is tied
>>> up with fibers, so it's to make the database access work here.
>>
>> It's not tied up with fibers. There is a database server in another
>> thread, and WITH-DB-CRITICAL-SECTION will allow you to communicate with
>> that server through channels. But you don't need to be in a fiber to
>> communicate through channels, being in the main thread is good enough.
>
> Ok, I'll have another look at how fibers are used when sending out
> events.
It's just a few lines to remove, nothing troublesome I believe.
Thanks,
Clément
^ permalink raw reply [flat|nested] 36+ messages in thread* Re: [PATCH 1/2] Support publishing build events
2019-12-04 13:59 ` Clément Lassieur
@ 2019-12-28 20:17 ` Christopher Baines
2020-01-08 11:27 ` Ludovic Courtès
0 siblings, 1 reply; 36+ messages in thread
From: Christopher Baines @ 2019-12-28 20:17 UTC (permalink / raw)
To: guix-devel; +Cc: Clément Lassieur
[-- Attachment #1: Type: text/plain, Size: 2550 bytes --]
I've finally got back around to looking at this again, I've sent a new
v4 version which is a slimmed down version of the previous patch. The
events table itself is now used as the queue, with sent events being
deleted. The table is also only populated if the --record-events option
is set when running Cuirass.
Clément Lassieur <clement@lassieur.org> writes:
>>>>> But in that case, why not fetch them from the Guix Data Service?
>>>>
>>>> I'm still not sure what the ideal scope and architecture for the Guix
>>>> Data Service, or Cuirass is, but at the moment I've been trying to avoid
>>>> making one dependent on the other.
>>>
>>> Well, if we want to keep our softwares (GDS and Cuirass) as simple as
>>> they can be, there should be a clear delimitation about what each of
>>> them does, and they should not implement the same features, in my
>>> opinion.
>>
>> At least in my mind, this is an important issue, but something I'm very
>> uncertian about. The biggest existing overlap in my mind is that the
>> Guix Data Service and Cuirass compute and store derivations.
>>
>>> Also, I can't see how GDS wouldn't be dependent on Cuirass.
>>
>> Maybe dependent wasn't the best way to phrase it. What I've been
>> thinking about is you should be able to run Cuirass without the Guix
>> Data Service, and this might be very applicable for small deployments.
>
> Oh yes, of course, I see. That's why I was talking about an option to
> enable/disable DB-ADD-EVENT in my other email.
I've now added this option, through the --record-events parameter.
...
>>>>> Why do we need to use a fiber, if there is only one? A fiber is a
>>>>> lightweight thread. They are useful if we need to do several things in
>>>>> the same time, but if there is only one thing to do, I don't understand
>>>>> the point.
>>>>
>>>> If I remember correctly, the way Cuirass accesses the database is tied
>>>> up with fibers, so it's to make the database access work here.
>>>
>>> It's not tied up with fibers. There is a database server in another
>>> thread, and WITH-DB-CRITICAL-SECTION will allow you to communicate with
>>> that server through channels. But you don't need to be in a fiber to
>>> communicate through channels, being in the main thread is good enough.
>>
>> Ok, I'll have another look at how fibers are used when sending out
>> events.
>
> It's just a few lines to remove, nothing troublesome I believe.
Yeah, so after trying this out, it does indeed work fine without using
fibers.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH 1/2] Support publishing build events
2019-12-28 20:17 ` Christopher Baines
@ 2020-01-08 11:27 ` Ludovic Courtès
2020-01-16 8:37 ` Christopher Baines
0 siblings, 1 reply; 36+ messages in thread
From: Ludovic Courtès @ 2020-01-08 11:27 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel, Clément Lassieur
Hi!
Christopher Baines <mail@cbaines.net> skribis:
> I've finally got back around to looking at this again, I've sent a new
> v4 version which is a slimmed down version of the previous patch. The
> events table itself is now used as the queue, with sent events being
> deleted. The table is also only populated if the --record-events option
> is set when running Cuirass.
It’s been a while already; I’d say this v4 can go in, and we can always
adjust later if needed!
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH 1/2] Support publishing build events
2020-01-08 11:27 ` Ludovic Courtès
@ 2020-01-16 8:37 ` Christopher Baines
0 siblings, 0 replies; 36+ messages in thread
From: Christopher Baines @ 2020-01-16 8:37 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guix-devel, Clément Lassieur
[-- Attachment #1: Type: text/plain, Size: 751 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Christopher Baines <mail@cbaines.net> skribis:
>
>> I've finally got back around to looking at this again, I've sent a new
>> v4 version which is a slimmed down version of the previous patch. The
>> events table itself is now used as the queue, with sent events being
>> deleted. The table is also only populated if the --record-events option
>> is set when running Cuirass.
>
> It’s been a while already; I’d say this v4 can go in, and we can always
> adjust later if needed!
Cool, I've pushed this now. I'm going to first look at querying the
builds through the outputs, which is the other patch I pushed, but I'll
also try to get around to testing this out too.
Thanks,
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH 1/2] Support publishing build events
2019-11-28 18:36 ` Christopher Baines
2019-11-28 18:36 ` [PATCH 2/2] Support publishing evaluation events Christopher Baines
2019-11-30 14:08 ` [PATCH 1/2] Support publishing build events Clément Lassieur
@ 2019-11-30 14:23 ` Clément Lassieur
2019-12-03 0:20 ` Christopher Baines
2 siblings, 1 reply; 36+ messages in thread
From: Clément Lassieur @ 2019-11-30 14:23 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel
Christopher Baines <mail@cbaines.net> writes:
> 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,
^
Also, I forgot. This row could be removed if the EventsOutbox table is
removed.
> + 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)
> +);
> +
And now that I think about it, even if we don't remove the EventsOutbox
table, wouldn't it be simpler to just add a 'sent' column (a Boolean) to
the Events table?
Clément
^ permalink raw reply [flat|nested] 36+ messages in thread* Re: [PATCH 1/2] Support publishing build events
2019-11-30 14:23 ` Clément Lassieur
@ 2019-12-03 0:20 ` Christopher Baines
0 siblings, 0 replies; 36+ messages in thread
From: Christopher Baines @ 2019-12-03 0:20 UTC (permalink / raw)
To: Clément Lassieur; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 1685 bytes --]
Clément Lassieur <clement@lassieur.org> writes:
> Christopher Baines <mail@cbaines.net> writes:
>
>> 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,
> ^
> Also, I forgot. This row could be removed if the EventsOutbox table is
> removed.
>
>> + 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)
>> +);
>> +
>
> And now that I think about it, even if we don't remove the EventsOutbox
> table, wouldn't it be simpler to just add a 'sent' column (a Boolean) to
> the Events table?
Simpler definitely in terms of the schema. However, I was thinking more
of the separation of concerns. One concern is storing events, and the
other is delivering them, and each table handles just one of those
things.
Also, I think at least in PostgreSQL, updating a row in a table
effectively inserts a new version of the row with the update, then at
some point the space for the old version of the row may be reused. Given
the events table may become quite large, it will probably be easier to
handle as something that's just added to, not added to and then
modified. But, I realise this is me guessing about performance and
maintenance without knowing much about SQLite, or doing any testing…
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH 1/2] Support publishing build events
2019-11-16 21:39 ` [PATCH 1/2] Support publishing build events Ludovic Courtès
2019-11-16 23:13 ` Christopher Baines
2019-11-28 18:36 ` Christopher Baines
@ 2019-11-28 18:48 ` Christopher Baines
2019-11-30 11:15 ` Clément Lassieur
2 siblings, 1 reply; 36+ messages in thread
From: Christopher Baines @ 2019-11-28 18:48 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 1861 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hi Chris,
>
> Christopher Baines <mail@cbaines.net> skribis:
>
>> ---
>> 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
>
> Sorry for the delay. It LGTM, thank you!
>
> Please add a commit log :-), and let us know when you’d like to test
> with the instance on berlin or that on bayfront.
Following up on this again, I've now sent a couple of updated
patches. Not much about the code has changed, I fixed a typo, added
better error handling to sending events, and added changelog entries to
the commit messages.
I have done more testing though, and also added more support for
receiving events to the Guix Data Service (mostly in this commit [1]).
1: https://git.savannah.gnu.org/cgit/guix/data-service.git/commit/?id=5663235048b7341b378634d083eaae9f13580e07
In terms of the code, the Guix Data Service is now capable of handling
Cuirass sending it events, and I've been testing this locally using the
random Cuirass example.
I'm not sure whether it's worth trying this out on bayfront prior to
merging the changes, or merging them and then trying it out on bayfront,
but either way, at the moment there's no rush, as the Guix Data Service
is down at the moment due to hardware issues.
Thanks,
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH 1/2] Support publishing build events
2019-11-28 18:48 ` Christopher Baines
@ 2019-11-30 11:15 ` Clément Lassieur
2019-12-02 23:22 ` Christopher Baines
0 siblings, 1 reply; 36+ messages in thread
From: Clément Lassieur @ 2019-11-30 11:15 UTC (permalink / raw)
To: Christopher Baines; +Cc: guix-devel
Christopher Baines <mail@cbaines.net> writes:
> Following up on this again, I've now sent a couple of updated
> patches. Not much about the code has changed, I fixed a typo, added
> better error handling to sending events, and added changelog entries to
> the commit messages.
Hi Christopher,
Thank you for this work!
Could you please update the documentation as well? That would be great
:)
Thanks again,
Clément
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: [PATCH 1/2] Support publishing build events
2019-11-30 11:15 ` Clément Lassieur
@ 2019-12-02 23:22 ` Christopher Baines
0 siblings, 0 replies; 36+ messages in thread
From: Christopher Baines @ 2019-12-02 23:22 UTC (permalink / raw)
To: Clément Lassieur; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 635 bytes --]
Clément Lassieur <clement@lassieur.org> writes:
> Christopher Baines <mail@cbaines.net> writes:
>
>> Following up on this again, I've now sent a couple of updated
>> patches. Not much about the code has changed, I fixed a typo, added
>> better error handling to sending events, and added changelog entries to
>> the commit messages.
>
> Hi Christopher,
>
> Thank you for this work!
>
> Could you please update the documentation as well? That would be great
> :)
Indeed :) I haven't actually read the Cuirass documentation, but I'll
have a read and look at adding/altering the documentation.
Thanks,
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* Re: Getting build information in to the Guix Data Service (draft patch)
2019-10-23 23:32 ` Christopher Baines
2019-10-28 8:10 ` [PATCH 1/2] Support publishing build events Christopher Baines
@ 2019-10-28 8:33 ` Christopher Baines
1 sibling, 0 replies; 36+ messages in thread
From: Christopher Baines @ 2019-10-28 8:33 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guix-devel
[-- Attachment #1: Type: text/plain, Size: 2716 bytes --]
Christopher Baines <mail@cbaines.net> writes:
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Christopher Baines <mail@cbaines.net> skribis:
>>
>> Should ‘BuildEvents’ be more generic and have ‘event’ be an sexp or JSON
>> string that could describe any kind of event?
>>
>> If we did that, we could keep ‘derivation’ but remove “NOT NULL” so that
>> non-derivation events can exist but we can still query
>> derivation-related events quickly. Does that make sense?
>
> Yep, that makes sense.
>
> This seems to be the general decision about the way you use a relational
> database, do you have specific tables (types) for the data, or do you
> have a more freeform structure (columns containing sexp or JSON).
>
> There's quite a few factors to consider here, the internals of Cuirass,
> how these events are exposed through the HTTP API, how these events one
> day might be published to a WebSub hub and then what kind of
> subscriptions you might support in Cuirass (events for an individual
> derivation, all builds for an evaluation, all builds, ...). I'll think
> about it further and see if I can form an opinion either way.
So I had a think about this, and also re-read the WebSub spec [1], along
with JSON Feed which is a Atom/RSS alternative with JSON [2]. I'm still
a bit undecided about how closely to follow WebSub, as it seems more
concerned with applications like blogging, and less with moving data
between services, but I still think the principles are good. For now, I
think it's best to pick the bits of the standard that work, and leave
any that don't particularly apply.
I think a generic approach to storing the events in the database will
work better though, at least with the way the events are currently
exposed. It does make it potentially harder to expose and support
subscriptions for events for individual builds, but that can probably be
addressed later if desired.
1: https://www.w3.org/TR/websub/
2: https://jsonfeed.org/version/1
>>> +CREATE TABLE BuildEventsOutbox (
>>> + build_event_id INTEGER NOT NULL,
>>> + FOREIGN KEY (build_event_id) REFERENCES BuildEvents (id)
>>> +);
>>
>> These are events that have not yet been sent, right?
>
> Yep, exactly.
>
>> Thanks!
>
> Thanks for taking a look. I'll neaten up the patch a bit, add in some
> error handling and retrying for sending out the events, and think a bit
> more about the data model, then hopefully send an updated patch soon!
I've now sent an updated set of patches. The first to add events for
builds, and the second to extend this to evaluations.
I've also added in error handling to the sending of the events.
Thanks,
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 36+ messages in thread
* [PATCH v3 1/2] Support publishing build events
2019-10-20 7:41 Getting build information in to the Guix Data Service (draft patch) Christopher Baines
2019-10-20 7:49 ` [PATCH] Support publishing build events Christopher Baines via Development of GNU Guix and the GNU System distribution.
2019-10-23 14:39 ` Getting build information in to the Guix Data Service (draft patch) Ludovic Courtès
@ 2019-12-28 19:05 ` Christopher Baines
2019-12-28 19:05 ` [PATCH v3 2/2] Support publishing evaluation events Christopher Baines
2019-12-28 19:54 ` [PATCH v4 1/2] Support publishing build events Christopher Baines
3 siblings, 1 reply; 36+ messages in thread
From: Christopher Baines @ 2019-12-28 19:05 UTC (permalink / raw)
To: guix-devel
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/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-add-build): Insert an event when a new build is inserted.
(db-delete-events-with-ids-<=-to): New procedure.
* src/schema.sql (Events): New table.
---
.gitignore | 1 +
Makefile.am | 8 ++-
bin/cuirass-send-events.in | 80 +++++++++++++++++++++++++
src/cuirass/database.scm | 114 ++++++++++++++++++++++++++++++++----
src/cuirass/send-events.scm | 91 ++++++++++++++++++++++++++++
src/schema.sql | 7 +++
src/sql/upgrade-5.sql | 15 +++++
7 files changed, 303 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/.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 <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..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 <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; 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))))
+
+\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/src/cuirass/database.scm b/src/cuirass/database.scm
index 523165d..924c72a 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
@@ -270,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."
@@ -504,7 +513,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 +538,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 +777,62 @@ 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)
+ ");")
+ #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 <mail@cbaines.net>
+;;;
+;;; 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 (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;
--
2.24.1
^ permalink raw reply related [flat|nested] 36+ messages in thread* [PATCH v3 2/2] Support publishing evaluation events
2019-12-28 19:05 ` [PATCH v3 1/2] Support publishing build events Christopher Baines
@ 2019-12-28 19:05 ` Christopher Baines
0 siblings, 0 replies; 36+ messages in thread
From: Christopher Baines @ 2019-12-28 19:05 UTC (permalink / raw)
To: guix-devel
* src/cuirass/database.scm (db-add-evaluation): Record the creation of new
evaluations as events.
(db-set-evaluation-done): Record when evaluations finish as an event.
* src/cuirass/http.scm (url-handler): Add a new /api/evaluation-events page.
---
src/cuirass/database.scm | 13 +++++++++++--
1 file changed, 11 insertions(+), 2 deletions(-)
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 924c72a..2e8e789 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -408,7 +408,12 @@ VALUES (" spec-name ", true);")
(if (null? new-checkouts)
(begin (sqlite-exec db "ROLLBACK;")
#f)
- (begin (sqlite-exec db "COMMIT;")
+ (begin (db-add-event 'evaluation
+ (time-second (current-time time-utc))
+ `((#:evaluation . ,eval-id)
+ (#:specification . ,spec-name)
+ (#:in_progress . #t)))
+ (sqlite-exec db "COMMIT;")
eval-id)))))
(define (db-set-evaluations-done)
@@ -418,7 +423,11 @@ VALUES (" spec-name ", true);")
(define (db-set-evaluation-done eval-id)
(with-db-critical-section db
(sqlite-exec db "UPDATE Evaluations SET in_progress = false
-WHERE id = " eval-id ";")))
+WHERE id = " eval-id ";")
+ (db-add-event 'evaluation
+ (time-second (current-time time-utc))
+ `((#:evaluation . ,eval-id)
+ (#:in_progress . #f)))))
(define-syntax-rule (with-database body ...)
"Run BODY with %DB-CHANNEL being dynamically bound to a channel implementing
--
2.24.1
^ permalink raw reply related [flat|nested] 36+ messages in thread
* [PATCH v4 1/2] Support publishing build events
2019-10-20 7:41 Getting build information in to the Guix Data Service (draft patch) Christopher Baines
` (2 preceding siblings ...)
2019-12-28 19:05 ` [PATCH v3 1/2] Support publishing build events Christopher Baines
@ 2019-12-28 19:54 ` Christopher Baines
2019-12-28 19:54 ` [PATCH v4 2/2] Support publishing evaluation events Christopher Baines
3 siblings, 1 reply; 36+ messages in thread
From: Christopher Baines @ 2019-12-28 19:54 UTC (permalink / raw)
To: guix-devel
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/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-add-build): Insert an event when a new build is inserted.
(db-delete-events-with-ids-<=-to): New procedure.
* src/schema.sql (Events): New table.
---
.gitignore | 1 +
Makefile.am | 8 ++-
bin/cuirass-send-events.in | 80 ++++++++++++++++++++++++
bin/cuirass.in | 3 +
src/cuirass/database.scm | 119 ++++++++++++++++++++++++++++++++----
src/cuirass/send-events.scm | 91 +++++++++++++++++++++++++++
src/schema.sql | 7 +++
src/sql/upgrade-5.sql | 15 +++++
8 files changed, 311 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/.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 <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..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 <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; 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))))
+
+\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 <mail@cbaines.net>
+;;;
+;;; 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 (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;
--
2.24.1
^ permalink raw reply related [flat|nested] 36+ messages in thread* [PATCH v4 2/2] Support publishing evaluation events
2019-12-28 19:54 ` [PATCH v4 1/2] Support publishing build events Christopher Baines
@ 2019-12-28 19:54 ` Christopher Baines
0 siblings, 0 replies; 36+ messages in thread
From: Christopher Baines @ 2019-12-28 19:54 UTC (permalink / raw)
To: guix-devel
* src/cuirass/database.scm (db-add-evaluation): Record the creation of new
evaluations as events.
(db-set-evaluation-done): Record when evaluations finish as an event.
* src/cuirass/http.scm (url-handler): Add a new /api/evaluation-events page.
---
src/cuirass/database.scm | 13 +++++++++++--
1 file changed, 11 insertions(+), 2 deletions(-)
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 9cd2e8f..ab6a4c7 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -412,7 +412,12 @@ VALUES (" spec-name ", true);")
(if (null? new-checkouts)
(begin (sqlite-exec db "ROLLBACK;")
#f)
- (begin (sqlite-exec db "COMMIT;")
+ (begin (db-add-event 'evaluation
+ (time-second (current-time time-utc))
+ `((#:evaluation . ,eval-id)
+ (#:specification . ,spec-name)
+ (#:in_progress . #t)))
+ (sqlite-exec db "COMMIT;")
eval-id)))))
(define (db-set-evaluations-done)
@@ -422,7 +427,11 @@ VALUES (" spec-name ", true);")
(define (db-set-evaluation-done eval-id)
(with-db-critical-section db
(sqlite-exec db "UPDATE Evaluations SET in_progress = false
-WHERE id = " eval-id ";")))
+WHERE id = " eval-id ";")
+ (db-add-event 'evaluation
+ (time-second (current-time time-utc))
+ `((#:evaluation . ,eval-id)
+ (#:in_progress . #f)))))
(define-syntax-rule (with-database body ...)
"Run BODY with %DB-CHANNEL being dynamically bound to a channel implementing
--
2.24.1
^ permalink raw reply related [flat|nested] 36+ messages in thread