diff options
Diffstat (limited to 'src/cuirass/send-events.scm')
-rw-r--r-- | src/cuirass/send-events.scm | 91 |
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..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)))))) |