[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Fri, 11 Sep 2020 09:53:07 -0400 (EDT) |
branch: wip-metrics
commit 3e2455c27b38e96c443b2a7fd1b3a614dfae7876
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Fri Sep 11 15:52:49 2020 +0200
Add metrics support.
---
Makefile.am | 4 +-
src/cuirass/base.scm | 2 +
src/cuirass/database.scm | 2 +
src/cuirass/http.scm | 11 +++
src/cuirass/metrics.scm | 168 ++++++++++++++++++++++++++++++++++++++++++++++
src/cuirass/templates.scm | 12 +++-
src/schema.sql | 8 +++
src/sql/upgrade-11.sql | 11 +++
8 files changed, 216 insertions(+), 2 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 9c86276..7e902be 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -46,6 +46,7 @@ dist_pkgmodule_DATA = \
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 +77,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 \
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index ec1b467..47f1d63 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -24,6 +24,7 @@
#:use-module (fibers)
#:use-module (cuirass logging)
#:use-module (cuirass database)
+ #:use-module (cuirass metrics)
#:use-module (cuirass utils)
#:use-module ((cuirass config) #:select (%localstatedir))
#:use-module (gnu packages)
@@ -835,6 +836,7 @@ by PRODUCT-SPECS."
(with-store store
(let ((jobs (evaluate store spec eval-id checkouts)))
(db-set-evaluation-time eval-id)
+ (db-update-metric 'eval-duration eval-id)
(log-message "building ~a jobs for '~a'"
(length jobs) name)
(build-packages store jobs eval-id))))))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index c1941a1..e554ec4 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -45,6 +45,8 @@
db-get-specification
db-get-specifications
evaluation-status
+ last-insert-rowid
+ expect-one-row
db-add-evaluation
db-abort-pending-evaluations
db-set-evaluation-status
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 98696a6..959949b 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)
@@ -604,6 +605,16 @@ 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-last-24-hours)))
+ (global-metrics-content
+ #: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..d25b55f
--- /dev/null
+++ b/src/cuirass/metrics.scm
@@ -0,0 +1,168 @@
+;;; 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 (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))
+
+
+;;;
+;;; 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(evaltime - timestamp)
+FROM Evaluations WHERE specification = " spec
+" AND evaltime != 0 LIMIT " (or limit -1))))
+ (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+
+(define (db-builds-last-24-hours _)
+ "Return the builds count last 24 hours."
+ (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-current-day-timestamp)
+ "Return the timestamp of the current day."
+ (with-db-worker-thread db
+ (let ((rows (sqlite-exec db "SELECT strftime('%s', date('now'))")))
+ (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+
+
+;;;
+;;; Definitions.
+;;;
+
+(define %metrics
+ (list
+ ;; Average evaluation duration per specification.
+ (metric
+ (id 'average-eval-duration-per-spec)
+ (compute-proc db-average-eval-duration-per-spec))
+ (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)))
+
+ ;; Builds count over last 24 hours.
+ (metric
+ (id 'builds-last-24-hours)
+ (compute-proc db-builds-last-24-hours)
+ (field-proc db-current-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)
+ "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 loop ((rows (sqlite-exec db "SELECT field, value from Metrics
+WHERE type = " type " LIMIT " limit))
+ (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)))
+ (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))))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 3128b45..983c82a 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -40,7 +40,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 +135,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 +824,9 @@ and BUILD-MAX are global minimal and maximal row
identifiers."
(th (@ (scope "col")) "System")))
(tbody
,(map build-row builds)))))))
+
+(define* (global-metrics-content
+ #:key builds-per-day)
+ `((div
+ (p (@ (class "lead")) "Global metrics")
+ (h6 "Build speed"))))
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;