From fbd64347fbe0c30aa78cb823d742a420d50768fe Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 12 Nov 2023 13:37:24 +0000
Subject: Wrap use of mutexes with call-with-blocked-asyncs

As this will hopefully avoid problems with mutexes when using fibers.
---
 prometheus.scm | 132 +++++++++++++++++++++++++++++++--------------------------
 1 file 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
-- 
cgit v1.2.3