diff options
| -rw-r--r-- | prometheus.scm | 149 |
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) |