aboutsummaryrefslogtreecommitdiff
path: root/prometheus.scm
diff options
context:
space:
mode:
Diffstat (limited to 'prometheus.scm')
-rw-r--r--prometheus.scm304
1 files changed, 304 insertions, 0 deletions
diff --git a/prometheus.scm b/prometheus.scm
new file mode 100644
index 0000000..8d6a37f
--- /dev/null
+++ b/prometheus.scm
@@ -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)))
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-21 11:38:04 +0000