Merge pull request mirage#14 from talex5/histogram

Histograms

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

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)

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. *)

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 () =