Fix histogram metrics

Properly write a _sum and _count line, and sort the lines correctly.

1 files changed, 95 insertions, 54 deletions

diff --git a/prometheus.scm b/prometheus.scm
index 68a3fa2..8d36b25 100644
--- a/prometheus.scm
+++ b/prometheus.scm
@@ -153,6 +153,13 @@ list of label names to be permitted for this metric and
   histogram-metric-type?
   (buckets          histogram-metric-type-buckets))
 
+(define-record-type <histogram-values>
+  (make-histogram-values buckets sum count)
+  histogram-values?
+  (buckets histogram-values-buckets)
+  (sum     histogram-values-sum      set-histogram-values-sum!)
+  (count   histogram-values-count    set-histogram-values-count!))
+
 (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)))
@@ -316,31 +323,38 @@ values are the values."
          (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)))))
+      (let* ((buckets
+              (histogram-metric-type-buckets (metric-type metric)))
+             (histogram-values-record
+              (or (hash-ref hash canonical-labels)
+                  (let ((new-record (make-histogram-values (make-vector
+                                                            (length buckets)
+                                                            0)
+                                                           0
+                                                           0)))
+                    (hash-set! hash canonical-labels new-record)
+                    new-record))))
+
+        (set-histogram-values-sum! histogram-values-record
+                                   (+ value
+                                      (histogram-values-sum
+                                       histogram-values-record)))
+        (set-histogram-values-count! histogram-values-record
+                                     (+ 1
+                                        (histogram-values-count
+                                         histogram-values-record)))
+        (let ((bucket-values-vector (histogram-values-buckets
+                                     histogram-values-record)))
+          (for-each
+           (lambda (index bucket-upper-limit)
+             (when (<= value bucket-upper-limit)
+               (vector-set! bucket-values-vector
+                            index
+                            (+ 1
+                               (vector-ref bucket-values-vector
+                                           index)))))
+           (iota (length buckets))
+           buckets))))))
 
 (define* (call-with-duration-metric registry metric-name thunk
                                     #:key
@@ -379,6 +393,32 @@ the standard text based exposition format.
 Usually, this would be in response to a HTTP request from Prometheus
 so that it can receive and store the metric values."
 
+  (define (write-line name label-values value)
+    (format
+     port
+     "~a~a ~f\n"
+     name
+     (if (null? label-values)
+         ""
+         (string-append
+          "{"
+          (string-join (map
+                        (match-lambda
+                          ((label . (? number? value))
+                           (format
+                            #f
+                            "~a=\"~f\""
+                            label value))
+                          ((label . value)
+                           (format
+                            #f
+                            "~a=\"~a\""
+                            label value)))
+                        label-values)
+                       ",")
+          "}"))
+     value))
+
   (hash-for-each
    (lambda (name metric)
      (let ((full-name
@@ -387,7 +427,8 @@ so that it can receive and store the metric values."
                         (lambda (namespace)
                           (string-append namespace "_")))
                  "")
-             name)))
+             name))
+           (type (metric-type metric)))
 
        (and=> (metric-docstring metric)
               (lambda (docstring)
@@ -399,37 +440,37 @@ so that it can receive and store the metric values."
 
        (simple-format port "# TYPE ~A ~A\n"
                       full-name
-                      (match (metric-type metric)
+                      (match type
                         ((? histogram-metric-type? type) 'histogram)
                         (type type)))
 
-       (hash-for-each
-        (lambda (label-values value)
-          (format
-           port
-           "~a~a ~f\n"
-           full-name
-           (if (null? label-values)
-               ""
-               (string-append
-                "{"
-                (string-join (map
-                              (match-lambda
-                                ((label . (? number? value))
-                                 (format
-                                  #f
-                                  "~a=\"~f\""
-                                  label value))
-                                ((label . value)
-                                 (format
-                                  #f
-                                  "~a=\"~a\""
-                                  label value)))
-                              label-values)
-                             ",")
-                "}"))
-           value))
-        (metric-values metric))))
+       (cond
+        ((histogram-metric-type? type)
+         (let ((buckets  (histogram-metric-type-buckets type)))
+           (hash-for-each
+            (lambda (label-values value)
+              (for-each (lambda (index bucket)
+                          (write-line full-name
+                                      `(,@label-values
+                                        (le . ,(if (inf? bucket)
+                                                   "+Inf"
+                                                   (format #f "~f" bucket))))
+                                      (vector-ref (histogram-values-buckets value)
+                                                  index)))
+                        (iota (length buckets))
+                        buckets)
+              (write-line (string-append full-name "_sum")
+                          label-values
+                          (histogram-values-sum value))
+              (write-line (string-append full-name "_count")
+                          label-values
+                          (histogram-values-count value)))
+            (metric-values metric))))
+        (else
+         (hash-for-each
+          (lambda (label-values value)
+            (write-line full-name label-values value))
+          (metric-values metric))))))
    (metrics-registry-metrics-hash registry)))
 
 (define (write-textfile registry filename)