diff --git a/app/prometheus_app.ml b/app/prometheus_app.ml index 5a77914..e592cd0 100644 --- a/app/prometheus_app.ml +++ b/app/prometheus_app.ml @@ -18,7 +18,7 @@ module TextFormat_0_0_4 = struct | Counter -> Fmt.string f "counter" | Gauge -> Fmt.string f "gauge" | Summary -> Fmt.string f "summary" - (* | Histogram -> Fmt.string f "histogram" *) + | Histogram -> Fmt.string f "histogram" let output_unquoted f s = Fmt.string f @@ Re.replace re_unquoted_escapes ~f:quote s @@ -46,7 +46,13 @@ module TextFormat_0_0_4 = struct | [] -> () | label_values -> Fmt.pf f "{%a}" output_pairs (label_names, label_values) - let output_sample ~base ~label_names ~label_values f { Sample_set.ext; value } = + let output_sample ~base ~label_names ~label_values f { Sample_set.ext; value; bucket } = + let label_names, label_values = match bucket with + | None -> label_names, label_values + | Some (label_name, label_value) -> + let label_value_str = Fmt.strf "%a" output_value label_value in + label_name :: label_names, label_value_str :: label_values + in Fmt.pf f "%a%s%a %a@." MetricName.pp base ext (output_labels ~label_names) label_values diff --git a/src/prometheus.ml b/src/prometheus.ml index d67c8f2..863750d 100644 --- a/src/prometheus.ml +++ b/src/prometheus.ml @@ -43,9 +43,7 @@ type metric_type = | Counter | Gauge | Summary -(* | Histogram -*) module LabelSet = struct type t = string list @@ -83,11 +81,12 @@ module Sample_set = struct type sample = { ext : string; value : float; + bucket : (LabelName.t * float) option; } type t = sample list - let sample ?(ext="") value = { ext; value } + let sample ?(ext="") ?bucket value = { ext; value; bucket } end module CollectorRegistry = struct @@ -131,6 +130,7 @@ module type CHILD = sig val create : unit -> t val values : t -> Sample_set.t val metric_type : metric_type + val validate_label : string -> unit end module Metric(Child : CHILD) : sig @@ -147,6 +147,7 @@ end = struct LabelSetMap.map Child.values t.children let v_labels ~label_names ?(registry=CollectorRegistry.default) ~help ?namespace ?subsystem name = + List.iter Child.validate_label label_names; let label_names = List.map LabelName.v label_names in let metric = MetricInfo.v ~metric_type:Child.metric_type ~help ~label_names ?namespace ?subsystem name in let t = { @@ -180,6 +181,7 @@ module Counter = struct let create () = ref 0.0 let values t = [Sample_set.sample !t] let metric_type = Counter + let validate_label _ = () end) let inc_one t = @@ -196,6 +198,7 @@ module Gauge = struct let create () = ref 0.0 let values t = [Sample_set.sample !t] let metric_type = Gauge + let validate_label _ = () end) let inc t v = @@ -235,6 +238,10 @@ module Summary = struct Sample_set.sample ~ext:"_count" t.count; ] let metric_type = Summary + + let validate_label = function + | "quantile" -> failwith "Can't use special label 'quantile' in summary" + | _ -> () end include Metric(Child) @@ -252,3 +259,116 @@ module Summary = struct Lwt.return_unit ) end + +module Histogram_spec = struct + type t = float array (* Upper bounds *) + + let make at_index_f count = + let real_at_index i = + if i >= count then + infinity + else + at_index_f i + in + Array.init (count + 1) real_at_index + + let of_linear start interval count = + let at_index i = + let f = float_of_int i in + start +. (interval *. f) + in + make at_index count + + let of_exponential start factor count = + let at_index i = + let multiplier = factor ** (float_of_int i) in + start *. multiplier + in + make at_index count + + let of_list lst = + let length = List.length lst in + make (List.nth lst) length + + (* The index at which to record a value [v]. *) + let index t v = + let rec aux index = + if v <= t.(index) then index + else aux (index + 1) + in + aux 0 +end + +module type BUCKETS = sig + val spec : Histogram_spec.t +end + +module type HISTOGRAM = sig + include METRIC + val observe : t -> float -> unit + val time : t -> (unit -> float) -> (unit -> 'a Lwt.t) -> 'a Lwt.t +end + +let bucket_label = LabelName.v "le" + +module Histogram (Buckets : BUCKETS) = struct + module Child = struct + type t = { + upper_bounds : Histogram_spec.t; + counts : float array; + mutable sum : float; + } + + let create () = + let count = Array.length Buckets.spec in + let counts = Array.make count 0. in + { upper_bounds = Buckets.spec; counts; sum = 0. } + + let values t = + let count = Array.length t.counts in + let rec fold val_acc acc index = + if index = count then + Sample_set.sample ~ext:"_sum" t.sum :: + Sample_set.sample ~ext:"_count" val_acc :: + acc + else + let val_acc = t.counts.(index) +. val_acc in + let bucket = (bucket_label, t.upper_bounds.(index)) in + let acc = Sample_set.sample ~ext:"_bucket" val_acc ~bucket :: acc in + fold val_acc acc (index + 1) + in + fold 0. [] 0 + + let metric_type = Histogram + + let validate_label = function + | "le" -> failwith "Can't use special label 'le' in histogram" + | _ -> () + end + + include Metric(Child) + + let observe t v = + let open Child in + let index = Histogram_spec.index t.upper_bounds v in + t.counts.(index) <- t.counts.(index) +. 1.; + t.sum <- t.sum +. v + + let time t gettimeofday fn = + let start = gettimeofday () in + Lwt.finalize fn + (fun () -> + let finish = gettimeofday () in + observe t (finish -. start); + Lwt.return_unit + ) +end + +module DefaultHistogram = Histogram ( + struct + let spec = + Histogram_spec.of_list [0.005; 0.01; 0.025; 0.05; + 0.075; 0.1 ; 0.25 ; 0.5; + 0.75 ; 1. ; 2.5 ; 5.; + 7.5 ; 10. ] + end) diff --git a/src/prometheus.mli b/src/prometheus.mli index 006c3a8..0ab9a4f 100644 --- a/src/prometheus.mli +++ b/src/prometheus.mli @@ -16,6 +16,7 @@ type metric_type = | Counter | Gauge | Summary + | Histogram module type NAME = sig type t = private string @@ -55,6 +56,7 @@ module Sample_set : sig type sample = { ext : string; (** An extension to append to the base metric name. *) value : float; + bucket : (LabelName.t * float) option; (** The "le" or "quantile" label and value, if any. *) } type t = sample list @@ -64,7 +66,7 @@ module Sample_set : sig For example, a "summary" sample set contains "_sum" and "_count" values. *) - val sample : ?ext:string -> float -> sample + val sample : ?ext:string -> ?bucket:(LabelName.t * float) -> float -> sample end module CollectorRegistry : sig @@ -168,3 +170,39 @@ module Summary : sig end (** A summary is a metric that records both the number of readings and their total. This allows calculating the average. *) + +module Histogram_spec : sig + type t + + val of_linear : float -> float -> int -> t + (** [of_linear start interval count] will return a histogram type with + [count] buckets with values starting at [start] and [interval] apart: + [(start, start+interval, start + (2 * interval), ... start + ((count-1) * interval), infinity)]. + [count] does not include the infinity bucket. + *) + + val of_exponential : float -> float -> int -> t + (** [of_exponential start factor count] will return a histogram type with + [count] buckets with values starting at [start] and every next item [previous*factor]. + [count] does not include the infinity bucket. + *) + + val of_list : float list -> t + (** [of_list [0.5; 1.]] will return a histogram with buckets [0.5;1.;infinity]. *) +end + +module type HISTOGRAM = sig + include METRIC + + val observe : t -> float -> unit + (** [observe t v] adds one to the appropriate bucket for v and adds v to the sum. *) + + val time : t -> (unit -> float) -> (unit -> 'a Lwt.t) -> 'a Lwt.t + (** [time t gettime f] calls [gettime ()] before and after executing [f ()] and + observes the difference. *) +end + +module Histogram (Buckets : sig val spec : Histogram_spec.t end) : HISTOGRAM + +module DefaultHistogram : HISTOGRAM +(** A histogram configured with reasonable defaults for measuring network request times in seconds. *) diff --git a/tests/test.ml b/tests/test.ml index 6313bb9..e021ab1 100644 --- a/tests/test.ml +++ b/tests/test.ml @@ -27,6 +27,37 @@ let test_metrics () = " output +module Buckets = struct + let spec = Histogram_spec.of_list [0.25; 0.5] +end + +module H = Histogram (Buckets) + +let test_histogram () = + let registry = CollectorRegistry.create () in + let requests = + let label_names = ["method"; "path"] in + H.v_labels ~label_names ~registry ~help:"Requests" ~namespace:"dkci" ~subsystem:"tests" "requests" in + let foo = H.labels requests ["GET"; "/foo"] in + let bar = H.labels requests ["PUT"; "/bar"] in + H.observe foo 0.12; + H.observe bar 0.33; + let output = Fmt.to_to_string TextFormat_0_0_4.output (CollectorRegistry.collect registry) in + Alcotest.(check string) "Text output" + "#HELP dkci_tests_requests Requests\n\ + #TYPE dkci_tests_requests histogram\n\ + dkci_tests_requests_sum{method=\"GET\", path=\"/foo\"} 0.12\n\ + dkci_tests_requests_count{method=\"GET\", path=\"/foo\"} 1\n\ + dkci_tests_requests_bucket{le=\"+Inf\", method=\"GET\", path=\"/foo\"} 1\n\ + dkci_tests_requests_bucket{le=\"0.5\", method=\"GET\", path=\"/foo\"} 1\n\ + dkci_tests_requests_bucket{le=\"0.25\", method=\"GET\", path=\"/foo\"} 1\n\ + dkci_tests_requests_sum{method=\"PUT\", path=\"/bar\"} 0.33\n\ + dkci_tests_requests_count{method=\"PUT\", path=\"/bar\"} 1\n\ + dkci_tests_requests_bucket{le=\"+Inf\", method=\"PUT\", path=\"/bar\"} 1\n\ + dkci_tests_requests_bucket{le=\"0.5\", method=\"PUT\", path=\"/bar\"} 1\n\ + dkci_tests_requests_bucket{le=\"0.25\", method=\"PUT\", path=\"/bar\"} 0\n\ + " + output (* "^[a-zA-Z_][a-zA-Z0-9_]*$" *) let valid_labels = [ @@ -100,6 +131,7 @@ let test_invalid_metrics_set = List.map (fun metric -> let test_set = [ "Metrics", `Quick, test_metrics; + "Histogram", `Quick, test_histogram; ] let () =