From 35dc26c0ea44c3d70f1819f240d84e2cbb4b7b4c Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 10 Dec 2020 19:50:02 +0000 Subject: [PATCH 01/10] Add a couple of procedures for generating histogram buckets --- prometheus.scm | 41 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/prometheus.scm b/prometheus.scm index 2a181f8..9d8d7ad 100644 --- a/prometheus.scm +++ b/prometheus.scm @@ -164,6 +164,47 @@ 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) From fbd64347fbe0c30aa78cb823d742a420d50768fe Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 12 Nov 2023 13:37:24 +0000 Subject: [PATCH 02/10] Wrap use of mutexes with call-with-blocked-asyncs As this will hopefully avoid problems with mutexes when using fibers. --- prometheus.scm | 130 ++++++++++++++++++++++++++----------------------- 1 file changed, 70 insertions(+), 60 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)))) + (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)))))) + (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 From c1b8fe176edfe43ed007e76aa00b14de11924f5a Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 12 Nov 2023 13:38:17 +0000 Subject: [PATCH 03/10] Export some more values --- prometheus.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/prometheus.scm b/prometheus.scm index b1b3d31..04f24d8 100644 --- a/prometheus.scm +++ b/prometheus.scm @@ -32,6 +32,11 @@ make-counter-metric make-gauge-metric + + %default-histogram-buckets + linear-histogram-buckets + exponential-histogram-buckets + make-histogram-metric metric-increment From 4aaf902eb45b3a4c1003f854bda56c516fdf4f5b Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 12 Nov 2023 13:39:14 +0000 Subject: [PATCH 04/10] Add get-gc-metrics-updater --- prometheus.scm | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/prometheus.scm b/prometheus.scm index 04f24d8..447ba08 100644 --- a/prometheus.scm +++ b/prometheus.scm @@ -44,7 +44,9 @@ metric-set metric-observe - call-with-duration-metric)) + call-with-duration-metric + + get-gc-metrics-updater)) (define-record-type (make-metrics-registry-record metrics-hash namespace) @@ -558,3 +560,28 @@ 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")) + (heap-size + . ,(make-gauge-metric registry "guile_heap_size")) + (heap-free-size + . ,(make-gauge-metric registry "guile_heap_free_size")) + (heap-total-allocated + . ,(make-gauge-metric registry "guile_heap_total_allocated")) + (heap-allocated-since-gc + . ,(make-gauge-metric registry "guile_allocated_since_gc")) + (protected-objects + . ,(make-gauge-metric registry "guile_gc_protected_objects")) + (gc-times + . ,(make-gauge-metric registry "guile_gc_times")))) + + (lambda () + (let ((stats (gc-stats))) + (for-each + (match-lambda + ((name . metric) + (let ((value (assq-ref stats name))) + (metric-set metric value)))) + metrics)))) From d0bca34214fcc88edb1292c705b07d363e17b028 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 22 Mar 2024 10:03:27 +0000 Subject: [PATCH 05/10] Remove reference from metric to the registry As this is unused, and will allow registering a metric with multiple registries. --- prometheus.scm | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/prometheus.scm b/prometheus.scm index 447ba08..5c45c8e 100644 --- a/prometheus.scm +++ b/prometheus.scm @@ -67,13 +67,12 @@ metrics relate to." namespace)) (define-record-type - (make-metric type name values registry docstring labels label-preset-values + (make-metric type name values 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) @@ -120,7 +119,6 @@ list of label names to be permitted for this metric and (make-metric 'counter name (make-hash-table) - registry docstring labels label-preset-values @@ -149,7 +147,6 @@ 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) @@ -241,7 +238,6 @@ 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 From 59d19a657c70c833ad511b2f52c64f85d31cbecb Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 22 Mar 2024 10:03:59 +0000 Subject: [PATCH 06/10] Remove locking in call-with-duration-metric As I think this is unnecessary. --- prometheus.scm | 21 +++++++-------------- 1 file changed, 7 insertions(+), 14 deletions(-) diff --git a/prometheus.scm b/prometheus.scm index 5c45c8e..5bb42af 100644 --- a/prometheus.scm +++ b/prometheus.scm @@ -424,20 +424,13 @@ The metric with the name @var{metric-name} is fetched from the " (let* ((metric (or (metrics-registry-fetch-metric registry metric-name) - (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))))))) + (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 From e63335e64a1f63967b94ba6dd97889f9f565ca48 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 22 Mar 2024 13:05:45 +0000 Subject: [PATCH 07/10] Add a process metrics updater --- prometheus.scm | 135 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 134 insertions(+), 1 deletion(-) diff --git a/prometheus.scm b/prometheus.scm index 5bb42af..7332d57 100644 --- a/prometheus.scm +++ b/prometheus.scm @@ -21,10 +21,12 @@ (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 @@ -46,7 +48,8 @@ call-with-duration-metric - get-gc-metrics-updater)) + get-gc-metrics-updater + get-process-metrics-updater)) (define-record-type (make-metrics-registry-record metrics-hash namespace) @@ -574,3 +577,133 @@ This procedure takes care of atomically replacing the file." (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 '("." ".."))))) + '())))))) From bf28a0deb9a2ff9ee82a07bcce8183c5e1ed4f20 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 19 Nov 2025 12:31:45 +0000 Subject: [PATCH 08/10] Improve naming for the gc metrics --- prometheus.scm | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/prometheus.scm b/prometheus.scm index 7332d57..83061a7 100644 --- a/prometheus.scm +++ b/prometheus.scm @@ -555,24 +555,28 @@ This procedure takes care of atomically replacing the file." (define (get-gc-metrics-updater registry) (define metrics `((gc-time-taken - . ,(make-gauge-metric registry "guile_gc_time_taken")) + . ,(make-gauge-metric registry "guile_gc_time_taken_seconds")) (heap-size - . ,(make-gauge-metric registry "guile_heap_size")) + . ,(make-gauge-metric registry "guile_heap_bytes")) (heap-free-size - . ,(make-gauge-metric registry "guile_heap_free_size")) + . ,(make-gauge-metric registry "guile_heap_free_bytes")) (heap-total-allocated - . ,(make-gauge-metric registry "guile_heap_total_allocated")) + . ,(make-gauge-metric registry "guile_heap_total_allocated_bytes")) (heap-allocated-since-gc - . ,(make-gauge-metric registry "guile_allocated_since_gc")) + . ,(make-gauge-metric registry "guile_allocated_since_gc_bytes")) (protected-objects - . ,(make-gauge-metric registry "guile_gc_protected_objects")) + . ,(make-gauge-metric registry "guile_gc_protected_objects_total")) (gc-times - . ,(make-gauge-metric registry "guile_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)))) From 4d1044bc161d891dc8dc65fb0372acac0c45a995 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 19 Nov 2025 12:31:56 +0000 Subject: [PATCH 09/10] Check the value for metric-set --- prometheus.scm | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/prometheus.scm b/prometheus.scm index 83061a7..d6caa6a 100644 --- a/prometheus.scm +++ b/prometheus.scm @@ -350,6 +350,12 @@ values are the values." '(gauge)) (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) From 49be2bc1ae7ff53b35aeefc0dd60ffa8768b5184 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 19 Nov 2025 12:34:24 +0000 Subject: [PATCH 10/10] Remove usage of error --- prometheus.scm | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/prometheus.scm b/prometheus.scm index d6caa6a..f6e4c23 100644 --- a/prometheus.scm +++ b/prometheus.scm @@ -291,10 +291,13 @@ To specify values for the labels, pass an alist as values are the values." (unless (memq (metric-type metric) '(counter gauge)) - (error "can only increment counter and gauge metrics")) + (raise-exception + (make-exception-with-message + "can only increment counter and gauge metrics"))) (unless (positive? by) - (error "can only increment positive values")) + (raise-exception + (make-exception-with-message "can only increment positive values"))) (let ((canonical-labels (canonicalise-label-values label-values)) @@ -322,7 +325,8 @@ To specify values for the labels, pass an alist as values are the values." (unless (memq (metric-type metric) '(gauge)) - (error "can only increment gauge metrics")) + (raise-exception + (make-exception-with-message "can only increment gauge metrics"))) (let ((canonical-labels (canonicalise-label-values label-values)) @@ -348,7 +352,8 @@ To specify values for the labels, pass an alist as values are the values." (unless (memq (metric-type metric) '(gauge)) - (error "can only set gauge metrics")) + (raise-exception + (make-exception-with-message "can only set gauge metrics"))) (unless (number? value) (raise-exception @@ -374,7 +379,9 @@ To specify values for the labels, pass an alist as values are the values." (unless (histogram-metric-type? (metric-type metric)) - (error "can only observe histogram metrics")) + (raise-exception + (make-exception-with-message + "can only observe histogram metrics"))) (let ((canonical-labels (canonicalise-label-values label-values))