305 lines
9.5 KiB
Scheme
305 lines
9.5 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 threads)
|
||
|
|
#:use-module (ice-9 exceptions)
|
||
|
|
#:export (make-metrics-registry
|
||
|
|
metrics-registry-fetch-metric
|
||
|
|
write-metrics
|
||
|
|
|
||
|
|
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)
|
||
|
|
(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)
|
||
|
|
(hash-ref (metrics-registry-metrics-hash registry)
|
||
|
|
name))
|
||
|
|
|
||
|
|
(define* (make-counter-metric registry name
|
||
|
|
#:key
|
||
|
|
docstring
|
||
|
|
(labels '())
|
||
|
|
(label-preset-values '()))
|
||
|
|
(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 '()))
|
||
|
|
(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 %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 '()))
|
||
|
|
;; 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 '()))
|
||
|
|
(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 '()))
|
||
|
|
(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 '()))
|
||
|
|
(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 '()))
|
||
|
|
(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 ((sum-labels
|
||
|
|
`(,@canonical-labels
|
||
|
|
(le . "sum"))))
|
||
|
|
|
||
|
|
(hash-set! hash
|
||
|
|
sum-labels
|
||
|
|
(+ value
|
||
|
|
(or (hash-ref hash sum-labels)
|
||
|
|
0))))
|
||
|
|
|
||
|
|
(let ((buckets (histogram-metric-type-buckets (metric-type metric))))
|
||
|
|
(for-each
|
||
|
|
(lambda (bucket-upper-limit)
|
||
|
|
(when (<= value bucket-upper-limit)
|
||
|
|
(let ((bucket-labels
|
||
|
|
`(,@canonical-labels
|
||
|
|
(le . ,(if (inf? bucket-upper-limit)
|
||
|
|
"+Inf"
|
||
|
|
(number->string bucket-upper-limit))))))
|
||
|
|
(hash-set! hash
|
||
|
|
bucket-labels
|
||
|
|
(+ 1
|
||
|
|
(or (hash-ref hash bucket-labels)
|
||
|
|
0))))))
|
||
|
|
buckets)))))
|
||
|
|
|
||
|
|
(define (call-with-duration-metric registry metric-name thunk)
|
||
|
|
(let* ((metric
|
||
|
|
(or (metrics-registry-fetch-metric registry metric-name)
|
||
|
|
(make-histogram-metric
|
||
|
|
registry
|
||
|
|
metric-name)))
|
||
|
|
(start-time (current-time)))
|
||
|
|
(let ((result (thunk)))
|
||
|
|
(metric-observe metric (- (current-time) start-time))
|
||
|
|
result)))
|
||
|
|
|
||
|
|
(define (write-metrics registry port)
|
||
|
|
(hash-for-each
|
||
|
|
(lambda (name metric)
|
||
|
|
(hash-for-each
|
||
|
|
(lambda (label-values value)
|
||
|
|
(simple-format
|
||
|
|
port
|
||
|
|
"~A~A~A ~A\n"
|
||
|
|
(or (metrics-registry-namespace registry)
|
||
|
|
"")
|
||
|
|
name
|
||
|
|
(if (null? label-values)
|
||
|
|
""
|
||
|
|
(string-append
|
||
|
|
"{"
|
||
|
|
(string-join (map
|
||
|
|
(match-lambda
|
||
|
|
((label . value)
|
||
|
|
(simple-format
|
||
|
|
#f
|
||
|
|
"~A=\"~A\""
|
||
|
|
label value)))
|
||
|
|
label-values)
|
||
|
|
",")
|
||
|
|
"}"))
|
||
|
|
value))
|
||
|
|
(metric-values metric)))
|
||
|
|
(metrics-registry-metrics-hash registry)))
|