diff --git a/src/prometheus/common_.ml b/src/prometheus/common_.ml new file mode 100644 index 00000000..bb70b2d7 --- /dev/null +++ b/src/prometheus/common_.ml @@ -0,0 +1,3 @@ +module A = Tiny_httpd_atomic_ + +let spf = Printf.sprintf diff --git a/src/prometheus/dune b/src/prometheus/dune new file mode 100644 index 00000000..9cf17df0 --- /dev/null +++ b/src/prometheus/dune @@ -0,0 +1,7 @@ + +(library + (name tiny_httpd_prometheus) + (public_name tiny_httpd.prometheus) + (synopsis "Metrics using prometheus") + (private_modules common_) + (libraries tiny_httpd)) diff --git a/src/prometheus/tiny_httpd_prometheus.ml b/src/prometheus/tiny_httpd_prometheus.ml new file mode 100644 index 00000000..026af9db --- /dev/null +++ b/src/prometheus/tiny_httpd_prometheus.ml @@ -0,0 +1,88 @@ +(* + https://prometheus.io/docs/instrumenting/exposition_formats/#text-based-format + *) + +open Common_ + +let bpf = Printf.bprintf + +type tags = (string * string) list +type counter = { name: string; tags: tags; descr: string option; c: int A.t } +type gauge = { name: string; tags: tags; descr: string option; g: int A.t } +type registry = { mutable counters: counter list; mutable gauges: gauge list } + +let validate_descr_ what s = + if String.contains s '\n' then + invalid_arg (spf "%s: description cannot contain '\n'" what) + +let emit_tags_ buf tags = + if tags <> [] then ( + bpf buf "{"; + List.iteri + (fun i (k, v) -> + if i > 0 then bpf buf ","; + bpf buf "%s=%S" k v) + tags; + bpf buf "}" + ) + +module Counter = struct + type t = counter + + let create (reg : registry) ?(tags = []) ?descr name : t = + let self : t = { name; descr; tags; c = A.make 0 } in + Option.iter (validate_descr_ "counter") descr; + reg.counters <- self :: reg.counters; + self + + let emit buf (self : t) = + Option.iter (bpf buf "# HELP %s %s\n" self.name) self.descr; + bpf buf "# TYPE %s counter\n" self.name; + bpf buf "%s%a %d\n" self.name emit_tags_ self.tags (A.get self.c); + () + + let[@inline] inc self = A.incr self.c + let[@inline] inc_by self n = ignore (A.fetch_and_add self.c n : int) + let[@inline] dec self = A.decr self.c + let[@inline] dec_by self n = ignore (A.fetch_and_add self.c (-n) : int) +end + +module Gauge = struct + type t = gauge + + let create (reg : registry) ?(tags = []) ?descr name : t = + Option.iter (validate_descr_ "gauge") descr; + let self : t = { name; descr; tags; g = A.make 0 } in + reg.gauges <- self :: reg.gauges; + self + + let emit buf (self : t) = + Option.iter (bpf buf "# HELP %s %s\n" self.name) self.descr; + bpf buf "# TYPE %s gauge\n" self.name; + bpf buf "%s%a %d\n" self.name emit_tags_ self.tags (A.get self.g); + () + + let[@inline] set self x = A.set self.g x + let[@inline] inc self = A.incr self.g + let[@inline] inc_by self n = ignore (A.fetch_and_add self.g n : int) + let[@inline] dec self = A.decr self.g + let[@inline] dec_by self n = ignore (A.fetch_and_add self.g (-n) : int) +end + +module Registry = struct + type t = registry + + let create () : t = { counters = []; gauges = [] } + + let emit (buf : Buffer.t) (self : t) : unit = + List.iter (Gauge.emit buf) self.gauges; + List.iter (Counter.emit buf) self.counters; + () + + let emit_str (self : t) : string = + let buf = Buffer.create 32 in + emit buf self; + Buffer.contents buf +end + +let global = Registry.create () diff --git a/src/prometheus/tiny_httpd_prometheus.mli b/src/prometheus/tiny_httpd_prometheus.mli new file mode 100644 index 00000000..0cd603f8 --- /dev/null +++ b/src/prometheus/tiny_httpd_prometheus.mli @@ -0,0 +1,49 @@ +(** Expose metrics over HTTP in the prometheus format *) + +type tags = (string * string) list + +(** Registry for metrics. *) +module Registry : sig + type t + (** The registry contains a group of metrics *) + + val create : unit -> t + + val emit : Buffer.t -> t -> unit + (** Write metrics into the given buffer. The buffer will be + cleared first thing. *) + + val emit_str : t -> string +end + +val global : Registry.t + +(** Counters *) +module Counter : sig + type t + (** A counter, monotonically increasing *) + + val create : Registry.t -> ?tags:tags -> ?descr:string -> string -> t + val inc : t -> unit + val inc_by : t -> int -> unit + val dec : t -> unit + val dec_by : t -> int -> unit +end + +(** Gauges *) +module Gauge : sig + type t + (** A gauge, taking arbitrary values *) + + val create : Registry.t -> ?tags:tags -> ?descr:string -> string -> t + val set : t -> int -> unit + val inc : t -> unit + val inc_by : t -> int -> unit + val dec : t -> unit + val dec_by : t -> int -> unit +end + +(* TODO: + module Histogram : sig + end +*)