Add prometheus-lwt as a forward-compatible Lwt interface

CHANGES.md

@@ -1,3 +1,20 @@
+## dev
+
+- Add a new `prometheus-lwt` metrics package (@avsm @mtelvers @talex5 #66 #60 #65)
+
+  This release is not a breaking change, but instead prepares for
+  deprecation of Lwt in the core package so a future release can remove Lwt
+  from the `prometheus` core. Users of the core's Lwt-typed functions
+  should migrate to `Prometheus_lwt` now. Code using the new interface will
+  keep working unchanged in future releases.
+
+- Add synchronous variants of the timing helpers to the core. Metric recording
+  is synchronous and these will become the only core timing helpers once the
+  Lwt-typed ones move to `prometheus-lwt`.
+
+To migrate existing code, add a dep on `prometheus-lwt` and rename following
+the deprecation warnings from the compiler.
+
 ## v1.3 (2025-12-08)
 
 - Make help / type information be OpenMetrics compatible (@Nymphium @tmcgilchrist #47).  

README.md

@@ -67,6 +67,17 @@ Tick!
 
 Unikernels can use `Prometheus_app` instead of `Prometheus_unix` to avoid the `Unix` dependency.
 
+### Lwt collectors
+
+The `prometheus-lwt` opam package provides `Prometheus_lwt` with collectors
+that may suspend before producing their samples, and also Lwt versions of the
+timing helpers. 
+
+A future release will remove Lwt from the `prometheus` core. Existing code
+using the core's Lwt-typed functions should migrate to `Prometheus_lwt`, or to
+the synchronous variants such as `Gauge.set_time` now. Code will then keep
+working unchanged when the core switch happens.
+
 ### API docs
 
 Generated API documentation is available at <https://mirage.github.io/prometheus/>.

lwt/dune

@@ -0,0 +1,4 @@
+(library
+ (name prometheus_lwt)
+ (public_name prometheus-lwt)
+ (libraries prometheus lwt))

lwt/prometheus_lwt.ml

@@ -0,0 +1,34 @@
+[@@@alert "-deprecated"]
+
+(* This transition module reexports the core operations under their
+   new names to allow the core package to drop the Lwt dependency
+   in a future release. This interface will not change. *)
+module CollectorRegistry = struct
+  type t = Prometheus.CollectorRegistry.t
+
+  let of_registry core = core
+
+  let default = Prometheus.CollectorRegistry.default
+
+  let core t = t
+
+  let collect = Prometheus.CollectorRegistry.collect
+
+  let register = Prometheus.CollectorRegistry.register_lwt
+
+  let register_pre_collect = Prometheus.CollectorRegistry.register_pre_collect_lwt
+end
+
+module Gauge = struct
+  let track_in_progress = Prometheus.Gauge.track_inprogress
+
+  let set_time = Prometheus.Gauge.time
+end
+
+module Summary = struct
+  let observe_time = Prometheus.Summary.time
+end
+
+module Histogram (H : Prometheus.HISTOGRAM) = struct
+  let observe_time = H.time
+end

lwt/prometheus_lwt.mli

@@ -0,0 +1,49 @@
+(** Lwt support for Prometheus.
+
+    Provide collectors that may suspend before producing their metrics. *)
+
+module CollectorRegistry : sig
+  type t
+
+  val of_registry : Prometheus.CollectorRegistry.t -> t
+  (** [of_registry core] is the Lwt view over the existing registry [core]. *)
+
+  val default : t
+  (** [default] is the view over {!Prometheus.CollectorRegistry.default}. *)
+
+  val core : t -> Prometheus.CollectorRegistry.t
+  (** [core t] is the underlying core registry. Use it to register
+      synchronous metrics. *)
+
+  val collect : t -> Prometheus.CollectorRegistry.snapshot Lwt.t
+  (** [collect t] reads the current value of every metric. *)
+
+  val register :
+    t -> Prometheus.MetricInfo.t ->
+    (unit -> Prometheus.Sample_set.t Prometheus.LabelSetMap.t Lwt.t) -> unit
+  (** [register t info collector] registers a collector that may suspend
+      before producing its samples. *)
+
+  val register_pre_collect : t -> (unit -> unit Lwt.t) -> unit
+  (** [register_pre_collect t f] arranges for [f ()] to run at the start
+      of each collection. *)
+end
+
+module Gauge : sig
+  val track_in_progress : Prometheus.Gauge.t -> (unit -> 'a Lwt.t) -> 'a Lwt.t
+  (** [track_in_progress t f] increases [t] by one while [f ()] is running. *)
+
+  val set_time : Prometheus.Gauge.t -> (unit -> float) -> (unit -> 'a Lwt.t) -> 'a Lwt.t
+  (** [set_time t gettime f] calls [gettime ()] before and after executing [f ()] and
+      sets [t] to the difference. *)
+end
+
+module Summary : sig
+  val observe_time : Prometheus.Summary.t -> (unit -> float) -> (unit -> 'a Lwt.t) -> 'a Lwt.t
+  (** [observe_time t gettime f] observes the duration of [f ()]. *)
+end
+
+module Histogram (H : Prometheus.HISTOGRAM) : sig
+  val observe_time : H.t -> (unit -> float) -> (unit -> 'a Lwt.t) -> 'a Lwt.t
+  (** [observe_time t gettime f] observes the duration of [f ()]. *)
+end

lwt/test/dune

@@ -0,0 +1,4 @@
+(test
+ (name test_lwt)
+ (package prometheus-lwt)
+ (libraries prometheus prometheus-app prometheus-lwt alcotest alcotest-lwt lwt fmt))

lwt/test/test_lwt.ml

@@ -0,0 +1,66 @@
+open Prometheus
+open Prometheus_app
+
+open Lwt.Infix
+
+let test_lwt_collectors () =
+  let registry = Prometheus_lwt.CollectorRegistry.of_registry (CollectorRegistry.create ()) in
+  let sync_counter =
+    Counter.v ~registry:(Prometheus_lwt.CollectorRegistry.core registry)
+      ~help:"A synchronous counter" "counter_0"
+  in
+  Counter.inc_one sync_counter;
+  let register_counter ~name ~help value =
+    let metric_info = {
+      MetricInfo.name = MetricName.v name;
+      metric_type = Counter;
+      help;
+      label_names = []
+    }
+    in
+    let collector () =
+      Lwt.pause () >|= fun () ->
+      LabelSetMap.singleton [] [Prometheus.Sample_set.sample value]
+    in
+    Prometheus_lwt.CollectorRegistry.register registry metric_info collector
+  in
+  register_counter ~name:"counter_1" ~help:"The first counter" 1.0;
+  register_counter ~name:"counter_2" ~help:"The second counter" 2.0;
+  Prometheus_lwt.CollectorRegistry.collect registry >|= fun collected ->
+  let output = Fmt.to_to_string TextFormat_0_0_4.output collected in
+  Alcotest.(check string) "Text output"
+    "# HELP counter_0 A synchronous counter\n\
+     # TYPE counter_0 counter\n\
+     counter_0 1\n\
+     # HELP counter_1 The first counter\n\
+     # TYPE counter_1 counter\n\
+     counter_1 1\n\
+     # HELP counter_2 The second counter\n\
+     # TYPE counter_2 counter\n\
+     counter_2 2\n"
+    output
+
+let test_timers () =
+  let registry = Prometheus_lwt.CollectorRegistry.of_registry (CollectorRegistry.create ()) in
+  let core = Prometheus_lwt.CollectorRegistry.core registry in
+  let gauge = Gauge.v ~registry:core ~help:"Time taken" "gauge_time" in
+  let clock = ref 0.0 in
+  let gettime () = !clock in
+  Prometheus_lwt.Gauge.set_time gauge gettime
+    (fun () -> clock := !clock +. 1.5; Lwt.pause ())
+  >>= fun () ->
+  Prometheus_lwt.CollectorRegistry.collect registry >|= fun collected ->
+  let output = Fmt.to_to_string TextFormat_0_0_4.output collected in
+  Alcotest.(check string) "Text output"
+    "# HELP gauge_time Time taken\n\
+     # TYPE gauge_time gauge\n\
+     gauge_time 1.5\n"
+    output
+
+let () =
+  Lwt_main.run @@ Alcotest_lwt.run "prometheus-lwt" [
+    "main", [
+      "Lwt collectors", `Quick, test_lwt_collectors;
+      "Lwt timers", `Quick, test_timers;
+    ];
+  ]

prometheus-lwt.opam

@@ -0,0 +1,24 @@
+opam-version: "2.0"
+synopsis: "Lwt support for Prometheus monitoring"
+description: "Lwt collectors and timing helpers for Prometheus metrics."
+maintainer: "talex5@gmail.com"
+authors: ["Thomas Leonard" "Anil Madhavapeddy" "David Scott"]
+license: "Apache-2.0"
+homepage: "https://github.com/mirage/prometheus"
+doc: "https://mirage.github.io/prometheus/"
+bug-reports: "https://github.com/mirage/prometheus/issues"
+depends: [
+  "ocaml" {>= "4.11.0"}
+  "dune" {>= "2.3"}
+  "prometheus" {= version}
+  "lwt" {>= "2.5.0"}
+  "prometheus-app" {= version & with-test}
+  "fmt" {>= "0.8.7" & with-test}
+  "alcotest" {with-test}
+  "alcotest-lwt" {with-test}
+]
+build: [
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+dev-repo: "git+https://github.com/mirage/prometheus.git"

src/prometheus.ml

@@ -253,6 +253,10 @@ module Gauge = struct
     inc_one t;
     Lwt.finalize fn (fun () -> dec_one t; Lwt.return_unit)
 
+  let track_in_progress t fn =
+    inc_one t;
+    Fun.protect fn ~finally:(fun () -> dec_one t)
+
   let time t gettimeofday fn =
     let start = gettimeofday () in
     Lwt.finalize fn
@@ -261,6 +265,14 @@ module Gauge = struct
          inc t (finish -. start);
          Lwt.return_unit
       )
+
+  let set_time t gettimeofday fn =
+    let start = gettimeofday () in
+    Fun.protect fn
+      ~finally:(fun () ->
+         let finish = gettimeofday () in
+         set t (finish -. start)
+      )
 end
 
 module Summary = struct
@@ -296,6 +308,14 @@ module Summary = struct
          observe t (finish -. start);
          Lwt.return_unit
       )
+
+  let observe_time t gettimeofday fn =
+    let start = gettimeofday () in
+    Fun.protect fn
+      ~finally:(fun () ->
+         let finish = gettimeofday () in
+         observe t (finish -. start)
+      )
 end
 
 module Histogram_spec = struct
@@ -344,7 +364,8 @@ end
 module type HISTOGRAM = sig
   include METRIC
   val observe : t -> float -> unit
-  val time : t -> (unit -> float) -> (unit -> 'a Lwt.t) -> 'a Lwt.t
+  val time : t -> (unit -> float) -> (unit -> 'a Lwt.t) -> 'a Lwt.t [@@deprecated]
+  val observe_time : t -> (unit -> float) -> (unit -> 'a) -> 'a
 end
 
 let bucket_label = LabelName.v "le"
@@ -400,6 +421,14 @@ module Histogram (Buckets : BUCKETS) = struct
          observe t (finish -. start);
          Lwt.return_unit
       )
+
+  let observe_time t gettimeofday fn =
+    let start = gettimeofday () in
+    Fun.protect fn
+      ~finally:(fun () ->
+         let finish = gettimeofday () in
+         observe t (finish -. start)
+      )
 end
 
 module DefaultHistogram = Histogram (

src/prometheus.mli

@@ -9,6 +9,10 @@
 
     - This library is intended to be a dependency of any library that might need to report metrics,
       even though many applications will not enable it. Therefore it should have minimal dependencies.
+
+    - The Lwt-typed functions here are superseded by the [prometheus-lwt]
+      package. A future release will remove Lwt from this library. New code
+      should use [Prometheus_lwt] or the synchronous variants.
 *)
 
 type metric_type =
@@ -96,6 +100,7 @@ module CollectorRegistry : sig
       It will call [collector ()] to collect the values each time [collect] is called. *)
 
   val register_lwt : t -> MetricInfo.t -> (unit -> Sample_set.t LabelSetMap.t Lwt.t) -> unit
+  [@@deprecated "Use Prometheus_lwt.CollectorRegistry.register instead."]
   (** [register_lwt t metric collector] is the same as [register t metrics collector]
       but [collector] returns [Sample_set.t LabelSetMap.t Lwt.t]. *)
 
@@ -105,7 +110,8 @@ module CollectorRegistry : sig
       information about multiple metrics. *)
 
   val register_pre_collect_lwt : t -> (unit -> unit Lwt.t) -> unit
-  (** [register_pre_collect t fn] same as [register_pre_collect] but [fn] returns [unit Lwt.t]. *)
+  [@@deprecated "Use Prometheus_lwt.CollectorRegistry.register_pre_collect instead."]
+  (** [register_pre_collect_lwt t fn] is like [register_pre_collect] but [fn] returns [unit Lwt.t]. *)
 end
 (** A collection of metric reporters. Usually, only {!CollectorRegistry.default} is used. *)
 
@@ -162,12 +168,21 @@ module Gauge : sig
   (** [set t v] sets the current value of the gauge to [v]. *)
 
   val track_inprogress : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t
+  [@@deprecated "Use track_in_progress (with two underscores in the name) instead if you don't need Lwt here, \
+                 or Prometheus_lwt.Gauge.track_in_progress if you do."]
   (** [track_inprogress t f] increases the value of the gauge by one while [f ()] is running. *)
 
+  val track_in_progress : t -> (unit -> 'a) -> 'a
+  (** [track_in_progress t f] increases the value of the gauge by one while [f ()] runs. *)
+
   val time : t -> (unit -> float) -> (unit -> 'a Lwt.t) -> 'a Lwt.t
+  [@@deprecated "This increments the gauge, which is probably not what you want. Use set_time instead."]
   (** [time t gettime f] calls [gettime ()] before and after executing [f ()] and
-      increases the metric by the difference.
-  *)
+      increases the metric by the difference. *)
+
+  val set_time : t -> (unit -> float) -> (unit -> 'a) -> 'a
+  (** [set_time t gettime f] calls [gettime ()] before and after executing [f ()] and
+      sets [t] to the difference. *)
 end
 (** A gauge is a metric that represents a single numerical value that can arbitrarily go up and down. *)
 
@@ -178,8 +193,13 @@ module Summary : sig
   (** [observe t v] increases the total by [v] and the count by one. *)
 
   val time : t -> (unit -> float) -> (unit -> 'a Lwt.t) -> 'a Lwt.t
+  [@@deprecated "Use observe_time instead if you don't need Lwt here, or Prometheus_lwt.Summary.observe_time if you do."]
   (** [time t gettime f] calls [gettime ()] before and after executing [f ()] and
       observes the difference. *)
+
+  val observe_time : t -> (unit -> float) -> (unit -> 'a) -> 'a
+  (** [observe_time t gettime f] calls [gettime ()] before and after executing [f ()] and
+      observes the difference. *)
 end
 (** A summary is a metric that records both the number of readings and their total.
     This allows calculating the average. *)
@@ -211,8 +231,13 @@ module type HISTOGRAM = sig
   (** [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
+  [@@deprecated "Use observe_time instead if you don't need Lwt here, or Prometheus_lwt.HISTOGRAM.observe_time if you do."]
   (** [time t gettime f] calls [gettime ()] before and after executing [f ()] and
       observes the difference. *)
+
+  val observe_time : t -> (unit -> float) -> (unit -> 'a) -> 'a
+  (** [observe_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