mirror of
git://git.savannah.gnu.org/guix/guix-cuirass.git
synced 2023-12-14 06:03:04 +01:00
df2d13621f
* .dir-locals.el: Add "with-queue-writer-worker".
* bin/cuirass.in: Modify "with-queue-writer-worker" scope to include the
web-server operations.
* src/cuirass/database.scm (with-db-writer-worker-thread): Export it.
(with-db-writer-worker-thread/force): New macro.
(db-add-input, db-add-checkout, db-add-specification, db-remove-specification,
db-add-evaluation, db-abort-pending-evaluations, db-set-evaluation-status,
db-set-evaluation-time, db-add-output, db-add-build-product, db-add-event,
db-delete-events-with-ids-<=-to): Use "with-db-writer-worker-thread" or
"with-db-writer-worker-thread/force" instead of "with-db-worker-thread".
* src/cuirass/metrics.scm (db-update-metrics): Ditto.
* tests/database.scm ("db-init"): Set "%db-writer-channel".
* tests/http.scm ("db-init"): Ditto.
* tests/metrics.scm ("db-init"): Ditto.
370 lines
13 KiB
Scheme
370 lines
13 KiB
Scheme
;;; metrics.scm -- Compute and store metrics.
|
||
;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
|
||
;;;
|
||
;;; 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 average evaluation duration for SPEC. Limit the average
|
||
computation to the most recent LIMIT records if this argument is set."
|
||
(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 ORDER BY rowid DESC
|
||
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(timestamp, 'unixepoch') = date('now', '-1 day') AND
|
||
date(stoptime, 'unixepoch') = date('now', '-1 day');")))
|
||
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
|
||
|
||
(define (db-new-derivations-previous-day _)
|
||
"Return the new derivations count of the previous day."
|
||
(with-db-worker-thread db
|
||
(let ((rows (sqlite-exec db "SELECT COUNT(*) from Builds
|
||
WHERE date(timestamp, 'unixepoch') = date('now', '-1 day');")))
|
||
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
|
||
|
||
(define (db-pending-builds _)
|
||
"Return the current pending builds count."
|
||
(with-db-worker-thread db
|
||
(let ((rows (sqlite-exec db "SELECT COUNT(*) from Builds
|
||
WHERE status < 0;")))
|
||
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
|
||
|
||
(define* (db-percentage-failed-eval-per-spec spec #:key limit)
|
||
"Return the failed evaluation percentage for SPEC. If LIMIT is set, limit
|
||
the percentage computation to the most recent LIMIT records."
|
||
(with-db-worker-thread db
|
||
(let ((rows (sqlite-exec db "\
|
||
SELECT 100 * CAST(SUM(status > 0) as float) / COUNT(*) FROM
|
||
(SELECT status from Evaluations WHERE specification = " spec
|
||
" ORDER BY rowid DESC LIMIT " (or limit -1) ");")))
|
||
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
|
||
|
||
(define* (db-average-build-start-time-per-eval eval)
|
||
"Return the average build start time for the given EVAL."
|
||
(with-db-worker-thread db
|
||
(let ((rows (sqlite-exec db "\
|
||
SELECT AVG(B.starttime - E.evaltime) FROM
|
||
(SELECT id, evaltime
|
||
FROM Evaluations WHERE id = " eval ") E
|
||
LEFT JOIN Builds as B
|
||
ON E.id = B.evaluation and B.starttime > 0
|
||
GROUP BY E.id;")))
|
||
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
|
||
|
||
(define* (db-average-build-complete-time-per-eval eval)
|
||
"Return the average build complete time for the given EVAL."
|
||
(with-db-worker-thread db
|
||
(let ((rows (sqlite-exec db "\
|
||
SELECT AVG(B.stoptime - E.evaltime) FROM
|
||
(SELECT id, evaltime
|
||
FROM Evaluations WHERE id = " eval ") E
|
||
LEFT JOIN Builds as B
|
||
ON E.id = B.evaluation and B.stoptime > 0
|
||
GROUP BY E.id;")))
|
||
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
|
||
|
||
(define* (db-evaluation-completion-speed eval)
|
||
"Return the evaluation completion speed of the given EVAL. The speed is
|
||
expressed in builds per hour."
|
||
;; completion_speed = 60 * completed_builds / eval_duration.
|
||
;;
|
||
;; evaluation_duration (seconds) = current_time - eval_start_time
|
||
;; If some evaluations builds are not completed.
|
||
;;
|
||
;; evaluation_duration (seconds) = max(build_stop_time) - eval_start_time
|
||
;; If the evaluation builds are all completed.
|
||
(with-db-worker-thread db
|
||
(let ((rows (sqlite-exec db "\
|
||
SELECT
|
||
3600.0 * SUM(B.status = 0) /
|
||
(CASE SUM(status < 0)
|
||
WHEN 0 THEN MAX(stoptime)
|
||
ELSE strftime('%s', 'now')
|
||
END - E.evaltime) FROM
|
||
(SELECT id, evaltime
|
||
FROM Evaluations WHERE id = " eval ") E
|
||
LEFT JOIN Builds as B
|
||
ON E.id = B.evaluation and B.stoptime > 0
|
||
GROUP BY E.id;")))
|
||
(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)))))
|
||
|
||
(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)))))
|
||
|
||
(define* (db-latest-evaluations #:key (days 3))
|
||
"Return the successful evaluations added during the previous DAYS."
|
||
(with-db-worker-thread db
|
||
(let ((query (format #f "SELECT id from Evaluations
|
||
WHERE date(timestamp, 'unixepoch') > date('now', '-~a day') AND
|
||
status = 0 ORDER BY rowid DESC" days)))
|
||
(let loop ((rows (sqlite-exec db query))
|
||
(evaluations '()))
|
||
(match rows
|
||
(() (reverse evaluations))
|
||
((#(id) . rest)
|
||
(loop rest
|
||
(cons id evaluations))))))))
|
||
|
||
|
||
;;;
|
||
;;; Definitions.
|
||
;;;
|
||
|
||
;; XXX: Make sure to add new metrics at the *end of the list* only, as they
|
||
;; are indexed by position in database.
|
||
(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 per day.
|
||
(metric
|
||
(id 'builds-per-day)
|
||
(compute-proc db-builds-previous-day)
|
||
(field-proc db-previous-day-timestamp))
|
||
|
||
;; Pending builds count.
|
||
(metric
|
||
(id 'pending-builds)
|
||
(compute-proc db-pending-builds)
|
||
(field-proc db-current-day-timestamp))
|
||
|
||
;; New derivations per day.
|
||
(metric
|
||
(id 'new-derivations-per-day)
|
||
(compute-proc db-new-derivations-previous-day)
|
||
(field-proc db-previous-day-timestamp))
|
||
|
||
;; Percentage of failed evaluations per specification.
|
||
(metric
|
||
(id 'percentage-failure-10-last-eval-per-spec)
|
||
(compute-proc
|
||
(cut db-percentage-failed-eval-per-spec <> #:limit 10)))
|
||
|
||
(metric
|
||
(id 'percentage-failure-100-last-eval-per-spec)
|
||
(compute-proc
|
||
(cut db-percentage-failed-eval-per-spec <> #:limit 100)))
|
||
|
||
(metric
|
||
(id 'percentage-failed-eval-per-spec)
|
||
(compute-proc db-percentage-failed-eval-per-spec))
|
||
|
||
;; Average time to start a build for an evaluation.
|
||
(metric
|
||
(id 'average-eval-build-start-time)
|
||
(compute-proc db-average-build-start-time-per-eval))
|
||
|
||
;; Average time to complete a build for an evaluation.
|
||
(metric
|
||
(id 'average-eval-build-complete-time)
|
||
(compute-proc db-average-build-complete-time-per-eval))
|
||
|
||
;; Evaluation completion speed in builds/hour.
|
||
(metric
|
||
(id 'evaluation-completion-speed)
|
||
(compute-proc db-evaluation-completion-speed))))
|
||
|
||
(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 "rowid DESC"))
|
||
"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."
|
||
(with-db-writer-worker-thread/force db
|
||
;; We can not update all evaluations metrics for performance reasons.
|
||
;; Limit to the evaluations that were added during the past three days.
|
||
(let ((specifications
|
||
(map (cut assq-ref <> #:name) (db-get-specifications)))
|
||
(evaluations (db-latest-evaluations)))
|
||
(sqlite-exec db "BEGIN TRANSACTION;")
|
||
|
||
(db-update-metric 'builds-per-day)
|
||
(db-update-metric 'new-derivations-per-day)
|
||
(db-update-metric 'pending-builds)
|
||
|
||
;; 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)
|
||
|
||
(db-update-metric
|
||
'percentage-failure-10-last-eval-per-spec spec)
|
||
(db-update-metric
|
||
'percentage-failure-100-last-eval-per-spec spec)
|
||
(db-update-metric
|
||
'percentage-failed-eval-per-spec spec))
|
||
specifications)
|
||
|
||
;; Update evaluation related metrics.
|
||
(for-each (lambda (evaluation)
|
||
(db-update-metric
|
||
'average-eval-build-start-time evaluation)
|
||
(db-update-metric
|
||
'average-eval-build-complete-time evaluation)
|
||
(db-update-metric
|
||
'evaluation-completion-speed evaluation))
|
||
evaluations)
|
||
|
||
(sqlite-exec db "COMMIT;"))))
|