diff --git a/prometheus.scm b/prometheus.scm index 2a181f8..f6e4c23 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 @@ -32,6 +34,11 @@ make-counter-metric make-gauge-metric + + %default-histogram-buckets + linear-histogram-buckets + exponential-histogram-buckets + make-histogram-metric metric-increment @@ -39,7 +46,10 @@ metric-set metric-observe - call-with-duration-metric)) + call-with-duration-metric + + get-gc-metrics-updater + get-process-metrics-updater)) (define-record-type (make-metrics-registry-record metrics-hash namespace) @@ -60,13 +70,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) @@ -113,7 +122,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 @@ -142,7 +150,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) @@ -164,6 +171,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) @@ -193,7 +241,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 @@ -244,21 +291,26 @@ 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)) (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 @@ -273,18 +325,21 @@ 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)) (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 '())) @@ -297,12 +352,21 @@ 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"))) - (with-mutex (metric-mutex metric) - (hash-set! (metric-values metric) - (canonicalise-label-values label-values) - value))) + (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))))) (define* (metric-observe metric value #:key (label-values '())) @@ -315,46 +379,50 @@ 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)) (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 @@ -372,18 +440,13 @@ 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))))) + (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 @@ -502,3 +565,162 @@ 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 '("." ".."))))) + '()))))))