495 lines
17 KiB
Scheme
495 lines
17 KiB
Scheme
;;; Guile Prometheus
|
|
;;;
|
|
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
|
|
;;;
|
|
;;; This file is part of the Guile Prometheus client.
|
|
;;;
|
|
;;; The Guile Prometheus client 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.
|
|
;;;
|
|
;;; The Guile Prometheus client 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 the guix-data-service. If not, see
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (prometheus)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 format)
|
|
#:use-module (ice-9 threads)
|
|
#:use-module (ice-9 exceptions)
|
|
#:export (make-metrics-registry
|
|
metrics-registry-fetch-metric
|
|
write-metrics
|
|
write-textfile
|
|
|
|
make-counter-metric
|
|
make-gauge-metric
|
|
make-histogram-metric
|
|
|
|
metric-increment
|
|
metric-decrement
|
|
metric-set
|
|
metric-observe
|
|
|
|
call-with-duration-metric))
|
|
|
|
(define-record-type <metrics-registry>
|
|
(make-metrics-registry-record metrics-hash namespace)
|
|
metrics-registry?
|
|
(metrics-hash metrics-registry-metrics-hash)
|
|
(namespace metrics-registry-namespace))
|
|
|
|
(define* (make-metrics-registry #:key namespace)
|
|
"Create a metrics registry. This record stores named metrics, and
|
|
can have an optional @var{namespace}.
|
|
|
|
The @var{namespace} is used when writing out the metrics, each metric
|
|
name will be prefixed by the @var{namespace}, separated with an
|
|
underscore. Convention for naming metrics is that the @var{namespace}
|
|
should be a single word that identifies the application or area the
|
|
metrics relate to."
|
|
(make-metrics-registry-record (make-hash-table)
|
|
namespace))
|
|
|
|
(define-record-type <metric>
|
|
(make-metric type name values registry docstring labels label-preset-values
|
|
mutex)
|
|
metric?
|
|
(type metric-type)
|
|
(name metric-name)
|
|
(values metric-values)
|
|
(registry metric-registry)
|
|
(docstring metric-docstring)
|
|
(labels metric-labels)
|
|
(label-preset-values metric-label-preset-values)
|
|
(mutex metric-mutex))
|
|
|
|
(define (metrics-registry-add-metric registry name metric)
|
|
(let ((metrics-hash
|
|
(metrics-registry-metrics-hash registry)))
|
|
(when (hash-ref metrics-hash name)
|
|
(raise-exception
|
|
(make-exception-with-message
|
|
(simple-format #f "metric ~A already exists"
|
|
name))))
|
|
|
|
(hash-set! metrics-hash name metric)
|
|
|
|
metric))
|
|
|
|
(define (metrics-registry-fetch-metric registry name)
|
|
"Fetch a metric by @var{name} from the @var{registry}"
|
|
(hash-ref (metrics-registry-metrics-hash registry)
|
|
name))
|
|
|
|
(define* (make-counter-metric registry name
|
|
#:key
|
|
docstring
|
|
(labels '())
|
|
(label-preset-values '()))
|
|
"Make a counter metric, to track a value that only increases aside
|
|
from when it resets to 0 normally when the collector restarts. The
|
|
metric is associated with the specified @var{registry} under the given
|
|
@var{name}.
|
|
|
|
A metric record is returned, the value of the metric can be changed
|
|
with the @code{metric-increment} procedure.
|
|
|
|
The following keyword arguments can be used with all metrics:
|
|
@var{#:docstring} a short description of the metric, @var{#:labels} a
|
|
list of label names to be permitted for this metric and
|
|
@var{#:label-preset-values} default values for labels."
|
|
(metrics-registry-add-metric
|
|
registry
|
|
name
|
|
(make-metric 'counter
|
|
name
|
|
(make-hash-table)
|
|
registry
|
|
docstring
|
|
labels
|
|
label-preset-values
|
|
(make-mutex))))
|
|
|
|
(define* (make-gauge-metric registry name
|
|
#:key
|
|
docstring
|
|
(labels '())
|
|
(label-preset-values '()))
|
|
"Make a gauge metric, to track a value that can go up or down. The
|
|
metric is associated with the specified @var{registry} under the given
|
|
@var{name}.
|
|
|
|
A metric record is returned, the value of the metric can be changed
|
|
with the @code{metric-increment}, @code{metric-decrement} or
|
|
@code{metric-set} procedures.
|
|
|
|
The following keyword arguments can be used with all metrics:
|
|
@var{#:docstring} a short description of the metric, @var{#:labels} a
|
|
list of label names to be permitted for this metric and
|
|
@var{#:label-preset-values} default values for labels."
|
|
(metrics-registry-add-metric
|
|
registry
|
|
name
|
|
(make-metric 'gauge
|
|
name
|
|
(make-hash-table)
|
|
registry
|
|
docstring
|
|
(map canonicalise-label labels)
|
|
(canonicalise-label-values label-preset-values)
|
|
(make-mutex))))
|
|
|
|
(define-record-type <histogram-metric-type>
|
|
(make-histogram-metric-type buckets)
|
|
histogram-metric-type?
|
|
(buckets histogram-metric-type-buckets))
|
|
|
|
(define-record-type <histogram-values>
|
|
(make-histogram-values buckets sum count)
|
|
histogram-values?
|
|
(buckets histogram-values-buckets)
|
|
(sum histogram-values-sum set-histogram-values-sum!)
|
|
(count histogram-values-count set-histogram-values-count!))
|
|
|
|
(define %default-histogram-buckets
|
|
;; The default buckets used in other client libraries
|
|
(list 0.005 0.01 0.025 0.05 0.1 0.25 0.5 1 2.5 5 10 (inf)))
|
|
|
|
(define* (make-histogram-metric registry name
|
|
#:key
|
|
(buckets %default-histogram-buckets)
|
|
docstring
|
|
(labels '())
|
|
(label-preset-values '()))
|
|
"Make a histogram metric, to track observations of values in a set
|
|
of buckets. Quantiles can be calculated from the histogram, which
|
|
makes this metric type good for observing things like durations.
|
|
|
|
Internally, this metric represents multiple metrics. One for each
|
|
bucket, plus one to record the total of all observed values and
|
|
another to count the number of observations.
|
|
|
|
A metric record is returned, this can be used with the
|
|
@code{metric-observe} procedure.
|
|
|
|
The following keyword arguments can be used with all metrics:
|
|
@var{#:docstring} a short description of the metric, @var{#:labels} a
|
|
list of label names to be permitted for this metric and
|
|
@var{#:label-preset-values} default values for labels."
|
|
;; TODO validate buckets
|
|
|
|
(metrics-registry-add-metric
|
|
registry
|
|
name
|
|
(make-metric (make-histogram-metric-type buckets)
|
|
name
|
|
(make-hash-table)
|
|
registry
|
|
docstring
|
|
labels
|
|
label-preset-values
|
|
(make-mutex))))
|
|
|
|
(define (canonicalise-label label)
|
|
(call-with-output-string
|
|
(lambda (port)
|
|
(display label port))))
|
|
|
|
(define (canonicalise-label-value value)
|
|
(call-with-output-string
|
|
(lambda (port)
|
|
(display value port))))
|
|
|
|
(define (canonicalise-label-values label-values)
|
|
(let ((canonical-label-values
|
|
(map (match-lambda
|
|
((k . v)
|
|
(cons (canonicalise-label k)
|
|
(canonicalise-label-value v))))
|
|
label-values)))
|
|
(let loop ((lst (map car canonical-label-values)))
|
|
(unless (null? lst)
|
|
(let ((element (car lst))
|
|
(rest (cdr lst)))
|
|
(when (member element rest string=?)
|
|
(raise-exception
|
|
(make-exception-with-message
|
|
(simple-format
|
|
#f "label value specified multiple times: ~A"
|
|
element))))
|
|
|
|
(loop rest))))
|
|
|
|
canonical-label-values))
|
|
|
|
(define* (metric-increment metric
|
|
#:key
|
|
(by 1)
|
|
(label-values '()))
|
|
"Increment the value of the given @var{metric} by 1 (or the @var{#:by} value).
|
|
|
|
This procedure can be used with counter or gauge metrics.
|
|
|
|
To specify values for the labels, pass an alist as
|
|
@var{#:label-values} where the keys are the label names, and the
|
|
values are the values."
|
|
(unless (memq (metric-type metric)
|
|
'(counter gauge))
|
|
(error "can only increment counter and gauge metrics"))
|
|
|
|
(unless (positive? by)
|
|
(error "can only increment positive values"))
|
|
|
|
(let ((canonical-labels
|
|
(canonicalise-label-values label-values))
|
|
(hash
|
|
(metric-values metric)))
|
|
(with-mutex (metric-mutex metric)
|
|
(hash-set! hash
|
|
canonical-labels
|
|
(+ by
|
|
(or (hash-ref hash canonical-labels)
|
|
0))))))
|
|
|
|
(define* (metric-decrement metric
|
|
#:key
|
|
(by 1)
|
|
(label-values '()))
|
|
"Decrement the value of the given @var{metric} by 1 (or the @var{#:by} value).
|
|
|
|
This procedure can be used with gauge metrics.
|
|
|
|
To specify values for the labels, pass an alist as
|
|
@var{#:label-values} where the keys are the label names, and the
|
|
values are the values."
|
|
(unless (memq (metric-type metric)
|
|
'(gauge))
|
|
(error "can only increment gauge metrics"))
|
|
|
|
(let ((canonical-labels
|
|
(canonicalise-label-values label-values))
|
|
(hash
|
|
(metric-values metric)))
|
|
(with-mutex (metric-mutex metric)
|
|
(hash-set! hash
|
|
canonical-labels
|
|
(+ (* -1 by)
|
|
(or (hash-ref hash canonical-labels)
|
|
0))))))
|
|
|
|
(define* (metric-set metric value
|
|
#:key (label-values '()))
|
|
"Set the value of the given @var{metric} to @var{value}.
|
|
|
|
This procedure can be used with gauge metrics.
|
|
|
|
To specify values for the labels, pass an alist as
|
|
@var{#:label-values} where the keys are the label names, and the
|
|
values are the values."
|
|
(unless (memq (metric-type metric)
|
|
'(gauge))
|
|
(error "can only set gauge metrics"))
|
|
|
|
(with-mutex (metric-mutex metric)
|
|
(hash-set! (metric-values metric)
|
|
(canonicalise-label-values label-values)
|
|
value)))
|
|
|
|
(define* (metric-observe metric value
|
|
#:key (label-values '()))
|
|
"With the given @var{metric}, observe the given @var{value}.
|
|
|
|
This procedure can be used with histogram metrics.
|
|
|
|
To specify values for the labels, pass an alist as
|
|
@var{#:label-values} where the keys are the label names, and the
|
|
values are the values."
|
|
|
|
(unless (histogram-metric-type? (metric-type metric))
|
|
(error "can only observe histogram metrics"))
|
|
|
|
(let ((canonical-labels
|
|
(canonicalise-label-values label-values))
|
|
(hash
|
|
(metric-values metric)))
|
|
|
|
(with-mutex (metric-mutex metric)
|
|
(let* ((buckets
|
|
(histogram-metric-type-buckets (metric-type metric)))
|
|
(histogram-values-record
|
|
(or (hash-ref hash canonical-labels)
|
|
(let ((new-record (make-histogram-values (make-vector
|
|
(length buckets)
|
|
0)
|
|
0
|
|
0)))
|
|
(hash-set! hash canonical-labels new-record)
|
|
new-record))))
|
|
|
|
(set-histogram-values-sum! histogram-values-record
|
|
(+ value
|
|
(histogram-values-sum
|
|
histogram-values-record)))
|
|
(set-histogram-values-count! histogram-values-record
|
|
(+ 1
|
|
(histogram-values-count
|
|
histogram-values-record)))
|
|
(let ((bucket-values-vector (histogram-values-buckets
|
|
histogram-values-record)))
|
|
(for-each
|
|
(lambda (index bucket-upper-limit)
|
|
(when (<= value bucket-upper-limit)
|
|
(vector-set! bucket-values-vector
|
|
index
|
|
(+ 1
|
|
(vector-ref bucket-values-vector
|
|
index)))))
|
|
(iota (length buckets))
|
|
buckets))))))
|
|
|
|
(define* (call-with-duration-metric registry metric-name thunk
|
|
#:key
|
|
(buckets %default-histogram-buckets)
|
|
docstring
|
|
(labels '())
|
|
(label-preset-values '()))
|
|
"Call @var{thunk} while recording the duration in seconds between
|
|
calling @var{thunk} and the procedure ending using a metric by the
|
|
name of @var{metric-name}.
|
|
|
|
The metric with the name @var{metric-name} is fetched from the
|
|
@var{registry}, or created if it doesn't already exist.
|
|
"
|
|
(let* ((metric
|
|
(or (metrics-registry-fetch-metric registry metric-name)
|
|
(make-histogram-metric
|
|
registry
|
|
metric-name
|
|
#:buckets buckets
|
|
#:docstring docstring
|
|
#:labels labels
|
|
#:label-preset-values label-preset-values)))
|
|
(start-time (current-time)))
|
|
(call-with-values
|
|
thunk
|
|
(lambda results
|
|
(metric-observe metric (- (current-time) start-time))
|
|
|
|
(apply values results)))))
|
|
|
|
(define (write-metrics registry port)
|
|
"Write all metrics from the given @var{registry} to @var{port} in
|
|
the standard text based exposition format.
|
|
|
|
Usually, this would be in response to a HTTP request from Prometheus
|
|
so that it can receive and store the metric values."
|
|
|
|
(define (write-line name label-values value)
|
|
(format
|
|
port
|
|
"~a~a ~f\n"
|
|
name
|
|
(if (null? label-values)
|
|
""
|
|
(string-append
|
|
"{"
|
|
(string-join (map
|
|
(match-lambda
|
|
((label . (? number? value))
|
|
(format
|
|
#f
|
|
"~a=\"~f\""
|
|
label value))
|
|
((label . value)
|
|
(format
|
|
#f
|
|
"~a=\"~a\""
|
|
label value)))
|
|
label-values)
|
|
",")
|
|
"}"))
|
|
value))
|
|
|
|
(hash-for-each
|
|
(lambda (name metric)
|
|
(let ((full-name
|
|
(string-append
|
|
(or (and=> (metrics-registry-namespace registry)
|
|
(lambda (namespace)
|
|
(string-append namespace "_")))
|
|
"")
|
|
name))
|
|
(type (metric-type metric)))
|
|
|
|
(and=> (metric-docstring metric)
|
|
(lambda (docstring)
|
|
(simple-format
|
|
port
|
|
"# HELP ~A ~A\n"
|
|
full-name
|
|
docstring)))
|
|
|
|
(simple-format port "# TYPE ~A ~A\n"
|
|
full-name
|
|
(match type
|
|
((? histogram-metric-type? type) 'histogram)
|
|
(type type)))
|
|
|
|
(cond
|
|
((histogram-metric-type? type)
|
|
(let ((buckets (histogram-metric-type-buckets type)))
|
|
(hash-for-each
|
|
(lambda (label-values value)
|
|
(for-each (lambda (index bucket)
|
|
(write-line full-name
|
|
`(,@label-values
|
|
(le . ,(if (inf? bucket)
|
|
"+Inf"
|
|
(format #f "~f" bucket))))
|
|
(vector-ref (histogram-values-buckets value)
|
|
index)))
|
|
(iota (length buckets))
|
|
buckets)
|
|
(write-line (string-append full-name "_sum")
|
|
label-values
|
|
(histogram-values-sum value))
|
|
(write-line (string-append full-name "_count")
|
|
label-values
|
|
(histogram-values-count value)))
|
|
(metric-values metric))))
|
|
(else
|
|
(hash-for-each
|
|
(lambda (label-values value)
|
|
(write-line full-name label-values value))
|
|
(metric-values metric))))))
|
|
(metrics-registry-metrics-hash registry)))
|
|
|
|
(define (write-textfile registry filename)
|
|
"Write all metrics from the given @var{registry} to @var{filename}
|
|
in the standard text based exposition format.
|
|
|
|
For the node exporter to read the file, the @var{filename} must end
|
|
with .prom.
|
|
|
|
This procedure takes care of atomically replacing the file."
|
|
(let* ((template (string-append filename ".XXXXXX"))
|
|
(out (mkstemp! template)))
|
|
(with-throw-handler #t
|
|
(lambda ()
|
|
(chmod out(logand #o666 (lognot (umask))))
|
|
(write-metrics registry out)
|
|
(close out)
|
|
(rename-file template filename)
|
|
#t)
|
|
(lambda (key . args)
|
|
(false-if-exception (delete-file template))))))
|
|
|