Add metrics tools for histograms

1 files changed, 89 insertions, 2 deletions

diff --git a/guix-build-coordinator/metrics.scm b/guix-build-coordinator/metrics.scm
index 8878953..1175027 100644
--- a/guix-build-coordinator/metrics.scm
+++ b/guix-build-coordinator/metrics.scm
@@ -19,18 +19,23 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (guix-build-coordinator metrics)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 match)
   #:use-module (ice-9 exceptions)
-  #:use-module (guix-build-coordinator datastore)
   #:export (make-metrics-registry
+            metrics-registry-fetch-metric
             write-metrics
 
             make-gauge-metric
+            make-histogram-metric
 
             metric-increment
             metric-decrement
-            metric-set))
+            metric-set
+            metric-observe
+
+            call-with-duration-metric))
 
 (define namespace
   "guixbuildcoordinator")
@@ -67,6 +72,10 @@
 
     metric))
 
+(define (metrics-registry-fetch-metric registry name)
+  (hash-ref (metrics-registry-metrics-hash registry)
+            name))
+
 (define* (make-gauge-metric registry name
                             #:key
                             docstring
@@ -83,6 +92,34 @@
                 labels
                 label-preset-values)))
 
+(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
+  '(0.005 0.01 0.025 0.05 0.1 0.25 0.5 1 2.5 5 10))
+
+(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)))
+
 (define (canonicalise-label-values-for-metric metric
                                               label-values)
   label-values)
@@ -136,6 +173,56 @@
              (canonicalise-label-values-for-metric metric 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* ((buckets (histogram-metric-type-buckets (metric-type metric)))
+         (bucket
+          (find (lambda (upper-limit)
+                  (>= upper-limit value))
+                buckets)))
+
+    (let ((canonical-labels
+           (canonicalise-label-values-for-metric metric label-values))
+          (hash
+           (metric-values metric)))
+
+      (let ((bucket-labels
+             `(,@canonical-labels
+               (le . ,(or (and=> bucket number->string)
+                          "+Inf")))))
+        (hash-set! hash
+                   bucket-labels
+                   (+ 1
+                      (or (hash-ref hash bucket-labels)
+                          0))))
+
+      (let ((sum-labels
+             `(,@canonical-labels
+               (le . "sum"))))
+
+        (hash-set! hash
+                   sum-labels
+                   (+ value
+                      (or (hash-ref hash sum-labels)
+                          0)))))))
+
+(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)))
+      (simple-format #t "~A ~A"
+                     metric-name
+                     (- (current-time) start-time))
+      (metric-observe metric (- (current-time) start-time))
+      result)))
+
 (define (write-metrics registry port)
   (hash-for-each
    (lambda (name metric)