From 5acbc44d2d6c89fd984ef2353f81f73d4e227a33 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 31 Aug 2020 13:38:22 +0100 Subject: Initial commit --- prometheus.scm | 304 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 304 insertions(+) create mode 100644 prometheus.scm (limited to 'prometheus.scm') 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 +;;; +;;; 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 +;;; . + +(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 + (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 + (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 + (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))) -- cgit v1.2.3