diff --git a/prometheus.scm b/prometheus.scm index f6e4c23..2a181f8 100644 --- a/prometheus.scm +++ b/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 (make-metrics-registry-record metrics-hash namespace) @@ -70,12 +60,13 @@ metrics relate to." namespace)) (define-record-type - (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 '("." ".."))))) - '()))))))