diff options
| -rw-r--r-- | prometheus.scm | 132 |
1 files changed, 71 insertions, 61 deletions
diff --git a/prometheus.scm b/prometheus.scm index 9d8d7ad..b1b3d31 100644 --- a/prometheus.scm +++ b/prometheus.scm @@ -294,12 +294,14 @@ values are the values." (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)))))) + (call-with-blocked-asyncs + (lambda () + (with-mutex (metric-mutex metric) + (hash-set! hash + canonical-labels + (+ by + (or (hash-ref hash canonical-labels) + 0)))))))) (define* (metric-decrement metric #:key @@ -320,12 +322,14 @@ values are the values." (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)))))) + (call-with-blocked-asyncs + (lambda () + (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 '())) @@ -340,10 +344,12 @@ values are the values." '(gauge)) (error "can only set gauge metrics")) - (with-mutex (metric-mutex metric) - (hash-set! (metric-values metric) - (canonicalise-label-values label-values) - value))) + (call-with-blocked-asyncs + (lambda () + (with-mutex (metric-mutex metric) + (hash-set! (metric-values metric) + (canonicalise-label-values label-values) + value))))) (define* (metric-observe metric value #:key (label-values '())) @@ -363,39 +369,41 @@ values are the values." (hash (metric-values metric))) - (with-mutex (metric-mutex metric) - (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)))))) + (call-with-blocked-asyncs + (lambda () + (with-mutex (metric-mutex metric) + (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 @@ -413,18 +421,20 @@ The metric with the name @var{metric-name} is fetched from the " (let* ((metric (or (metrics-registry-fetch-metric registry metric-name) - (monitor - ;; Check once more in case another thread has created - ;; the metric while this thread was waiting for the - ;; mutex - (or (metrics-registry-fetch-metric registry metric-name) - (make-histogram-metric - registry - metric-name - #:buckets buckets - #:docstring docstring - #:labels labels - #:label-preset-values label-preset-values))))) + (call-with-blocked-asyncs + (lambda () + (monitor + ;; Check once more in case another thread has created + ;; the metric while this thread was waiting for the + ;; mutex + (or (metrics-registry-fetch-metric registry metric-name) + (make-histogram-metric + registry + metric-name + #:buckets buckets + #:docstring docstring + #:labels labels + #:label-preset-values label-preset-values))))))) (start-time (get-internal-real-time))) (call-with-values thunk |