Initial commit

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)))