From 53280ed5628b5dd50f4ab74847ad81dd7281b61d Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 18 Jan 2024 21:11:46 -0500
Subject: [PATCH 01/11] basic prometheus library

---
 src/prometheus/common_.ml                |  3 +
 src/prometheus/dune                      |  7 ++
 src/prometheus/tiny_httpd_prometheus.ml  | 88 ++++++++++++++++++++++++
 src/prometheus/tiny_httpd_prometheus.mli | 49 +++++++++++++
 4 files changed, 147 insertions(+)
 create mode 100644 src/prometheus/common_.ml
 create mode 100644 src/prometheus/dune
 create mode 100644 src/prometheus/tiny_httpd_prometheus.ml
 create mode 100644 src/prometheus/tiny_httpd_prometheus.mli

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

From da7a27552a5215b075ba0a600961c81a79bee7c0 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 18 Jan 2024 21:11:58 -0500
Subject: [PATCH 02/11] wip: tests for prometheus

---
 tests/prometheus/dune            |  4 ++++
 tests/prometheus/t_prom.expected | 22 ++++++++++++++++++++++
 tests/prometheus/t_prom.ml       | 23 +++++++++++++++++++++++
 3 files changed, 49 insertions(+)
 create mode 100644 tests/prometheus/dune
 create mode 100644 tests/prometheus/t_prom.expected
 create mode 100644 tests/prometheus/t_prom.ml

diff --git a/tests/prometheus/dune b/tests/prometheus/dune
new file mode 100644
index 00000000..da921019
--- /dev/null
+++ b/tests/prometheus/dune
@@ -0,0 +1,4 @@
+
+(test
+  (name t_prom)
+  (libraries tiny_httpd.prometheus))
diff --git a/tests/prometheus/t_prom.expected b/tests/prometheus/t_prom.expected
new file mode 100644
index 00000000..590b6c82
--- /dev/null
+++ b/tests/prometheus/t_prom.expected
@@ -0,0 +1,22 @@
+==== first try ====
+```
+# TYPE yolo_gauge gauge
+yolo_gauge{level="max"} 2525
+# HELP t_c2 more awesome than c1
+# TYPE t_c2 counter
+t_c2 1
+# TYPE t_c1 counter
+t_c1 42
+
+```
+==== second try====
+```
+# TYPE yolo_gauge gauge
+yolo_gauge{level="max"} 42000
+# HELP t_c2 more awesome than c1
+# TYPE t_c2 counter
+t_c2 2
+# TYPE t_c1 counter
+t_c1 53
+
+```
diff --git a/tests/prometheus/t_prom.ml b/tests/prometheus/t_prom.ml
new file mode 100644
index 00000000..8e9fe8b5
--- /dev/null
+++ b/tests/prometheus/t_prom.ml
@@ -0,0 +1,23 @@
+module P = Tiny_httpd_prometheus
+
+let pf = Printf.printf
+let reg = P.Registry.create ()
+let c1 = P.Counter.create reg "t_c1"
+let c2 = P.Counter.create reg "t_c2" ~descr:"more awesome than c1"
+let g1 = P.Gauge.create reg ~tags:[ "level", "max" ] "yolo_gauge"
+
+let () =
+  print_endline "==== first try ====";
+  P.Counter.inc_by c1 42;
+  P.Counter.inc c2;
+  P.Gauge.set g1 2525;
+
+  pf "```\n%s\n```\n" @@ P.Registry.emit_str reg
+
+let () =
+  print_endline "==== second try====";
+  P.Counter.inc_by c1 11;
+  P.Counter.inc c2;
+  P.Gauge.set g1 42_000;
+
+  pf "```\n%s\n```\n" @@ P.Registry.emit_str reg

From 9f9017f26ac612e3134a10c185bc06b8ff5e4fe4 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 18 Jan 2024 21:25:49 -0500
Subject: [PATCH 03/11] add prometheus middleware for httpd

---
 src/prometheus/tiny_httpd_prometheus.ml  | 34 ++++++++++++++++++------
 src/prometheus/tiny_httpd_prometheus.mli | 18 +++++++------
 tests/prometheus/t_prom.ml               |  8 +++---
 3 files changed, 40 insertions(+), 20 deletions(-)

diff --git a/src/prometheus/tiny_httpd_prometheus.ml b/src/prometheus/tiny_httpd_prometheus.ml
index 026af9db..d9157ddf 100644
--- a/src/prometheus/tiny_httpd_prometheus.ml
+++ b/src/prometheus/tiny_httpd_prometheus.ml
@@ -41,10 +41,10 @@ module Counter = struct
     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)
+  let[@inline] incr self = A.incr self.c
+  let[@inline] incr_by self n = ignore (A.fetch_and_add self.c n : int)
+  let[@inline] decr self = A.decr self.c
+  let[@inline] decr_by self n = ignore (A.fetch_and_add self.c (-n) : int)
 end
 
 module Gauge = struct
@@ -63,10 +63,10 @@ module Gauge = struct
     ()
 
   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)
+  let[@inline] incr self = A.incr self.g
+  let[@inline] incr_by self n = ignore (A.fetch_and_add self.g n : int)
+  let[@inline] decr self = A.decr self.g
+  let[@inline] decr_by self n = ignore (A.fetch_and_add self.g (-n) : int)
 end
 
 module Registry = struct
@@ -86,3 +86,21 @@ module Registry = struct
 end
 
 let global = Registry.create ()
+
+module H = Tiny_httpd
+
+let http_middleware (reg : Registry.t) : H.Middleware.t =
+  let c_req =
+    Counter.create reg "tiny_httpd_requests" ~descr:"number of HTTP requests"
+  in
+  let c_err =
+    Counter.create reg "tiny_httpd_errors" ~descr:"number of HTTP errors"
+  in
+
+  fun h : H.Middleware.handler ->
+    fun req ~resp : unit ->
+     Counter.incr c_req;
+     h req ~resp:(fun (response : H.Response.t) ->
+         let code = response.code in
+         if code < 200 || code >= 300 then Counter.incr c_err;
+         resp response)
diff --git a/src/prometheus/tiny_httpd_prometheus.mli b/src/prometheus/tiny_httpd_prometheus.mli
index 0cd603f8..b295f687 100644
--- a/src/prometheus/tiny_httpd_prometheus.mli
+++ b/src/prometheus/tiny_httpd_prometheus.mli
@@ -24,10 +24,10 @@ module Counter : sig
   (** 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
+  val incr : t -> unit
+  val incr_by : t -> int -> unit
+  val decr : t -> unit
+  val decr_by : t -> int -> unit
 end
 
 (** Gauges *)
@@ -37,13 +37,15 @@ module Gauge : sig
 
   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
+  val incr : t -> unit
+  val incr_by : t -> int -> unit
+  val decr : t -> unit
+  val decr_by : t -> int -> unit
 end
 
 (* TODO:
    module Histogram : sig
    end
 *)
+
+val http_middleware : Registry.t -> Tiny_httpd.Middleware.t
diff --git a/tests/prometheus/t_prom.ml b/tests/prometheus/t_prom.ml
index 8e9fe8b5..f8144b7b 100644
--- a/tests/prometheus/t_prom.ml
+++ b/tests/prometheus/t_prom.ml
@@ -8,16 +8,16 @@ let g1 = P.Gauge.create reg ~tags:[ "level", "max" ] "yolo_gauge"
 
 let () =
   print_endline "==== first try ====";
-  P.Counter.inc_by c1 42;
-  P.Counter.inc c2;
+  P.Counter.incr_by c1 42;
+  P.Counter.incr c2;
   P.Gauge.set g1 2525;
 
   pf "```\n%s\n```\n" @@ P.Registry.emit_str reg
 
 let () =
   print_endline "==== second try====";
-  P.Counter.inc_by c1 11;
-  P.Counter.inc c2;
+  P.Counter.incr_by c1 11;
+  P.Counter.incr c2;
   P.Gauge.set g1 42_000;
 
   pf "```\n%s\n```\n" @@ P.Registry.emit_str reg

From 66ddee35227c88b5e201e5829288787fe38e42ff Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 18 Jan 2024 21:34:47 -0500
Subject: [PATCH 04/11] more http handling

---
 src/prometheus/tiny_httpd_prometheus.ml  | 9 +++++++++
 src/prometheus/tiny_httpd_prometheus.mli | 7 +++++++
 2 files changed, 16 insertions(+)

diff --git a/src/prometheus/tiny_httpd_prometheus.ml b/src/prometheus/tiny_httpd_prometheus.ml
index d9157ddf..e0a1f3cd 100644
--- a/src/prometheus/tiny_httpd_prometheus.ml
+++ b/src/prometheus/tiny_httpd_prometheus.ml
@@ -104,3 +104,12 @@ let http_middleware (reg : Registry.t) : H.Middleware.t =
          let code = response.code in
          if code < 200 || code >= 300 then Counter.incr c_err;
          resp response)
+
+let add_route_to_server (server : H.t) (reg : registry) : unit =
+  H.add_route_handler server H.Route.(exact "metrics" @/ return) @@ fun _req ->
+  let str = Registry.emit_str reg in
+  H.Response.make_string @@ Ok str
+
+let instrument_server (server : H.t) reg : unit =
+  H.add_middleware ~stage:(`Stage 1) server (http_middleware global);
+  add_route_to_server server reg
diff --git a/src/prometheus/tiny_httpd_prometheus.mli b/src/prometheus/tiny_httpd_prometheus.mli
index b295f687..a2104af1 100644
--- a/src/prometheus/tiny_httpd_prometheus.mli
+++ b/src/prometheus/tiny_httpd_prometheus.mli
@@ -49,3 +49,10 @@ end
 *)
 
 val http_middleware : Registry.t -> Tiny_httpd.Middleware.t
+(** Middleware to get basic metrics about HTTP requests *)
+
+val add_route_to_server : Tiny_httpd.t -> Registry.t -> unit
+(** Add a "/metrics" route to the server *)
+
+val instrument_server : Tiny_httpd.t -> Registry.t -> unit
+(** Add middleware and route *)

From 2da3bd3fc7cad606834e6548f66e49acc9927bc2 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 18 Jan 2024 21:36:20 -0500
Subject: [PATCH 05/11] compat old ocaml

---
 src/prometheus/tiny_httpd_prometheus.ml | 12 ++++++++----
 1 file changed, 8 insertions(+), 4 deletions(-)

diff --git a/src/prometheus/tiny_httpd_prometheus.ml b/src/prometheus/tiny_httpd_prometheus.ml
index e0a1f3cd..249d14f4 100644
--- a/src/prometheus/tiny_httpd_prometheus.ml
+++ b/src/prometheus/tiny_httpd_prometheus.ml
@@ -26,17 +26,21 @@ let emit_tags_ buf tags =
     bpf buf "}"
   )
 
+let opt_iter_ f = function
+  | None -> ()
+  | Some x -> f x
+
 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;
+    opt_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;
+    opt_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);
     ()
@@ -51,13 +55,13 @@ module Gauge = struct
   type t = gauge
 
   let create (reg : registry) ?(tags = []) ?descr name : t =
-    Option.iter (validate_descr_ "gauge") descr;
+    opt_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;
+    opt_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);
     ()

From c19b8dc16f80cb982b254de0b9862fc8703803f6 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 18 Jan 2024 22:05:23 -0500
Subject: [PATCH 06/11] add histograms to prometheus

---
 dune-project                             |  2 +
 src/dune                                 |  2 +-
 src/prometheus/dune                      | 15 +++--
 src/prometheus/time_.default.ml          |  3 +
 src/prometheus/time_.mli                 |  1 +
 src/prometheus/time_.mtime.ml            |  3 +
 src/prometheus/tiny_httpd_prometheus.ml  | 84 +++++++++++++++++++++++-
 src/prometheus/tiny_httpd_prometheus.mli | 15 +++++
 tests/prometheus/t_prom.expected         | 20 ++++++
 tests/prometheus/t_prom.ml               | 17 +++++
 tiny_httpd.opam                          |  3 +
 11 files changed, 157 insertions(+), 8 deletions(-)
 create mode 100644 src/prometheus/time_.default.ml
 create mode 100644 src/prometheus/time_.mli
 create mode 100644 src/prometheus/time_.mtime.ml

diff --git a/dune-project b/dune-project
index 415fe81c..95927d24 100644
--- a/dune-project
+++ b/dune-project
@@ -13,6 +13,8 @@
   (name tiny_httpd)
   (synopsis "Minimal HTTP server using threads")
   (tags (http thread server tiny_httpd http_of_dir simplehttpserver))
+  (depopts
+    (mtime (>= 2.0)))
   (depends
     seq
     base-threads
diff --git a/src/dune b/src/dune
index 89ba2327..680ebc43 100644
--- a/src/dune
+++ b/src/dune
@@ -7,7 +7,7 @@
 (library
   (name tiny_httpd)
   (public_name tiny_httpd)
-  (libraries threads seq)
+  (libraries threads seq unix)
   (wrapped false))
 
 (rule
diff --git a/src/prometheus/dune b/src/prometheus/dune
index 9cf17df0..5da724e5 100644
--- a/src/prometheus/dune
+++ b/src/prometheus/dune
@@ -1,7 +1,12 @@
 
+
 (library
-  (name tiny_httpd_prometheus)
-  (public_name tiny_httpd.prometheus)
-  (synopsis "Metrics using prometheus")
-  (private_modules common_)
-  (libraries tiny_httpd))
+ (name tiny_httpd_prometheus)
+ (public_name tiny_httpd.prometheus)
+ (synopsis "Metrics using prometheus")
+ (private_modules common_ time_)
+ (libraries
+  tiny_httpd unix
+  (select time_.ml from
+   (mtime mtime.clock.os -> time_.mtime.ml)
+   (-> time_.default.ml))))
diff --git a/src/prometheus/time_.default.ml b/src/prometheus/time_.default.ml
new file mode 100644
index 00000000..86dd302c
--- /dev/null
+++ b/src/prometheus/time_.default.ml
@@ -0,0 +1,3 @@
+let[@inline] now_us () =
+  let t = Unix.gettimeofday () in
+  t *. 1e6 |> ceil
diff --git a/src/prometheus/time_.mli b/src/prometheus/time_.mli
new file mode 100644
index 00000000..d6824fba
--- /dev/null
+++ b/src/prometheus/time_.mli
@@ -0,0 +1 @@
+val now_us : unit -> float
diff --git a/src/prometheus/time_.mtime.ml b/src/prometheus/time_.mtime.ml
new file mode 100644
index 00000000..65e2ec73
--- /dev/null
+++ b/src/prometheus/time_.mtime.ml
@@ -0,0 +1,3 @@
+let[@inline] now_us () =
+  let t = Mtime_clock.now_ns () in
+  Int64.(div t 1000L |> to_float)
diff --git a/src/prometheus/tiny_httpd_prometheus.ml b/src/prometheus/tiny_httpd_prometheus.ml
index 249d14f4..bbede737 100644
--- a/src/prometheus/tiny_httpd_prometheus.ml
+++ b/src/prometheus/tiny_httpd_prometheus.ml
@@ -9,7 +9,20 @@ 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 }
+
+type histogram = {
+  name: string;
+  tags: tags;
+  descr: string option;
+  sum: float A.t;
+  buckets: (float * int A.t) array;
+}
+
+type registry = {
+  mutable counters: counter list;
+  mutable gauges: gauge list;
+  mutable hists: histogram list;
+}
 
 let validate_descr_ what s =
   if String.contains s '\n' then
@@ -73,14 +86,71 @@ module Gauge = struct
   let[@inline] decr_by self n = ignore (A.fetch_and_add self.g (-n) : int)
 end
 
+module Histogram = struct
+  type t = histogram
+
+  let create reg ?(tags = []) ?descr ~buckets name : t =
+    opt_iter_ (validate_descr_ "histogram") descr;
+    let buckets =
+      List.sort Float.compare buckets
+      |> List.map (fun thresh -> thresh, A.make 0)
+    in
+    let buckets = Array.of_list @@ buckets @ [ infinity, A.make 0 ] in
+    let self : t = { name; descr; tags; sum = A.make 0.; buckets } in
+    reg.hists <- self :: reg.hists;
+    self
+
+  let add (self : t) n =
+    while
+      let old = A.get self.sum in
+      not (A.compare_and_set self.sum old (old +. n))
+    do
+      ()
+    done;
+    let i = ref 0 in
+    let continue = ref true in
+    while !continue && !i < Array.length self.buckets do
+      let thresh, count = self.buckets.(!i) in
+      if n <= thresh then (
+        continue := false;
+        A.incr count
+      ) else
+        incr i
+    done
+
+  let emit buf (self : t) : unit =
+    opt_iter_ (bpf buf "# HELP %s %s\n" self.name) self.descr;
+    bpf buf "# TYPE %s histogram\n" self.name;
+
+    let count = ref 0 in
+    for i = 0 to Array.length self.buckets - 1 do
+      let thresh, buck_count = self.buckets.(i) in
+      count := !count + A.get buck_count;
+
+      let name =
+        if thresh = infinity then
+          "+Inf"
+        else
+          string_of_float thresh
+      in
+      bpf buf "%s%a %d\n" self.name emit_tags_
+        (("le", name) :: self.tags)
+        !count
+    done;
+    bpf buf "%s_count%a %d\n" self.name emit_tags_ self.tags !count;
+    bpf buf "%s_sum%a %.3f\n" self.name emit_tags_ self.tags (A.get self.sum);
+    ()
+end
+
 module Registry = struct
   type t = registry
 
-  let create () : t = { counters = []; gauges = [] }
+  let create () : t = { counters = []; gauges = []; hists = [] }
 
   let emit (buf : Buffer.t) (self : t) : unit =
     List.iter (Gauge.emit buf) self.gauges;
     List.iter (Counter.emit buf) self.counters;
+    List.iter (Histogram.emit buf) self.hists;
     ()
 
   let emit_str (self : t) : string =
@@ -100,12 +170,22 @@ let http_middleware (reg : Registry.t) : H.Middleware.t =
   let c_err =
     Counter.create reg "tiny_httpd_errors" ~descr:"number of HTTP errors"
   in
+  let h_latency =
+    Histogram.create reg "tiny_httpd_latency" ~descr:"latency of HTTP responses"
+      ~buckets:[ 0.001; 0.01; 0.1; 0.5; 1.; 5.; 10. ]
+  in
 
   fun h : H.Middleware.handler ->
     fun req ~resp : unit ->
+     let start = Time_.now_us () in
      Counter.incr c_req;
      h req ~resp:(fun (response : H.Response.t) ->
          let code = response.code in
+
+         let elapsed_us = Time_.now_us () -. start in
+         let elapsed_s = elapsed_us /. 1e6 in
+         Histogram.add h_latency elapsed_s;
+
          if code < 200 || code >= 300 then Counter.incr c_err;
          resp response)
 
diff --git a/src/prometheus/tiny_httpd_prometheus.mli b/src/prometheus/tiny_httpd_prometheus.mli
index a2104af1..e82a5e13 100644
--- a/src/prometheus/tiny_httpd_prometheus.mli
+++ b/src/prometheus/tiny_httpd_prometheus.mli
@@ -43,6 +43,21 @@ module Gauge : sig
   val decr_by : t -> int -> unit
 end
 
+module Histogram : sig
+  type t
+  (** Histogram *)
+
+  val create :
+    Registry.t ->
+    ?tags:tags ->
+    ?descr:string ->
+    buckets:float list ->
+    string ->
+    t
+
+  val add : t -> float -> unit
+end
+
 (* TODO:
    module Histogram : sig
    end
diff --git a/tests/prometheus/t_prom.expected b/tests/prometheus/t_prom.expected
index 590b6c82..0305272e 100644
--- a/tests/prometheus/t_prom.expected
+++ b/tests/prometheus/t_prom.expected
@@ -7,6 +7,16 @@ yolo_gauge{level="max"} 2525
 t_c2 1
 # TYPE t_c1 counter
 t_c1 42
+# HELP latency latency
+# TYPE latency histogram
+latency{le="0.01"} 2
+latency{le="0.1"} 4
+latency{le="0.5"} 7
+latency{le="1."} 8
+latency{le="10."} 9
+latency{le="+Inf"} 10
+latency_count 10
+latency_sum 31.530
 
 ```
 ==== second try====
@@ -18,5 +28,15 @@ yolo_gauge{level="max"} 42000
 t_c2 2
 # TYPE t_c1 counter
 t_c1 53
+# HELP latency latency
+# TYPE latency histogram
+latency{le="0.01"} 2
+latency{le="0.1"} 4
+latency{le="0.5"} 8
+latency{le="1."} 9
+latency{le="10."} 10
+latency{le="+Inf"} 12
+latency_count 12
+latency_sum 54.930
 
 ```
diff --git a/tests/prometheus/t_prom.ml b/tests/prometheus/t_prom.ml
index f8144b7b..04b1639e 100644
--- a/tests/prometheus/t_prom.ml
+++ b/tests/prometheus/t_prom.ml
@@ -6,11 +6,26 @@ let c1 = P.Counter.create reg "t_c1"
 let c2 = P.Counter.create reg "t_c2" ~descr:"more awesome than c1"
 let g1 = P.Gauge.create reg ~tags:[ "level", "max" ] "yolo_gauge"
 
+let h1 =
+  P.Histogram.create reg ~descr:"latency"
+    ~buckets:[ 0.01; 0.1; 0.5; 1.; 10. ]
+    "latency"
+
 let () =
   print_endline "==== first try ====";
   P.Counter.incr_by c1 42;
   P.Counter.incr c2;
   P.Gauge.set g1 2525;
+  P.Histogram.add h1 0.2;
+  P.Histogram.add h1 0.003;
+  P.Histogram.add h1 0.002;
+  P.Histogram.add h1 0.025;
+  P.Histogram.add h1 0.9;
+  P.Histogram.add h1 7.4;
+  P.Histogram.add h1 22.2;
+  P.Histogram.add h1 0.3;
+  P.Histogram.add h1 0.4;
+  P.Histogram.add h1 0.1;
 
   pf "```\n%s\n```\n" @@ P.Registry.emit_str reg
 
@@ -19,5 +34,7 @@ let () =
   P.Counter.incr_by c1 11;
   P.Counter.incr c2;
   P.Gauge.set g1 42_000;
+  P.Histogram.add h1 23.2;
+  P.Histogram.add h1 0.2;
 
   pf "```\n%s\n```\n" @@ P.Registry.emit_str reg
diff --git a/tiny_httpd.opam b/tiny_httpd.opam
index 3cda25ee..6a2d337b 100644
--- a/tiny_httpd.opam
+++ b/tiny_httpd.opam
@@ -21,6 +21,9 @@ depends: [
   "ptime" {with-test}
   "qcheck-core" {>= "0.9" & with-test}
 ]
+depopts: [
+  "mtime" {>= "2.0"}
+]
 build: [
   ["dune" "subst"] {dev}
   [

From 68c82692e14fbacaed3ae0f8cca1b51776e3a5ac Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 18 Jan 2024 22:11:35 -0500
Subject: [PATCH 07/11] fix

---
 src/prometheus/tiny_httpd_prometheus.ml |  2 +-
 tests/prometheus/t_prom.expected        | 24 ++++++++++++------------
 2 files changed, 13 insertions(+), 13 deletions(-)

diff --git a/src/prometheus/tiny_httpd_prometheus.ml b/src/prometheus/tiny_httpd_prometheus.ml
index bbede737..7e6a8539 100644
--- a/src/prometheus/tiny_httpd_prometheus.ml
+++ b/src/prometheus/tiny_httpd_prometheus.ml
@@ -133,7 +133,7 @@ module Histogram = struct
         else
           string_of_float thresh
       in
-      bpf buf "%s%a %d\n" self.name emit_tags_
+      bpf buf "%s_bucket%a %d\n" self.name emit_tags_
         (("le", name) :: self.tags)
         !count
     done;
diff --git a/tests/prometheus/t_prom.expected b/tests/prometheus/t_prom.expected
index 0305272e..1603900c 100644
--- a/tests/prometheus/t_prom.expected
+++ b/tests/prometheus/t_prom.expected
@@ -9,12 +9,12 @@ t_c2 1
 t_c1 42
 # HELP latency latency
 # TYPE latency histogram
-latency{le="0.01"} 2
-latency{le="0.1"} 4
-latency{le="0.5"} 7
-latency{le="1."} 8
-latency{le="10."} 9
-latency{le="+Inf"} 10
+latency_bucket{le="0.01"} 2
+latency_bucket{le="0.1"} 4
+latency_bucket{le="0.5"} 7
+latency_bucket{le="1."} 8
+latency_bucket{le="10."} 9
+latency_bucket{le="+Inf"} 10
 latency_count 10
 latency_sum 31.530
 
@@ -30,12 +30,12 @@ t_c2 2
 t_c1 53
 # HELP latency latency
 # TYPE latency histogram
-latency{le="0.01"} 2
-latency{le="0.1"} 4
-latency{le="0.5"} 8
-latency{le="1."} 9
-latency{le="10."} 10
-latency{le="+Inf"} 12
+latency_bucket{le="0.01"} 2
+latency_bucket{le="0.1"} 4
+latency_bucket{le="0.5"} 8
+latency_bucket{le="1."} 9
+latency_bucket{le="10."} 10
+latency_bucket{le="+Inf"} 12
 latency_count 12
 latency_sum 54.930
 

From 7684f67bc1a0a76a97548a03834caf4f266b9ec0 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 18 Jan 2024 23:27:15 -0500
Subject: [PATCH 08/11] add GC metrics to prometheus

---
 src/prometheus/tiny_httpd_prometheus.ml  | 36 ++++++++++++++++++++++--
 src/prometheus/tiny_httpd_prometheus.mli | 13 +++++++--
 2 files changed, 45 insertions(+), 4 deletions(-)

diff --git a/src/prometheus/tiny_httpd_prometheus.ml b/src/prometheus/tiny_httpd_prometheus.ml
index 7e6a8539..b7caf220 100644
--- a/src/prometheus/tiny_httpd_prometheus.ml
+++ b/src/prometheus/tiny_httpd_prometheus.ml
@@ -60,8 +60,17 @@ module Counter = struct
 
   let[@inline] incr self = A.incr self.c
   let[@inline] incr_by self n = ignore (A.fetch_and_add self.c n : int)
-  let[@inline] decr self = A.decr self.c
-  let[@inline] decr_by self n = ignore (A.fetch_and_add self.c (-n) : int)
+
+  let incr_to self n =
+    while
+      let old = A.get self.c in
+      if old < n then
+        not (A.compare_and_set self.c old n)
+      else
+        false
+    do
+      ()
+    done
 end
 
 module Gauge = struct
@@ -197,3 +206,26 @@ let add_route_to_server (server : H.t) (reg : registry) : unit =
 let instrument_server (server : H.t) reg : unit =
   H.add_middleware ~stage:(`Stage 1) server (http_middleware global);
   add_route_to_server server reg
+
+module GC_metrics = struct
+  type t = { major_coll: counter; major_heap: gauge; compactions: counter }
+
+  let create reg : t =
+    let major_coll =
+      Counter.create reg ~descr:"major GC collections" "ocaml_gc_major"
+    in
+    let major_heap =
+      Gauge.create reg ~descr:"size of major heap" "ocaml_gc_major_heap_size"
+    in
+    let compactions =
+      Counter.create reg ~descr:"number of GC compactions"
+        "ocaml_gc_compactions"
+    in
+    { major_coll; major_heap; compactions }
+
+  let update (self : t) =
+    let stats = Gc.quick_stat () in
+    Counter.incr_to self.major_coll stats.major_collections;
+    Counter.incr_to self.compactions stats.compactions;
+    Gauge.set self.major_heap (int_of_float (stats.major_words *. 8.))
+end
diff --git a/src/prometheus/tiny_httpd_prometheus.mli b/src/prometheus/tiny_httpd_prometheus.mli
index e82a5e13..055dc135 100644
--- a/src/prometheus/tiny_httpd_prometheus.mli
+++ b/src/prometheus/tiny_httpd_prometheus.mli
@@ -26,8 +26,10 @@ module Counter : sig
   val create : Registry.t -> ?tags:tags -> ?descr:string -> string -> t
   val incr : t -> unit
   val incr_by : t -> int -> unit
-  val decr : t -> unit
-  val decr_by : t -> int -> unit
+
+  val incr_to : t -> int -> unit
+  (** Increment to the given number. If it's lower than the current
+      value this does nothing *)
 end
 
 (** Gauges *)
@@ -71,3 +73,10 @@ val add_route_to_server : Tiny_httpd.t -> Registry.t -> unit
 
 val instrument_server : Tiny_httpd.t -> Registry.t -> unit
 (** Add middleware and route *)
+
+module GC_metrics : sig
+  type t
+
+  val create : Registry.t -> t
+  val update : t -> unit
+end

From e8eeec591568e808e9fe239218a8d76d6080742e Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 18 Jan 2024 23:37:16 -0500
Subject: [PATCH 09/11] fix GC metrics

---
 src/prometheus/tiny_httpd_prometheus.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/prometheus/tiny_httpd_prometheus.ml b/src/prometheus/tiny_httpd_prometheus.ml
index b7caf220..88c35e07 100644
--- a/src/prometheus/tiny_httpd_prometheus.ml
+++ b/src/prometheus/tiny_httpd_prometheus.ml
@@ -227,5 +227,5 @@ module GC_metrics = struct
     let stats = Gc.quick_stat () in
     Counter.incr_to self.major_coll stats.major_collections;
     Counter.incr_to self.compactions stats.compactions;
-    Gauge.set self.major_heap (int_of_float (stats.major_words *. 8.))
+    Gauge.set self.major_heap (stats.heap_words * 8)
 end

From c8852b15ab8c455be9ddd45d38dbd0d12d4fca49 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Fri, 19 Jan 2024 15:46:44 -0500
Subject: [PATCH 10/11] function to update GC metrics when prometheus knocks

---
 src/prometheus/tiny_httpd_prometheus.ml  | 11 ++++++++++-
 src/prometheus/tiny_httpd_prometheus.mli | 10 ++++++++++
 2 files changed, 20 insertions(+), 1 deletion(-)

diff --git a/src/prometheus/tiny_httpd_prometheus.ml b/src/prometheus/tiny_httpd_prometheus.ml
index 88c35e07..37a968cf 100644
--- a/src/prometheus/tiny_httpd_prometheus.ml
+++ b/src/prometheus/tiny_httpd_prometheus.ml
@@ -22,6 +22,7 @@ type registry = {
   mutable counters: counter list;
   mutable gauges: gauge list;
   mutable hists: histogram list;
+  mutable on_will_emit: (unit -> unit) list;
 }
 
 let validate_descr_ what s =
@@ -154,9 +155,13 @@ end
 module Registry = struct
   type t = registry
 
-  let create () : t = { counters = []; gauges = []; hists = [] }
+  let create () : t =
+    { counters = []; gauges = []; hists = []; on_will_emit = [] }
+
+  let on_will_emit self f = self.on_will_emit <- f :: self.on_will_emit
 
   let emit (buf : Buffer.t) (self : t) : unit =
+    List.iter (fun f -> f ()) self.on_will_emit;
     List.iter (Gauge.emit buf) self.gauges;
     List.iter (Counter.emit buf) self.counters;
     List.iter (Histogram.emit buf) self.hists;
@@ -228,4 +233,8 @@ module GC_metrics = struct
     Counter.incr_to self.major_coll stats.major_collections;
     Counter.incr_to self.compactions stats.compactions;
     Gauge.set self.major_heap (stats.heap_words * 8)
+
+  let create_and_update_before_emit reg : unit =
+    let gc = create reg in
+    Registry.on_will_emit reg (fun () -> update gc)
 end
diff --git a/src/prometheus/tiny_httpd_prometheus.mli b/src/prometheus/tiny_httpd_prometheus.mli
index 055dc135..799db5b2 100644
--- a/src/prometheus/tiny_httpd_prometheus.mli
+++ b/src/prometheus/tiny_httpd_prometheus.mli
@@ -9,6 +9,11 @@ module Registry : sig
 
   val create : unit -> t
 
+  val on_will_emit : t -> (unit -> unit) -> unit
+  (** [on_will_emit registry f] calls [f()] every time
+      [emit buf registry] is called (before the metrics start being emitted). This
+      is useful to update some metrics on demand. *)
+
   val emit : Buffer.t -> t -> unit
   (** Write metrics into the given buffer. The buffer will be
       cleared first thing. *)
@@ -79,4 +84,9 @@ module GC_metrics : sig
 
   val create : Registry.t -> t
   val update : t -> unit
+
+  val create_and_update_before_emit : Registry.t -> unit
+  (** [create_and_update_before_emit reg] creates new GC metrics,
+    adds them to the registry, and uses {!Registry.on_will_emit}
+    to {!update} the metrics every time the registry is polled. *)
 end

From 8c1c38f772ddfc073db128f5e76906942b98b675 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Sat, 20 Jan 2024 00:59:26 -0500
Subject: [PATCH 11/11] CI and compat with 4.8

---
 .github/workflows/main.yml              | 5 +++--
 dune-project                            | 2 +-
 src/prometheus/tiny_httpd_prometheus.ml | 2 +-
 tiny_httpd.opam                         | 2 +-
 4 files changed, 6 insertions(+), 5 deletions(-)

diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml
index f0bbcdf5..75829676 100644
--- a/.github/workflows/main.yml
+++ b/.github/workflows/main.yml
@@ -17,8 +17,9 @@ jobs:
             #- macos-latest
             #- windows-latest
         ocaml-compiler:
-          - 4.05
-          - 4.14
+          - 4.08.x
+          - 4.14.x
+          - 5.1.x
 
     runs-on: ${{ matrix.os }}
 
diff --git a/dune-project b/dune-project
index 95927d24..435b7f75 100644
--- a/dune-project
+++ b/dune-project
@@ -19,7 +19,7 @@
     seq
     base-threads
     result
-    (ocaml (>= 4.05))
+    (ocaml (>= 4.08))
     (odoc :with-doc)
     (conf-libcurl :with-test)
     (ptime :with-test)
diff --git a/src/prometheus/tiny_httpd_prometheus.ml b/src/prometheus/tiny_httpd_prometheus.ml
index 37a968cf..dcc19a8b 100644
--- a/src/prometheus/tiny_httpd_prometheus.ml
+++ b/src/prometheus/tiny_httpd_prometheus.ml
@@ -102,7 +102,7 @@ module Histogram = struct
   let create reg ?(tags = []) ?descr ~buckets name : t =
     opt_iter_ (validate_descr_ "histogram") descr;
     let buckets =
-      List.sort Float.compare buckets
+      List.sort Stdlib.compare buckets
       |> List.map (fun thresh -> thresh, A.make 0)
     in
     let buckets = Array.of_list @@ buckets @ [ infinity, A.make 0 ] in
diff --git a/tiny_httpd.opam b/tiny_httpd.opam
index 6a2d337b..955a14fe 100644
--- a/tiny_httpd.opam
+++ b/tiny_httpd.opam
@@ -15,7 +15,7 @@ depends: [
   "seq"
   "base-threads"
   "result"
-  "ocaml" {>= "4.05"}
+  "ocaml" {>= "4.08"}
   "odoc" {with-doc}
   "conf-libcurl" {with-test}
   "ptime" {with-test}