prometheus.scm

@@ -21,12 +21,10 @@
 (define-module (prometheus)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
-  #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (ice-9 threads)
   #:use-module (ice-9 exceptions)
-  #:use-module (ice-9 textual-ports)
   #:export (make-metrics-registry
             metrics-registry-fetch-metric
             write-metrics
@@ -34,11 +32,6 @@
 
             make-counter-metric
             make-gauge-metric
-
-            %default-histogram-buckets
-            linear-histogram-buckets
-            exponential-histogram-buckets
-
             make-histogram-metric
 
             metric-increment
@@ -46,10 +39,7 @@
             metric-set
             metric-observe
 
-            call-with-duration-metric
-
-            get-gc-metrics-updater
-            get-process-metrics-updater))
+            call-with-duration-metric))
 
 (define-record-type <metrics-registry>
   (make-metrics-registry-record metrics-hash namespace)
@@ -70,12 +60,13 @@ metrics relate to."
                                 namespace))
 
 (define-record-type <metric>
-  (make-metric type name values docstring labels label-preset-values
+  (make-metric type name values registry docstring labels label-preset-values
                mutex)
   metric?
   (type                  metric-type)
   (name                  metric-name)
   (values                metric-values)
+  (registry              metric-registry)
   (docstring             metric-docstring)
   (labels                metric-labels)
   (label-preset-values   metric-label-preset-values)
@@ -122,6 +113,7 @@ list of label names to be permitted for this metric and
    (make-metric 'counter
                 name
                 (make-hash-table)
+                registry
                 docstring
                 labels
                 label-preset-values
@@ -150,6 +142,7 @@ list of label names to be permitted for this metric and
    (make-metric 'gauge
                 name
                 (make-hash-table)
+                registry
                 docstring
                 (map canonicalise-label labels)
                 (canonicalise-label-values label-preset-values)
@@ -171,47 +164,6 @@ list of label names to be permitted for this metric and
   ;; The default buckets used in other client libraries
   (list 0.005 0.01 0.025 0.05 0.1 0.25 0.5 1 2.5 5 10 (inf)))
 
-(define* (linear-histogram-buckets #:key start step end count)
-  (when (and end count)
-    (raise-exception
-     (make-exception-with-message
-      "you can only specify either end or count to linear-histogram-buckets")))
-
-  (append (if count
-              (map (lambda (index)
-                     (+ start
-                        (* step index)))
-                   (iota count))
-              (let loop ((reverse-result (list start))
-                         (current-value start))
-                (let ((next-value (+ current-value step)))
-                  (if (>= next-value end)
-                      (reverse (cons end reverse-result))
-                      (loop (cons next-value reverse-result)
-                            next-value)))))
-          (list (inf))))
-
-(define* (exponential-histogram-buckets #:key start (factor 2) end count)
-  (when (and end count)
-    (raise-exception
-     (make-exception-with-message
-      "you can only specify either end or count to exponential-histogram-buckets")))
-
-  (append (if count
-              (map (lambda (index)
-                     (* start
-                        (expt factor index)))
-                   (iota count))
-              (let loop ((reverse-result (list start)))
-                (let ((next-value
-                       (* start
-                          (expt factor
-                                (+ 1 (length reverse-result))))))
-                  (if (>= next-value end)
-                      (reverse (cons end reverse-result))
-                      (loop (cons next-value reverse-result))))))
-          (list (inf))))
-
 (define* (make-histogram-metric registry name
                                 #:key
                                 (buckets %default-histogram-buckets)
@@ -241,6 +193,7 @@ list of label names to be permitted for this metric and
    (make-metric (make-histogram-metric-type buckets)
                 name
                 (make-hash-table)
+                registry
                 docstring
                 labels
                 label-preset-values
@@ -291,26 +244,21 @@ To specify values for the labels, pass an alist as
 values are the values."
   (unless (memq (metric-type metric)
                 '(counter gauge))
-    (raise-exception
-     (make-exception-with-message
-      "can only increment counter and gauge metrics")))
+    (error "can only increment counter and gauge metrics"))
 
   (unless (positive? by)
-    (raise-exception
-     (make-exception-with-message "can only increment positive values")))
+    (error "can only increment positive values"))
 
   (let ((canonical-labels
          (canonicalise-label-values label-values))
         (hash
          (metric-values metric)))
-    (call-with-blocked-asyncs
-     (lambda ()
-       (with-mutex (metric-mutex 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
@@ -325,21 +273,18 @@ To specify values for the labels, pass an alist as
 values are the values."
   (unless (memq (metric-type metric)
                 '(gauge))
-    (raise-exception
-     (make-exception-with-message "can only increment gauge metrics")))
+    (error "can only increment gauge metrics"))
 
   (let ((canonical-labels
          (canonicalise-label-values label-values))
         (hash
          (metric-values metric)))
-    (call-with-blocked-asyncs
-     (lambda ()
-       (with-mutex (metric-mutex 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 '()))
@@ -352,21 +297,12 @@ To specify values for the labels, pass an alist as
 values are the values."
   (unless (memq (metric-type metric)
                 '(gauge))
-    (raise-exception
-     (make-exception-with-message "can only set gauge metrics")))
+    (error "can only set gauge metrics"))
 
-  (unless (number? value)
-    (raise-exception
-     (make-exception-with-message
-      (simple-format #f "metric-set value must be a number: ~A"
-                     value))))
-
-  (call-with-blocked-asyncs
-   (lambda ()
-     (with-mutex (metric-mutex metric)
-       (hash-set! (metric-values metric)
-                  (canonicalise-label-values label-values)
-                  value)))))
+  (with-mutex (metric-mutex metric)
+    (hash-set! (metric-values metric)
+               (canonicalise-label-values label-values)
+               value)))
 
 (define* (metric-observe metric value
                          #:key (label-values '()))
@@ -379,50 +315,46 @@ To specify values for the labels, pass an alist as
 values are the values."
 
   (unless (histogram-metric-type? (metric-type metric))
-    (raise-exception
-     (make-exception-with-message
-      "can only observe histogram metrics")))
+    (error "can only observe histogram metrics"))
 
   (let ((canonical-labels
          (canonicalise-label-values label-values))
         (hash
          (metric-values metric)))
 
-    (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))))
+    (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))))))))
+        (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
@@ -440,13 +372,18 @@ The metric with the name @var{metric-name} is fetched from the
 "
   (let* ((metric
           (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)))
+              (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
@@ -565,162 +502,3 @@ This procedure takes care of atomically replacing the file."
       (lambda (key . args)
         (false-if-exception (delete-file template))))))
 
-(define (get-gc-metrics-updater registry)
-  (define metrics
-    `((gc-time-taken
-       . ,(make-gauge-metric registry "guile_gc_time_taken_seconds"))
-      (heap-size
-       . ,(make-gauge-metric registry "guile_heap_bytes"))
-      (heap-free-size
-       . ,(make-gauge-metric registry "guile_heap_free_bytes"))
-      (heap-total-allocated
-       . ,(make-gauge-metric registry "guile_heap_total_allocated_bytes"))
-      (heap-allocated-since-gc
-       . ,(make-gauge-metric registry "guile_allocated_since_gc_bytes"))
-      (protected-objects
-       . ,(make-gauge-metric registry "guile_gc_protected_objects_total"))
-      (gc-times
-       . ,(make-gauge-metric registry "guile_gc_times_total"))))
-
-  (lambda ()
-    (let ((stats (gc-stats)))
-      (for-each
-       (match-lambda
-         (('gc-time-taken . metric)
-          (metric-set metric
-                      (/ (assq-ref stats 'gc-time-taken)
-                         internal-time-units-per-second)))
-         ((name . metric)
-          (let ((value (assq-ref stats name)))
-            (metric-set metric value))))
-       metrics))))
-
-(define* (get-process-metrics-updater registry
-                                      #:key (pid (getpid))
-                                      (proc "/proc"))
-  (define cpu-seconds-metric
-    (make-gauge-metric registry
-                       "process_cpu_seconds_total"
-                       #:docstring
-                       "Total user and system CPU time spent in seconds."))
-
-  (define open-fds-metric
-    (make-gauge-metric registry
-                       "process_open_fds"
-                       #:docstring "Number of open file descriptors."))
-
-  (define max-fds-metric
-    (make-gauge-metric registry
-                       "process_max_fds"
-                       #:docstring "Maximum number of open file descriptors."))
-
-  (define virtual-memory-bytes-metric
-    (make-gauge-metric registry
-                       "process_virtual_memory_bytes"
-                       #:docstring "Virtual memory size in bytes."))
-
-  ;; (define virtual-memory-max-bytes-metric
-  ;;   (make-gauge-metric registry
-  ;;                      "process_virtual_memory_max_bytes"
-  ;;                      #:docstring "Maximum amount of virtual memory available in bytes."))
-
-  (define resident-memory-bytes-metric
-    (make-gauge-metric registry
-                       "process_resident_memory_bytes"
-                       #:docstring "Resident memory size in bytes."))
-
-  ;; (define heap-bytes-metric
-  ;;   (make-gauge-metric registry
-  ;;                      "process_heap_bytes"
-  ;;                      #:docstring "Process heap size in bytes."))
-
-  (define start-time-seconds-metric
-    (make-gauge-metric registry
-                       "process_start_time_seconds"
-                       #:docstring "Start time of the process since unix epoch in seconds."))
-
-  (define threads-metric
-    (make-gauge-metric registry
-                       "process_threads"
-                       #:docstring "Number of OS threads in the process."))
-
-  (define boot-time
-    (let ((contents
-           (call-with-input-file (string-append proc "/stat")
-             get-string-all)))
-      (match (string-split
-              (find
-               (lambda (line)
-                 (string-prefix? "btime " line))
-               (string-split contents #\newline))
-              #\space)
-        ((_ btime)
-         (string->number btime)))))
-
-  (define page-size
-    ;; TODO Assume the page size
-    4096)
-
-  (define ticks
-    ;; TODO
-    100)
-
-  (lambda ()
-    (let ((stat-parts
-           (drop
-            (string-split
-             (last
-              (string-split
-               (call-with-input-file
-                   (string-append proc "/" (number->string pid) "/stat")
-                 get-string-all)
-               #\)))
-             #\space)
-            1)))
-
-      (metric-set virtual-memory-bytes-metric
-                  (string->number (list-ref stat-parts 20)))
-
-      (metric-set resident-memory-bytes-metric
-                  (* (string->number (list-ref stat-parts 21)) page-size))
-
-      (metric-set start-time-seconds-metric
-                  (+ (/ (string->number (list-ref stat-parts 19)) ticks) boot-time))
-
-      (let ((utime (/ (string->number (list-ref stat-parts 11)) ticks))
-            (stime (/ (string->number (list-ref stat-parts 12)) ticks)))
-        (metric-set cpu-seconds-metric
-                    (+ utime stime)))
-
-      (metric-set threads-metric
-                  (string->number (list-ref stat-parts 17))))
-
-    (let ((limits-lines
-           (string-split
-            (call-with-input-file
-                (string-append proc "/" (number->string pid) "/limits")
-              get-string-all)
-            #\newline)))
-
-      (let ((max-open-files-data
-             (take-right
-              (remove
-               string-null?
-               (string-split
-                (find
-                 (lambda (line)
-                   (string-prefix? "Max open files" line))
-                 limits-lines)
-                #\space))
-              3)))
-        (metric-set max-fds-metric
-                    (string->number (first max-open-files-data))))
-
-      (metric-set open-fds-metric
-                  (length
-                   ;; In theory 'scandir' cannot return #f, but in practice,
-                   ;; we've seen it before.
-                   (or (scandir "/proc/self/fd"
-                                (lambda (file)
-                                  (not (member file '("." "..")))))
-                       '()))))))