branch master updated: Remove send events binary.

[Mathieu Othacehe]

This is an automated email from the git hooks/post-receive script.

mothacehe pushed a commit to branch master
in repository guix-cuirass.

The following commit(s) were added to refs/heads/master by this push:
     new 2eda35b  Remove send events binary.
2eda35b is described below

commit 2eda35bf685bab1db9eb489193003e3b733bc0de
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Sun Mar 14 20:48:25 2021 +0100

    Remove send events binary.
    
    This is superseeded by the notification system.
---
 .gitignore                  |  1 -
 Makefile.am                 |  4 --
 bin/cuirass-send-events.in  | 80 ---------------------------------------
 src/cuirass/send-events.scm | 91 ---------------------------------------------
 4 files changed, 176 deletions(-)

diff --git a/.gitignore b/.gitignore
index a67fb93..47627e3 100644
--- a/.gitignore
+++ b/.gitignore
@@ -10,7 +10,6 @@
 /aclocal.m4
 /autom4te.cache/
 /bin/cuirass
-/bin/cuirass-send-events
 /bin/evaluate
 /bin/remote-server
 /bin/remote-worker
diff --git a/Makefile.am b/Makefile.am
index 545d49e..f970046 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -24,7 +24,6 @@
 
 bin_SCRIPTS =                    \
   bin/cuirass                   \
-  bin/cuirass-send-events       \
   bin/evaluate                  \
   bin/remote-server             \
   bin/remote-worker
@@ -62,7 +61,6 @@ dist_pkgmodule_DATA =                         \
   src/cuirass/remote-server.scm                        \
   src/cuirass/remote-worker.scm                        \
   src/cuirass/rss.scm                          \
-  src/cuirass/send-events.scm                  \
   src/cuirass/specification.scm                        \
   src/cuirass/ui.scm                           \
   src/cuirass/utils.scm                                \
@@ -161,7 +159,6 @@ CLEANFILES =                                        \
 EXTRA_DIST = \
   .dir-locals.el \
   bin/cuirass.in \
-  bin/cuirass-send-events.in \
   bin/evaluate.in \
   bin/remote-server.in \
   bin/remote-worker.in \
@@ -223,7 +220,6 @@ 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/remote-server: $(srcdir)/bin/remote-server.in
 bin/remote-worker: $(srcdir)/bin/remote-worker.in
diff --git a/bin/cuirass-send-events.in b/bin/cuirass-send-events.in
deleted file mode 100644
index 2373e46..0000000
--- a/bin/cuirass-send-events.in
+++ /dev/null
@@ -1,80 +0,0 @@
-#!/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
-        (while #t
-          (send-events (option-ref opts 'target-url #f))
-          (sleep 5)))))))
diff --git a/src/cuirass/send-events.scm b/src/cuirass/send-events.scm
deleted file mode 100644
index 3ff5295..0000000
--- a/src/cuirass/send-events.scm
+++ /dev/null
@@ -1,91 +0,0 @@
-;;;; 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))))))