[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Mon, 14 Sep 2020 08:35:35 -0400 (EDT) |
branch: master
commit cf11b73db00678b45b70108768138d0fb74d9506
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Mon Sep 14 14:25:23 2020 +0200
Add metrics support.
* Makefile.am: Add "upgrade-11.sql", "chart.js" and "metrics.js".
* bin/cuirass.in (main): Add 'metrics fiber.
* src/cuirass/http.scm (%file-white-list): Add "js/chart.js".
(url-handler): Add "/metrics" route.
* src/cuirass/metrics.scm: New file.
* src/cuirass/templates.scm (html-page): Add a "Global metrics" sub-menu to
"Status" dropdown menu.
(make-line-chart, global-metrics-content): New procedures.
* src/schema.sql (Metrics): New table.
* src/sql/upgrade-11.sql: New file.
* src/static/js/chart.js: New file.
---
Makefile.am | 7 +-
bin/cuirass.in | 12 ++-
src/cuirass/http.scm | 25 +++++-
src/cuirass/metrics.scm | 199 ++++++++++++++++++++++++++++++++++++++++++++++
src/cuirass/templates.scm | 78 +++++++++++++++++-
src/schema.sql | 8 ++
src/sql/upgrade-11.sql | 11 +++
src/static/js/chart.js | 7 ++
8 files changed, 343 insertions(+), 4 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 9c86276..df24342 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -40,12 +40,14 @@ staticdir = $(pkgdatadir)/static
cssdir = $(staticdir)/css
fontsdir = $(staticdir)/fonts
imagesdir = $(staticdir)/images
+jsdir = $(staticdir)/js
dist_pkgmodule_DATA = \
src/cuirass/base.scm \
src/cuirass/database.scm \
src/cuirass/http.scm \
src/cuirass/logging.scm \
+ src/cuirass/metrics.scm \
src/cuirass/send-events.scm \
src/cuirass/ui.scm \
src/cuirass/utils.scm \
@@ -76,7 +78,8 @@ dist_sql_DATA = \
src/sql/upgrade-7.sql \
src/sql/upgrade-8.sql \
src/sql/upgrade-9.sql \
- src/sql/upgrade-10.sql
+ src/sql/upgrade-10.sql \
+ src/sql/upgrade-11.sql
dist_css_DATA = \
src/static/css/cuirass.css \
@@ -90,6 +93,8 @@ dist_fonts_DATA = \
src/static/fonts/open-iconic.woff
dist_images_DATA = \
src/static/images/logo.png
+dist_js_DATA = \
+ src/static/js/chart.js
TEST_EXTENSIONS = .scm .sh
AM_TESTS_ENVIRONMENT = \
diff --git a/bin/cuirass.in b/bin/cuirass.in
index c4bcfaa..9c856fc 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -29,6 +29,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(use-modules (cuirass)
(cuirass ui)
(cuirass logging)
+ (cuirass metrics)
(cuirass utils)
(guix ui)
((guix build utils) #:select (mkdir-p))
@@ -183,11 +184,20 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(lambda ()
(while #t
(process-specs (db-get-specifications))
- (log-message "next evaluation in ~a
seconds" interval)
+ (log-message
+ "next evaluation in ~a seconds" interval)
(sleep interval)))))
(spawn-fiber
(essential-task
+ 'metrics exit-channel
+ (lambda ()
+ (while #t
+ (db-update-metrics)
+ (sleep 3600)))))
+
+ (spawn-fiber
+ (essential-task
'monitor exit-channel
(lambda ()
(while #t
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 98696a6..cc88f04 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -25,6 +25,7 @@
#:use-module (cuirass config)
#:use-module (cuirass database)
#:use-module ((cuirass base) #:select (evaluation-log-file))
+ #:use-module (cuirass metrics)
#:use-module (cuirass utils)
#:use-module (cuirass logging)
#:use-module (srfi srfi-1)
@@ -72,7 +73,8 @@
"css/open-iconic-bootstrap.css"
"fonts/open-iconic.otf"
"fonts/open-iconic.woff"
- "images/logo.png"))
+ "images/logo.png"
+ "js/chart.js"))
(define (build->hydra-build build)
"Convert BUILD to an assoc list matching hydra API format."
@@ -604,6 +606,27 @@ Hydra format."
(respond-json-with-error 500 "No build found.")))
(respond-json-with-error 500 "Query parameter not provided."))))
+ (('GET "metrics")
+ (respond-html
+ (html-page
+ "Global metrics"
+ (let ((builds-per-day
+ (db-get-metrics-with-id 'builds-previous-day
+ #:limit 10
+ #:order "field"))
+ (avg-eval-durations
+ (list
+ (db-get-metrics-with-id
+ 'average-10-last-eval-duration-per-spec)
+ (db-get-metrics-with-id
+ 'average-100-last-eval-duration-per-spec)
+ (db-get-metrics-with-id
+ 'average-eval-duration-per-spec))))
+ (global-metrics-content
+ #:avg-eval-durations avg-eval-durations
+ #:builds-per-day builds-per-day))
+ '())))
+
(('GET "status")
(respond-html
(html-page
diff --git a/src/cuirass/metrics.scm b/src/cuirass/metrics.scm
new file mode 100644
index 0000000..c5880e3
--- /dev/null
+++ b/src/cuirass/metrics.scm
@@ -0,0 +1,199 @@
+;;; metrics.scm -- Compute and store metrics.
+;;; 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 metrics)
+ #:use-module (cuirass database)
+ #:use-module (cuirass logging)
+ #:use-module (guix records)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:export (metric
+ metric?
+ metric-id
+ metric-proc
+
+ %metrics
+ metric->type
+ compute-metric
+
+ db-get-metric
+ db-get-metrics-with-id
+ db-update-metric
+ db-update-metrics))
+
+
+;;;
+;;; Metric record.
+;;;
+
+(define-record-type* <metric> metric make-metric
+ metric?
+ (id metric-id)
+ (compute-proc metric-compute-proc)
+ (field-proc metric-field-proc
+ (default #f)))
+
+
+;;;
+;;; Database procedures.
+;;;
+
+(define* (db-average-eval-duration-per-spec spec #:key limit)
+ "Return the evaluation duration of EVAL."
+ (with-db-worker-thread db
+ (let ((rows (sqlite-exec db "SELECT AVG(duration) FROM
+(SELECT (evaltime - timestamp) as duration
+FROM Evaluations WHERE specification = " spec
+" AND evaltime != 0 LIMIT " (or limit -1) ");")))
+ (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+
+(define (db-builds-previous-day _)
+ "Return the builds count of the previous day."
+ (with-db-worker-thread db
+ (let ((rows (sqlite-exec db "SELECT COUNT(*) from Builds
+WHERE date(stoptime, 'unixepoch') = date('now', '-1 day');")))
+ (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+
+(define (db-previous-day-timestamp)
+ "Return the timestamp of the previous day."
+ (with-db-worker-thread db
+ (let ((rows (sqlite-exec db "SELECT strftime('%s',
+date('now', '-1 day'));")))
+ (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+
+
+;;;
+;;; Definitions.
+;;;
+
+(define %metrics
+ (list
+ ;; Average evaluation duration per specification.
+ (metric
+ (id 'average-10-last-eval-duration-per-spec)
+ (compute-proc
+ (cut db-average-eval-duration-per-spec <> #:limit 10)))
+ (metric
+ (id 'average-100-last-eval-duration-per-spec)
+ (compute-proc
+ (cut db-average-eval-duration-per-spec <> #:limit 100)))
+ (metric
+ (id 'average-eval-duration-per-spec)
+ (compute-proc db-average-eval-duration-per-spec))
+
+ ;; Builds count over last 24 hours.
+ (metric
+ (id 'builds-previous-day)
+ (compute-proc db-builds-previous-day)
+ (field-proc db-previous-day-timestamp))))
+
+(define (metric->type metric)
+ "Return the index of the given METRIC in %metrics list. This index is used
+to identify the metric type in database."
+ (list-index
+ (lambda (cur-metric)
+ (eq? (metric-id cur-metric) (metric-id metric)))
+ %metrics))
+
+(define (find-metric id)
+ "Find the metric with the given ID."
+ (find (lambda (metric)
+ (eq? (metric-id metric) id))
+ %metrics))
+
+(define* (compute-metric metric field)
+ "Compute the given METRIC on FIELD and return the associated value."
+ (let ((compute (metric-compute-proc metric)))
+ (compute field)))
+
+(define* (db-get-metric id field)
+ "Return the metric with the given ID and FIELD."
+ (let* ((metric (find-metric id))
+ (type (metric->type metric)))
+ (with-db-worker-thread db
+ (let ((rows (sqlite-exec db "SELECT value from Metrics
+WHERE type = " type " AND field = " field ";")))
+ (and=> (expect-one-row rows) (cut vector-ref <> 0))))))
+
+(define* (db-get-metrics-with-id id
+ #:key
+ limit
+ (order "timestamp"))
+ "Return the metrics with the given ID. If LIMIT is set, the resulting list
+if restricted to LIMIT records."
+ (let* ((metric (find-metric id))
+ (type (metric->type metric))
+ (limit (or limit -1)))
+ (with-db-worker-thread db
+ (let ((query (format #f "SELECT field, value from Metrics
+WHERE type = ? ORDER BY ~a LIMIT ~a" order limit)))
+ (let loop ((rows (%sqlite-exec db query type))
+ (metrics '()))
+ (match rows
+ (() (reverse metrics))
+ ((#(field value) . rest)
+ (loop rest
+ `((,field . ,value)
+ ,@metrics)))))))))
+
+(define* (db-update-metric id #:optional field)
+ "Compute and update the value of the metric ID in database.
+
+ FIELD is optional and can be the id of a database object such as an
+evaluation or a specification that the METRIC applies to. If FIELD is not
+passed then the METRIC may provide a FIELD-PROC to compute it. It is useful
+for periodical metrics for instance."
+ (define now
+ (time-second (current-time time-utc)))
+
+ (let* ((metric (find-metric id))
+ (field-proc (metric-field-proc metric))
+ (field (or field (field-proc)))
+ (value (compute-metric metric field)))
+ (if value
+ (begin
+ (log-message "Updating metric ~a (~a) to ~a."
+ (symbol->string id) field value)
+ (with-db-worker-thread db
+ (sqlite-exec db "\
+INSERT OR REPLACE INTO Metrics (field, type, value,
+timestamp) VALUES ("
+ field ", "
+ (metric->type metric) ", "
+ value ", "
+ now ");")
+ (last-insert-rowid db)))
+ (log-message "Failed to compute metric ~a (~a)."
+ (symbol->string id) field))))
+
+(define (db-update-metrics)
+ "Compute and update all available metrics in database."
+ (define specifications
+ (map (cut assq-ref <> #:name) (db-get-specifications)))
+
+ (db-update-metric 'builds-previous-day)
+
+ ;; Update specification related metrics.
+ (for-each (lambda (spec)
+ (db-update-metric
+ 'average-10-last-eval-duration-per-spec spec)
+ (db-update-metric
+ 'average-100-last-eval-duration-per-spec spec)
+ (db-update-metric
+ 'average-eval-duration-per-spec spec))
+ specifications))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 3128b45..e5a7526 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -26,6 +26,7 @@
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
+ #:use-module (json)
#:use-module (web uri)
#:use-module (guix derivations)
#:use-module (guix progress)
@@ -40,7 +41,8 @@
build-search-results-table
build-details
evaluation-build-table
- running-builds-table))
+ running-builds-table
+ global-metrics-content))
(define (navigation-items navigation)
(match navigation
@@ -134,6 +136,9 @@ system whose names start with " (code "guile-") ":" (br)
(div (@ (class "dropdown-menu")
(aria-labelledby "navbarDropdow"))
(a (@ (class "dropdown-item")
+ (href "/metrics"))
+ "Global metrics")
+ (a (@ (class "dropdown-item")
(href "/status"))
"Running builds")))
(li (@ (class "nav-item"))
@@ -820,3 +825,74 @@ and BUILD-MAX are global minimal and maximal row
identifiers."
(th (@ (scope "col")) "System")))
(tbody
,(map build-row builds)))))))
+
+(define* (make-line-chart id data
+ #:key
+ title
+ color)
+ (let* ((scales `((xAxes
+ . ,(vector '((type . "time")
+ (time . ((unit . "day")))
+ (display . #t)
+ (distribution . "series")
+ (scaleLabel
+ . ((display . #t)
+ (labelString . "Day"))))))
+ (yAxes
+ . ,(vector '((display . #t)
+ (scaleLabel
+ . ((display . #t)
+ (labelString . "Builds"))))))))
+ (chart `((type . "line")
+ (data . ((datasets . ,(vector `((fill . #f)
+ (borderColor . ,color)
+ (data . ,data))))))
+ (options . ((responsive . #t)
+ (tooltips . ((enabled . #f)))
+ (legend . ((display . #f)))
+ (title . ((display . #t)
+ (text . ,title)))
+ (scales . ,scales))))))
+ `((script ,(format #f "window.onload = function() {\
+window.~a = new Chart\
+(document.getElementById('~a').getContext('2d'), ~a);\
+};" id id (scm->json-string chart))))))
+
+(define* (global-metrics-content #:key
+ builds-per-day
+ avg-eval-durations)
+ (define (avg-eval-duration-row . eval-durations)
+ (let ((spec (match eval-durations
+ (((spec . _) . rest) spec))))
+ `(tr (td ,spec)
+ ,@(map (lambda (duration)
+ `(td ,(number->string
+ (nearest-exact-integer duration))))
+ (map cdr eval-durations)))))
+
+ (define builds-json-scm
+ (apply vector
+ (map (match-lambda
+ ((field . value)
+ `((x . ,(* field 1000)) (y . ,value))))
+ builds-per-day)))
+
+ (let ((builds-chart "builds_per_day"))
+ `((div
+ (p (@ (class "lead")) "Global metrics")
+ (h6 "Average evaluation duration per specification (seconds).")
+ (table
+ (@ (class "table table-sm table-hover table-striped"))
+ (thead (tr (th (@ (scope "col")) "Specification")
+ (th (@ (scope "col")) "10 last evaluations")
+ (th (@ (scope "col")) "100 last evaluations")
+ (th (@ (scope "col")) "All evaluations")))
+ (tbody
+ ,(apply map avg-eval-duration-row avg-eval-durations)))
+ (br)
+ (h6 "Build speed.")
+ (canvas (@ (id ,builds-chart)))
+ (script (@ (src "/static/js/chart.js")))
+ ,@(make-line-chart builds-chart builds-json-scm
+ #:title "Builds per day"
+ #:color "#3e95cd")))))
diff --git a/src/schema.sql b/src/schema.sql
index 335a6d4..ed5893e 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -70,6 +70,14 @@ CREATE TABLE Builds (
FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
);
+CREATE TABLE Metrics (
+ field INTEGER NOT NULL,
+ type INTEGER NOT NULL,
+ value DOUBLE PRECISION NOT NULL,
+ timestamp INTEGER NOT NULL,
+ PRIMARY KEY (field, type)
+);
+
CREATE TABLE BuildProducts (
build INTEGER NOT NULL,
type TEXT NOT NULL,
diff --git a/src/sql/upgrade-11.sql b/src/sql/upgrade-11.sql
new file mode 100644
index 0000000..22f2dac
--- /dev/null
+++ b/src/sql/upgrade-11.sql
@@ -0,0 +1,11 @@
+BEGIN TRANSACTION;
+
+CREATE TABLE Metrics (
+ field INTEGER NOT NULL,
+ type INTEGER NOT NULL,
+ value DOUBLE PRECISION NOT NULL,
+ timestamp INTEGER NOT NULL,
+ PRIMARY KEY (field, type)
+);
+
+COMMIT;
diff --git a/src/static/js/chart.js b/src/static/js/chart.js
new file mode 100644
index 0000000..55d9eb0
--- /dev/null
+++ b/src/static/js/chart.js
@@ -0,0 +1,7 @@
+/*!
+ * Chart.js v2.9.3
+ * https://www.chartjs.org
+ * (c) 2019 Chart.js Contributors
+ * Released under the MIT License
+ */
+!function(t,e){"object"==typeof exports&&"undefined"!=typeof
module?module.exports=e():"function"==typeof
define&&define.amd?define(e):(t=t||self).Chart=e()}(this,(function(){"use
strict";"undefined"!=typeof globalThis?globalThis:"undefined"!=typeof
window?window:"undefined"!=typeof global?global:"undefined"!=typeof
self&&self;function t(){throw new Error("Dynamic requires are not currently
supported by rollup-plugin-commonjs")}function e(t,e){return
t(e={exports:{}},e.exports),e.exports [...]