aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--prometheus.scm132
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