Use mutexes for the metrics to add some thread safety

This means they can be used in multiple threads.

1 files changed, 53 insertions, 43 deletions

diff --git a/guix-build-coordinator/metrics.scm b/guix-build-coordinator/metrics.scm
index 5f2ff6a..2a3e0db 100644
--- a/guix-build-coordinator/metrics.scm
+++ b/guix-build-coordinator/metrics.scm
@@ -22,6 +22,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 threads)
   #:use-module (ice-9 exceptions)
   #:export (make-metrics-registry
             metrics-registry-fetch-metric
@@ -50,7 +51,8 @@
   (make-metrics-registry-record (make-hash-table)))
 
 (define-record-type <metric>
-  (make-metric type name values registry docstring labels label-preset-values)
+  (make-metric type name values registry docstring labels label-preset-values
+               mutex)
   metric?
   (type                  metric-type)
   (name                  metric-name)
@@ -58,7 +60,8 @@
   (registry              metric-registry)
   (docstring             metric-docstring)
   (labels                metric-labels)
-  (label-preset-values   metric-label-preset-values))
+  (label-preset-values   metric-label-preset-values)
+  (mutex                 metric-mutex))
 
 (define (metrics-registry-add-metric registry name metric)
   (let ((metrics-hash
@@ -91,7 +94,8 @@
                 registry
                 docstring
                 labels
-                label-preset-values)))
+                label-preset-values
+                (make-mutex))))
 
 (define* (make-gauge-metric registry name
                             #:key
@@ -107,7 +111,8 @@
                 registry
                 docstring
                 labels
-                label-preset-values)))
+                label-preset-values
+                (make-mutex))))
 
 (define-record-type <histogram-metric-type>
   (make-histogram-metric-type buckets)
@@ -135,7 +140,8 @@
                 registry
                 docstring
                 labels
-                label-preset-values)))
+                label-preset-values
+                (make-mutex))))
 
 (define (canonicalise-label-values-for-metric metric
                                               label-values)
@@ -156,11 +162,12 @@
          (canonicalise-label-values-for-metric metric label-values))
         (hash
          (metric-values metric)))
-    (hash-set! hash
-               canonical-labels
-               (+ by
-                  (or (hash-ref hash canonical-labels)
-                      0)))))
+    (with-mutex (metric-mutex metric)
+      (hash-set! hash
+                 canonical-labels
+                 (+ by
+                    (or (hash-ref hash canonical-labels)
+                        0))))))
 
 (define* (metric-decrement metric
                            #:key
@@ -174,11 +181,12 @@
          (canonicalise-label-values-for-metric metric label-values))
         (hash
          (metric-values metric)))
-    (hash-set! hash
-               canonical-labels
-               (+ (* -1 by)
-                  (or (hash-ref hash canonical-labels)
-                      0)))))
+    (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 '()))
@@ -186,9 +194,10 @@
                 '(gauge))
     (error "can only set gauge metrics"))
 
-  (hash-set! (metric-values metric)
-             (canonicalise-label-values-for-metric metric label-values)
-             value))
+  (with-mutex (metric-mutex metric)
+    (hash-set! (metric-values metric)
+               (canonicalise-label-values-for-metric metric label-values)
+               value)))
 
 (define* (metric-observe metric value
                          #:key (label-values '()))
@@ -200,31 +209,32 @@
         (hash
          (metric-values 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))))
+    (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)))))
 
 (define (call-with-duration-metric registry metric-name thunk)
   (let* ((metric