From mboxrd@z Thu Jan 1 00:00:00 1970 From: Christopher Baines Subject: [PATCH 1/2] Support publishing build events Date: Mon, 28 Oct 2019 08:10:25 +0000 Message-ID: <20191028081026.25988-1-mail@cbaines.net> References: <8736fjqbrd.fsf@cbaines.net> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Return-path: Received: from eggs.gnu.org ([2001:470:142:3::10]:51163) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1iP06j-0008A7-Hb for guix-devel@gnu.org; Mon, 28 Oct 2019 04:10:36 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1iP06g-00046I-0S for guix-devel@gnu.org; Mon, 28 Oct 2019 04:10:33 -0400 Received: from mira.cbaines.net ([2a01:7e00::f03c:91ff:fe69:8da9]:46212) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1iP06f-00042s-Ni for guix-devel@gnu.org; Mon, 28 Oct 2019 04:10:29 -0400 Received: from localhost (cpc102582-walt20-2-0-cust14.13-2.cable.virginm.net [86.27.34.15]) by mira.cbaines.net (Postfix) with ESMTPSA id 82697175CF for ; Mon, 28 Oct 2019 08:10:27 +0000 (GMT) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 718d32d1 for ; Mon, 28 Oct 2019 08:10:26 +0000 (UTC) In-Reply-To: <8736fjqbrd.fsf@cbaines.net> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: guix-devel@gnu.org --- 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 . =20 -bin_SCRIPTS =3D bin/cuirass bin/evaluate +bin_SCRIPTS =3D bin/cuirass bin/cuirass-send-events bin/evaluate noinst_SCRIPTS =3D pre-inst-env =20 guilesitedir =3D $(datarootdir)/guile/site/@GUILE_EFFECTIVE_VERSION@ @@ -45,6 +45,7 @@ dist_pkgmodule_DATA =3D \ 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 =3D \ 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 =20 dist_css_DATA =3D \ src/static/css/bootstrap.css \ @@ -143,6 +145,7 @@ sql-check: src/schema.sql EXTRA_DIST =3D \ .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 =3D \ # 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=3D"@PACKAGE_LOAD_PATH@${GUILE_LOAD_PATH:+:}$GUILE_LOAD_= PATH" +#GUILE_LOAD_COMPILED_PATH=3D"@PACKAGE_LOAD_COMPILED_PATH@${GUILE_LOAD_CO= MPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" +exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" +!# +;;;; cuirass -- continuous integration tool +;;; Copyright =C2=A9 2016 Mathieu Lirzin +;;; Copyright =C2=A9 2017 Mathieu Othacehe +;;; Copyright =C2=A9 2018 Ludovic Court=C3=A8s +;;; Copyright =C2=A9 2018 Cl=C3=A9ment Lassieur +;;; Copyright =C2=A9 2019 Christopher Baines +;;; +;;; 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 . + +(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=3DURL Send events to URL. + -D --database=3DDB 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)))) + +=0C +;;; +;;; 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-databas= e))) + (%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)))) =20 (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-<=3D-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)) =20 +(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 ge= ts 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))) =20 + (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 (=3D status (build-status started)) - (sqlite-exec db "UPDATE Builds SET starttime=3D" now ", status=3D= " - status "WHERE derivation=3D" drv ";") + (begin + (sqlite-exec db "UPDATE Builds SET starttime=3D" now ", status= =3D" + status "WHERE derivation=3D" drv ";") + (db-add-event 'build + now + `((#:derivation . ,drv) + (#:event . started)))) =20 ;; Update only if we're switching to a different status; otherwi= se ;; leave things unchanged. This ensures that 'stoptime' remains= valid ;; and doesn't change every time we mark DRV as 'succeeded' seve= ral ;; times in a row, for instance. - (if log-file - (sqlite-exec db "UPDATE Builds SET stoptime=3D" now - ", status=3D" status ", log=3D" log-file - "WHERE derivation=3D" drv "AND status !=3D " st= atus ";") - (sqlite-exec db "UPDATE Builds SET stoptime=3D" now - ", status=3D" status - "WHERE derivation=3D" drv " AND status !=3D " s= tatus - ";"))))) + (begin + (if log-file + (sqlite-exec db "UPDATE Builds SET stoptime=3D" now + ", status=3D" status ", log=3D" log-file + "WHERE derivation=3D" drv "AND status !=3D " = status ";") + (sqlite-exec db "UPDATE Builds SET stoptime=3D" now + ", status=3D" status + "WHERE derivation=3D" drv " AND status !=3D "= status + ";")) + (unless (eq? (changes-count db) 0) + (db-add-event 'build + now + `((#:derivation . ,drv) + (#:event . ,(assq-ref status-names + status))))))))) =20 (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))))))) =20 +(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 =3D 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-<=3D-to id) + (with-db-critical-section db + (sqlite-exec + db + "DELETE FROM EventsOutbox WHERE event_id <=3D " id ";"))) + (define (db-get-pending-derivations) "Return the list of derivation file names corresponding to pending bui= lds in the database. The returned list is guaranteed to not have any duplicate= s." 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)))) =20 +(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 =C2=A9 2019 Christopher Baines +;;; +;;; 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 . + +(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 #:tim= estamp)) + ,@(json-string->scm + (assq-ref event #:event_json)))) + events-to-send)))))) + (db-delete-events-from-outbox-with-ids-<=3D-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) ); =20 +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, timest= amp 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; --=20 2.23.0