cbaines/guile-prometheus
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Compare commits

base: cbaines:49be2bc1ae7ff53b35aeefc0dd60ffa8768b5184
Branches Tags
cbaines:trunk
..
compare: cbaines:0b22a8760cd9ed5f9a0a855a0ef62bab88e46067
Branches Tags
cbaines:trunk

No commits in common. "49be2bc1ae7ff53b35aeefc0dd60ffa8768b5184" and "0b22a8760cd9ed5f9a0a855a0ef62bab88e46067" have entirely different histories.
49be2bc1ae ... 0b22a8760c

1 changed files with 71 additions and 293 deletions
Download patch file Download diff file Expand all files Collapse all files

364
prometheus.scm
View file

@ -21,12 +21,10 @@
(define-module (prometheus) (define-module (prometheus)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 threads) #:use-module (ice-9 threads)
#:use-module (ice-9 exceptions) #:use-module (ice-9 exceptions)
#:use-module (ice-9 textual-ports)
#:export (make-metrics-registry #:export (make-metrics-registry
metrics-registry-fetch-metric metrics-registry-fetch-metric
write-metrics write-metrics
@ -34,11 +32,6 @@
make-counter-metric make-counter-metric
make-gauge-metric make-gauge-metric
%default-histogram-buckets
linear-histogram-buckets
exponential-histogram-buckets
make-histogram-metric make-histogram-metric
metric-increment metric-increment
@ -46,10 +39,7 @@
metric-set metric-set
metric-observe metric-observe
call-with-duration-metric call-with-duration-metric))
get-gc-metrics-updater
get-process-metrics-updater))
(define-record-type <metrics-registry> (define-record-type <metrics-registry>
(make-metrics-registry-record metrics-hash namespace) (make-metrics-registry-record metrics-hash namespace)
@ -70,12 +60,13 @@ metrics relate to."
namespace)) namespace))
(define-record-type <metric> (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) mutex)
metric? metric?
(type metric-type) (type metric-type)
(name metric-name) (name metric-name)
(values metric-values) (values metric-values)
(registry metric-registry)
(docstring metric-docstring) (docstring metric-docstring)
(labels metric-labels) (labels metric-labels)
(label-preset-values metric-label-preset-values) (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 (make-metric 'counter
name name
(make-hash-table) (make-hash-table)
registry
docstring docstring
labels labels
label-preset-values label-preset-values
@ -150,6 +142,7 @@ list of label names to be permitted for this metric and
(make-metric 'gauge (make-metric 'gauge
name name
(make-hash-table) (make-hash-table)
registry
docstring docstring
(map canonicalise-label labels) (map canonicalise-label labels)
(canonicalise-label-values label-preset-values) (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 ;; 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))) (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 (define* (make-histogram-metric registry name
#:key #:key
(buckets %default-histogram-buckets) (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) (make-metric (make-histogram-metric-type buckets)
name name
(make-hash-table) (make-hash-table)
registry
docstring docstring
labels labels
label-preset-values label-preset-values
@ -291,26 +244,21 @@ To specify values for the labels, pass an alist as
values are the values." values are the values."
(unless (memq (metric-type metric) (unless (memq (metric-type metric)
'(counter gauge)) '(counter gauge))
(raise-exception (error "can only increment counter and gauge metrics"))
(make-exception-with-message
"can only increment counter and gauge metrics")))
(unless (positive? by) (unless (positive? by)
(raise-exception (error "can only increment positive values"))
(make-exception-with-message "can only increment positive values")))
(let ((canonical-labels (let ((canonical-labels
(canonicalise-label-values label-values)) (canonicalise-label-values label-values))
(hash (hash
(metric-values metric))) (metric-values metric)))
(call-with-blocked-asyncs (with-mutex (metric-mutex metric)
(lambda () (hash-set! hash
(with-mutex (metric-mutex metric) canonical-labels
(hash-set! hash (+ by
canonical-labels (or (hash-ref hash canonical-labels)
(+ by 0))))))
(or (hash-ref hash canonical-labels)
0))))))))
(define* (metric-decrement metric (define* (metric-decrement metric
#:key #:key
@ -325,21 +273,18 @@ To specify values for the labels, pass an alist as
values are the values." values are the values."
(unless (memq (metric-type metric) (unless (memq (metric-type metric)
'(gauge)) '(gauge))
(raise-exception (error "can only increment gauge metrics"))
(make-exception-with-message "can only increment gauge metrics")))
(let ((canonical-labels (let ((canonical-labels
(canonicalise-label-values label-values)) (canonicalise-label-values label-values))
(hash (hash
(metric-values metric))) (metric-values metric)))
(call-with-blocked-asyncs (with-mutex (metric-mutex metric)
(lambda () (hash-set! hash
(with-mutex (metric-mutex metric) canonical-labels
(hash-set! hash (+ (* -1 by)
canonical-labels (or (hash-ref hash canonical-labels)
(+ (* -1 by) 0))))))
(or (hash-ref hash canonical-labels)
0))))))))
(define* (metric-set metric value (define* (metric-set metric value
#:key (label-values '())) #:key (label-values '()))
@ -352,21 +297,12 @@ To specify values for the labels, pass an alist as
values are the values." values are the values."
(unless (memq (metric-type metric) (unless (memq (metric-type metric)
'(gauge)) '(gauge))
(raise-exception (error "can only set gauge metrics"))
(make-exception-with-message "can only set gauge metrics")))
(unless (number? value) (with-mutex (metric-mutex metric)
(raise-exception (hash-set! (metric-values metric)
(make-exception-with-message (canonicalise-label-values label-values)
(simple-format #f "metric-set value must be a number: ~A" value)))
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 (define* (metric-observe metric value
#:key (label-values '())) #:key (label-values '()))
@ -379,50 +315,46 @@ To specify values for the labels, pass an alist as
values are the values." values are the values."
(unless (histogram-metric-type? (metric-type metric)) (unless (histogram-metric-type? (metric-type metric))
(raise-exception (error "can only observe histogram metrics"))
(make-exception-with-message
"can only observe histogram metrics")))
(let ((canonical-labels (let ((canonical-labels
(canonicalise-label-values label-values)) (canonicalise-label-values label-values))
(hash (hash
(metric-values metric))) (metric-values metric)))
(call-with-blocked-asyncs (with-mutex (metric-mutex metric)
(lambda () (let* ((buckets
(with-mutex (metric-mutex metric) (histogram-metric-type-buckets (metric-type metric)))
(let* ((buckets (histogram-values-record
(histogram-metric-type-buckets (metric-type metric))) (or (hash-ref hash canonical-labels)
(histogram-values-record (let ((new-record (make-histogram-values (make-vector
(or (hash-ref hash canonical-labels) (length buckets)
(let ((new-record (make-histogram-values (make-vector 0)
(length buckets) 0
0) 0)))
0 (hash-set! hash canonical-labels new-record)
0))) new-record))))
(hash-set! hash canonical-labels new-record)
new-record))))
(set-histogram-values-sum! histogram-values-record (set-histogram-values-sum! histogram-values-record
(+ value (+ value
(histogram-values-sum (histogram-values-sum
histogram-values-record))) histogram-values-record)))
(set-histogram-values-count! histogram-values-record (set-histogram-values-count! histogram-values-record
(+ 1 (+ 1
(histogram-values-count (histogram-values-count
histogram-values-record))) histogram-values-record)))
(let ((bucket-values-vector (histogram-values-buckets (let ((bucket-values-vector (histogram-values-buckets
histogram-values-record))) histogram-values-record)))
(for-each (for-each
(lambda (index bucket-upper-limit) (lambda (index bucket-upper-limit)
(when (<= value bucket-upper-limit) (when (<= value bucket-upper-limit)
(vector-set! bucket-values-vector (vector-set! bucket-values-vector
index index
(+ 1 (+ 1
(vector-ref bucket-values-vector (vector-ref bucket-values-vector
index))))) index)))))
(iota (length buckets)) (iota (length buckets))
buckets)))))))) buckets))))))
(define* (call-with-duration-metric registry metric-name thunk (define* (call-with-duration-metric registry metric-name thunk
#:key #:key
@ -440,13 +372,18 @@ The metric with the name @var{metric-name} is fetched from the
" "
(let* ((metric (let* ((metric
(or (metrics-registry-fetch-metric registry metric-name) (or (metrics-registry-fetch-metric registry metric-name)
(make-histogram-metric (monitor
registry ;; Check once more in case another thread has created
metric-name ;; the metric while this thread was waiting for the
#:buckets buckets ;; mutex
#:docstring docstring (or (metrics-registry-fetch-metric registry metric-name)
#:labels labels (make-histogram-metric
#:label-preset-values label-preset-values))) registry
metric-name
#:buckets buckets
#:docstring docstring
#:labels labels
#:label-preset-values label-preset-values)))))
(start-time (get-internal-real-time))) (start-time (get-internal-real-time)))
(call-with-values (call-with-values
thunk thunk
@ -565,162 +502,3 @@ This procedure takes care of atomically replacing the file."
(lambda (key . args) (lambda (key . args)
(false-if-exception (delete-file template)))))) (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 '("." "..")))))
'()))))))