Support publishing build events

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.

8 files changed, 378 insertions, 13 deletions

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))))
+
+
+;;;
+;;; 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;