cbaines/guile-prometheus
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit

Browse source
This commit is contained in:
Christopher Baines 2020-08-31 13:38:22 +01:00
commit 5acbc44d2d
10 changed files with 1109 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

304
prometheus.scm Normal file
View file

@ -0,0 +1,304 @@
;;; 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)))