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.
.gitignore: 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.

1 files changed, 91 insertions, 0 deletions

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