Fix the histogram implementation

At least a bit, don't just update a single bucket on observations, but update
all the relevant buckets (all buckets with a upper bound <= than the value
being observed).

1 files changed, 31 insertions, 31 deletions

diff --git a/guix-build-coordinator/metrics.scm b/guix-build-coordinator/metrics.scm
index 1175027..cf0331a 100644
--- a/guix-build-coordinator/metrics.scm
+++ b/guix-build-coordinator/metrics.scm
@@ -99,7 +99,7 @@
 
 (define %default-histogram-buckets
   ;; The default buckets used in other client libraries
-  '(0.005 0.01 0.025 0.05 0.1 0.25 0.5 1 2.5 5 10))
+  (list 0.005 0.01 0.025 0.05 0.1 0.25 0.5 1 2.5 5 10 (inf)))
 
 (define* (make-histogram-metric registry name
                                 #:key
@@ -178,36 +178,36 @@
   (unless (histogram-metric-type? (metric-type metric))
     (error "can only observe histogram metrics"))
 
-  (let* ((buckets (histogram-metric-type-buckets (metric-type metric)))
-         (bucket
-          (find (lambda (upper-limit)
-                  (>= upper-limit value))
-                buckets)))
-
-    (let ((canonical-labels
-           (canonicalise-label-values-for-metric metric label-values))
-          (hash
-           (metric-values metric)))
-
-      (let ((bucket-labels
-             `(,@canonical-labels
-               (le . ,(or (and=> bucket number->string)
-                          "+Inf")))))
-        (hash-set! hash
-                   bucket-labels
-                   (+ 1
-                      (or (hash-ref hash bucket-labels)
-                          0))))
-
-      (let ((sum-labels
-             `(,@canonical-labels
-               (le . "sum"))))
-
-        (hash-set! hash
-                   sum-labels
-                   (+ value
-                      (or (hash-ref hash sum-labels)
-                          0)))))))
+  (let ((canonical-labels
+         (canonicalise-label-values-for-metric metric label-values))
+        (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))))
 
 (define (call-with-duration-metric registry metric-name thunk)
   (let* ((metric