Move the Lwt logic out of the prometheus core

Complete the migration started in mirage#66 so the core no longer depends
on Lwt.  Libraries that only define and record metrics no longer need
to pull in a concurrency library.

Review suggestions from @talex5

Co-authored-by: Mark Elvers <mark.elvers@tunbury.org>

Author: avsm

CHANGES.md

@@ -1,5 +1,14 @@
 ## dev
 
+- Remove Lwt from the `prometheus` core (@mtelvers @avsm #60 #65)
+
+  The deprecated Lwt-typed functions are gone and `CollectorRegistry.collect`
+  now returns a snapshot directly. The Lwt collectors and timing helpers live
+  in `prometheus-lwt`, whose interface is unchanged, so code that already
+  migrated to `Prometheus_lwt` needs no further changes. Applications that
+  collected via the core in an Lwt context should use
+  `Prometheus_lwt.CollectorRegistry.collect`.
+
 - Add a new `prometheus-lwt` metrics package (@avsm @mtelvers @talex5 #66 #60 #65)
 
   This release is not a breaking change, but instead prepares for

README.md

@@ -71,12 +71,13 @@ Unikernels can use `Prometheus_app` instead of `Prometheus_unix` to avoid the `U
 
 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. 
+timing helpers.
+
+The `prometheus` core does not depend on Lwt, so libraries that only define
+and record metrics do not pull in a concurrency library. Code that used the
+core's Lwt-typed functions should use `Prometheus_lwt`, or the synchronous
+variants such as `Gauge.set_time`.
 
-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
 

app/dune

@@ -1,7 +1,7 @@
 (library
  (name prometheus_app)
  (public_name prometheus-app)
- (libraries prometheus lwt cohttp-lwt fmt re)
+ (libraries prometheus prometheus-lwt lwt cohttp-lwt fmt re)
  (modules Prometheus_app)
  (wrapped false))
 

app/prometheus_app.ml

@@ -148,7 +148,7 @@ module Cohttp(Server : Cohttp_lwt.S.Server) = struct
     let uri = Request.uri req in
     match Request.meth req, Uri.path uri with
     | `GET, "/metrics" ->
-      Prometheus.CollectorRegistry.(collect default) >>= fun data ->
+      Prometheus_lwt.CollectorRegistry.(collect default) >>= fun data ->
       let body = Fmt.to_to_string TextFormat_0_0_4.output data in
       let headers = Header.init_with "Content-Type" "text/plain; version=0.0.4" in
       Server.respond_string ~status:`OK ~headers ~body ()

lwt/prometheus_lwt.ml

@@ -1,34 +1,81 @@
-[@@@alert "-deprecated"]
+(* The Lwt collectors for Prometheus metrics. *)
+
+open Prometheus
 
-(* 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
+  type t = {
+    core : Prometheus.CollectorRegistry.t;
+    mutable metrics_lwt : (unit -> Sample_set.t LabelSetMap.t Lwt.t) MetricFamilyMap.t;
+    mutable pre_collect_lwt : (unit -> unit Lwt.t) list;
+  }
+
+  let of_registry core = {
+    core;
+    metrics_lwt = MetricFamilyMap.empty;
+    pre_collect_lwt = [];
+  }
+
+  let default = of_registry Prometheus.CollectorRegistry.default
 
-  let of_registry core = core
+  let core t = t.core
 
-  let default = Prometheus.CollectorRegistry.default
+  let register_pre_collect t f = t.pre_collect_lwt <- f :: t.pre_collect_lwt
 
-  let core t = t
+  let register t info collector =
+    if MetricFamilyMap.mem info t.metrics_lwt then
+      failwith (Format.asprintf "%a already registered" MetricName.pp info.MetricInfo.name);
+    t.metrics_lwt <- MetricFamilyMap.add info collector t.metrics_lwt
 
-  let collect = Prometheus.CollectorRegistry.collect
+  open Lwt.Infix
 
-  let register = Prometheus.CollectorRegistry.register_lwt
+  let map_p m =
+    MetricFamilyMap.fold (fun k f acc -> (k, f ()) :: acc) m []
+    |> Lwt_list.fold_left_s
+      (fun acc (k, v) -> v >|= fun v -> MetricFamilyMap.add k v acc)
+      MetricFamilyMap.empty
 
-  let register_pre_collect = Prometheus.CollectorRegistry.register_pre_collect_lwt
+  let collect t =
+    Lwt_list.iter_p (fun f -> f ()) t.pre_collect_lwt >>= fun () ->
+    let sync = Prometheus.CollectorRegistry.collect t.core in
+    map_p t.metrics_lwt >|= fun metrics_lwt ->
+    MetricFamilyMap.merge
+      (fun _ v1 v2 ->
+         match v1 with
+         | Some v1 -> Some v1
+         | None -> v2)
+      sync metrics_lwt
 end
 
 module Gauge = struct
-  let track_in_progress = Prometheus.Gauge.track_inprogress
+  let track_in_progress t fn =
+    Prometheus.Gauge.inc_one t;
+    Lwt.finalize fn (fun () -> Prometheus.Gauge.dec_one t; Lwt.return_unit)
 
-  let set_time = Prometheus.Gauge.time
+  let set_time t gettimeofday fn =
+    let start = gettimeofday () in
+    Lwt.finalize fn
+      (fun () ->
+         let finish = gettimeofday () in
+         Prometheus.Gauge.set t (finish -. start);
+         Lwt.return_unit)
 end
 
 module Summary = struct
-  let observe_time = Prometheus.Summary.time
+  let observe_time t gettimeofday fn =
+    let start = gettimeofday () in
+    Lwt.finalize fn
+      (fun () ->
+         let finish = gettimeofday () in
+         Prometheus.Summary.observe t (finish -. start);
+         Lwt.return_unit)
 end
 
 module Histogram (H : Prometheus.HISTOGRAM) = struct
-  let observe_time = H.time
+  let observe_time t gettimeofday fn =
+    let start = gettimeofday () in
+    Lwt.finalize fn
+      (fun () ->
+         let finish = gettimeofday () in
+         H.observe t (finish -. start);
+         Lwt.return_unit)
 end

lwt/test/dune

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

prometheus-app.opam

@@ -28,6 +28,7 @@ depends: [
   "ocaml" {>= "4.11.0"}
   "dune" {>= "2.3"}
   "prometheus" {= version}
+  "prometheus-lwt" {= version}
   "fmt" {>= "0.8.7"}
   "re"
   "cohttp-lwt" {>= "4.0.0"}

prometheus-lwt.opam

@@ -12,10 +12,6 @@ depends: [
   "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]

prometheus.opam

@@ -10,7 +10,6 @@ depends: [
   "ocaml" {>= "4.11.0"}
   "dune" {>= "2.3"}
   "re"
-  "lwt" {>= "2.5.0"}
 ]
 build: [
   ["dune" "build" "-p" name "-j" jobs]

src/dune

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