From d29f31840e71c3de413705996dfca55b2506fe4c Mon Sep 17 00:00:00 2001 From: Gabriel Moise Date: Tue, 16 Jul 2024 16:24:24 +0100 Subject: [PATCH 1/3] Bring prometheus into the monorepo in its dedicated directory prometheus: import tag [v1.2] into [prometheus/] Import tag [v1.2], revision d1669d0e0d7e44b104755a0fd9700ae87e140f34 of prometheus (https://github.com/mirage/prometheus/) into the directory [prometheus]. --- prometheus/.gitignore | 3 + prometheus/CHANGES.md | 63 +++++ prometheus/LICENSE.md | 191 ++++++++++++++ prometheus/Makefile | 10 + prometheus/README.md | 80 ++++++ prometheus/app/dune | 13 + prometheus/app/prometheus_app.ml | 165 ++++++++++++ prometheus/app/prometheus_app.mli | 26 ++ prometheus/app/prometheus_unix.ml | 108 ++++++++ prometheus/app/prometheus_unix.mli | 60 +++++ prometheus/dune-project | 3 + prometheus/examples/dune | 4 + prometheus/examples/example.ml | 46 ++++ prometheus/prometheus-app.opam | 47 ++++ prometheus/prometheus-app.version | 1 + prometheus/prometheus.opam | 30 +++ prometheus/src/dune | 4 + prometheus/src/prometheus.ml | 405 +++++++++++++++++++++++++++++ prometheus/src/prometheus.mli | 213 +++++++++++++++ prometheus/tests/dune | 4 + prometheus/tests/test.ml | 179 +++++++++++++ prometheus/tests/test.mli | 0 22 files changed, 1655 insertions(+) create mode 100644 prometheus/.gitignore create mode 100644 prometheus/CHANGES.md create mode 100644 prometheus/LICENSE.md create mode 100644 prometheus/Makefile create mode 100644 prometheus/README.md create mode 100644 prometheus/app/dune create mode 100644 prometheus/app/prometheus_app.ml create mode 100644 prometheus/app/prometheus_app.mli create mode 100644 prometheus/app/prometheus_unix.ml create mode 100644 prometheus/app/prometheus_unix.mli create mode 100644 prometheus/dune-project create mode 100644 prometheus/examples/dune create mode 100644 prometheus/examples/example.ml create mode 100644 prometheus/prometheus-app.opam create mode 100644 prometheus/prometheus-app.version create mode 100644 prometheus/prometheus.opam create mode 100644 prometheus/src/dune create mode 100644 prometheus/src/prometheus.ml create mode 100644 prometheus/src/prometheus.mli create mode 100644 prometheus/tests/dune create mode 100644 prometheus/tests/test.ml create mode 100644 prometheus/tests/test.mli diff --git a/prometheus/.gitignore b/prometheus/.gitignore new file mode 100644 index 000000000000..5a3709df0dbf --- /dev/null +++ b/prometheus/.gitignore @@ -0,0 +1,3 @@ +*.install +_build +*.merlin diff --git a/prometheus/CHANGES.md b/prometheus/CHANGES.md new file mode 100644 index 000000000000..58641c17d4dd --- /dev/null +++ b/prometheus/CHANGES.md @@ -0,0 +1,63 @@ +## v1.2 (2022-06-16) + +- Add lwt collectors and pre-collectors (@killian-delarue, #43). + Note that this is a temporary feature while we wait for OCaml 5 to be released, + when this can be replaced by the use of effects. + +- Fix deprecations in Fmt 0.8.10 (@MisterDA, #36). + +- General build updates, upstream deprecations, etc (@talex5, #33 #34 #35 #40 #42). + +## v1.1 (2021-06-08) + +- Allow using a custom formatter for log output (@MisterDA #31). + Windows services crash if they try to use stderr. + +## v1.0 (2020-12-22) + +- Add logging configuration (#29, @talex5). + To configure a server to report counts for log messages: + ```ocaml + let () = Prometheus_unix.Logging.init () + ``` + This installs a reporter that reports the number of messages logged by each log source and at each level. + The reporter also displays the timestamp and log source with each message, which is a more suitable configuration for servers. + +- Add bounds on cohttp to prepare for cohttp 3 release (#28, @talex5). + +## v0.7 (2020-03-03) + +- switch float representation to OCaml's default `"%f"` (#22, @toots) +- use `Gc.quick_stat` for faster stats (#25, @talex5) + +## v0.6 (2019-11-23) + +- upgrade build to dune (@talex5) +- upgrade to opam2 format (@talex5) + +## v0.5 (2017-12-20) + +- prometheus-app: update to cohttp.1.0.0 API (#15, @djs55) +- add support for histograms (#14, @stijn-devriendt and @talex5) +- add `Sample_set module` to clean up the API a bit (#13, @talex5) +- fix gettimeofday parameter not used in favor of Unix.gettimeofdaya (#12, @stijn-devriendt) + +## v0.4 (2017-08-02) + +- unix: update to cohttp >= 0.99.0. Note this means the unix package + requires OCaml 4.03+. The main library still only requires OCaml 4.01+ + +## v0.3 (2017-07-03) + +- Build tweaks to support topkg versioning (@avsm) + +## v0.2 (2017-05-18) + +- add example program and update README +- switch to jbuilder +- throw a clearer error on registering a duplicate metric +- use `Re` rather than `Str` + +## v0.1 + +- Initial release. diff --git a/prometheus/LICENSE.md b/prometheus/LICENSE.md new file mode 100644 index 000000000000..0f525f6fb528 --- /dev/null +++ b/prometheus/LICENSE.md @@ -0,0 +1,191 @@ + + Apache License + Version 2.0, January 2004 + https://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + Copyright 2016-2017 Docker, Inc. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/prometheus/Makefile b/prometheus/Makefile new file mode 100644 index 000000000000..1fb80acc6c05 --- /dev/null +++ b/prometheus/Makefile @@ -0,0 +1,10 @@ +.PHONY: build clean test + +build: + dune build @install ./examples/example.exe + +test: + dune runtest + +clean: + dune clean diff --git a/prometheus/README.md b/prometheus/README.md new file mode 100644 index 000000000000..7d1a516d1607 --- /dev/null +++ b/prometheus/README.md @@ -0,0 +1,80 @@ +## OCaml client library for Prometheus monitoring + +To run services reliably, it is useful if they can report various metrics +(for example, heap size, queue lengths, number of warnings logged, etc). + +A monitoring service can be configured to collect this data regularly. +The data can be graphed to help understand the performance of the service over time, +or to help debug problems quickly. +It can also be used to send alerts if a service is down or behaving poorly. + +This repository contains code to report metrics to a [Prometheus][] monitoring server. + +### Use by libraries + +Library authors should define a set of metrics that may be useful. For example, the DataKitCI +cache module defines several metrics like this: + +```ocaml +module Metrics = struct + open Prometheus + + let namespace = "DataKitCI" + let subsystem = "cache" + + let builds_started_total = + let help = "Total number of builds started" in + Counter.v_label ~help ~label_name:"name" ~namespace ~subsystem "builds_started_total" + + let builds_succeeded_total = + let help = "Total number of builds that succeeded" in + Counter.v_label ~help ~label_name:"name" ~namespace ~subsystem "builds_succeeded_total" + + let builds_failed_total = + let help = "Total number of builds that failed" in + Counter.v_label ~help ~label_name:"name" ~namespace ~subsystem "builds_failed_total" + + [...] +end +``` + +Each of these metrics has a `name` label, which allows the reports to be further broken down +by the type of thing being built. + +When (for example) a build succeeds, the CI does: + +```ocaml +Prometheus.Counter.inc_one (Metrics.builds_succeeded_total build_type) +``` + +### Use by applications + +Applications can enable metric reporting using the `prometheus-app` opam package. +This depends on cohttp and can serve the metrics collected above over HTTP. + +The `prometheus-app.unix` ocamlfind library provides the `Prometheus_unix` module, +which includes a cmdliner option and pre-configured web-server. +See the `examples/example.ml` program for an example, which can be run as: + +```shell +$ dune exec -- examples/example.exe --listen-prometheus=9090 +If run with the option --listen-prometheus=9090, this program serves metrics at +http://localhost:9090/metrics +Tick! +Tick! +... +``` + +Unikernels can use `Prometheus_app` instead of `Prometheus_unix` to avoid the `Unix` dependency. + +### API docs + +Generated API documentation is available at . + +## Licensing + +This code is licensed under the Apache License, Version 2.0. See +[LICENSE](https://github.com/docker/datakit/blob/master/LICENSE.md) for the full +license text. + +[Prometheus]: https://prometheus.io diff --git a/prometheus/app/dune b/prometheus/app/dune new file mode 100644 index 000000000000..debed4ddeb58 --- /dev/null +++ b/prometheus/app/dune @@ -0,0 +1,13 @@ +(library + (name prometheus_app) + (public_name prometheus-app) + (libraries prometheus lwt cohttp-lwt astring asetmap fmt re) + (modules Prometheus_app) + (wrapped false)) + +(library + (name prometheus_app_unix) + (public_name prometheus-app.unix) + (libraries prometheus prometheus-app cmdliner cohttp-lwt cohttp-lwt-unix logs.fmt fmt.tty) + (modules Prometheus_unix) + (wrapped false)) diff --git a/prometheus/app/prometheus_app.ml b/prometheus/app/prometheus_app.ml new file mode 100644 index 000000000000..6707b2dc7117 --- /dev/null +++ b/prometheus/app/prometheus_app.ml @@ -0,0 +1,165 @@ +open Prometheus + +let failf fmt = + Fmt.kstr failwith fmt + +module TextFormat_0_0_4 = struct + let re_unquoted_escapes = Re.compile @@ Re.set "\\\n" + let re_quoted_escapes = Re.compile @@ Re.set "\"\\\n" + + let quote g = + match Re.Group.get g 0 with + | "\\" -> "\\\\" + | "\n" -> "\\n" + | "\"" -> "\\\"" + | x -> failf "Unexpected match %S" x + + let output_metric_type f = function + | Counter -> Fmt.string f "counter" + | Gauge -> Fmt.string f "gauge" + | Summary -> Fmt.string f "summary" + | Histogram -> Fmt.string f "histogram" + + let output_unquoted f s = + Fmt.string f @@ Re.replace re_unquoted_escapes ~f:quote s + + let output_quoted f s = + Fmt.string f @@ Re.replace re_quoted_escapes ~f:quote s + + (* Fmt.float by default prints floats using scientific exponential + * notation, which loses significant data on e.g. timestamp: + * Fmt.str "%a" Fmt.float 1575363850.57 --> 1.57536e+09 *) + let float_fmt f = + Fmt.pf f "%f" + + let output_value f v = + match classify_float v with + | FP_normal | FP_subnormal | FP_zero -> float_fmt f v + | FP_infinite when v > 0.0 -> Fmt.string f "+Inf" + | FP_infinite -> Fmt.string f "-Inf" + | FP_nan -> Fmt.string f "Nan" + + let output_pairs f (label_names, label_values) = + let cont = ref false in + let output_pair name value = + if !cont then Fmt.string f ", " + else cont := true; + Fmt.pf f "%a=\"%a\"" LabelName.pp name output_quoted value + in + List.iter2 output_pair label_names label_values + + let output_labels ~label_names f = function + | [] -> () + | 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; bucket } = + let label_names, label_values = match bucket with + | None -> label_names, label_values + | Some (label_name, label_value) -> + let label_value_str = Fmt.str "%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 + output_value value + + let output_metric ~name ~label_names f (label_values, samples) = + List.iter (output_sample ~base:name ~label_names ~label_values f) samples + + let output f = + MetricFamilyMap.iter (fun metric samples -> + let {MetricInfo.name; metric_type; help; label_names} = metric in + Fmt.pf f + "#HELP %a %a@.\ + #TYPE %a %a@.\ + %a" + MetricName.pp name output_unquoted help + MetricName.pp name output_metric_type metric_type + (LabelSetMap.pp ~sep:Fmt.nop (output_metric ~name ~label_names)) samples + ) +end + +module Runtime = struct + let current = ref (Gc.quick_stat ()) + let update () = + current := Gc.quick_stat () + + let simple_metric ~metric_type ~help name fn = + let info = { + MetricInfo. + name = MetricName.v name; + help; + metric_type; + label_names = []; + } + in + let collect () = + LabelSetMap.singleton [] [Sample_set.sample (fn ())] + in + info, collect + + let ocaml_gc_allocated_bytes = + simple_metric ~metric_type:Counter "ocaml_gc_allocated_bytes" Gc.allocated_bytes + ~help:"Total number of bytes allocated since the program was started." + + let ocaml_gc_major_words = + simple_metric ~metric_type:Counter "ocaml_gc_major_words" (fun () -> (!current).Gc.major_words) + ~help:"Number of words allocated in the major heap since the program was started." + + let ocaml_gc_minor_collections = + simple_metric ~metric_type:Counter "ocaml_gc_minor_collections" (fun () -> float_of_int (!current).Gc.minor_collections) + ~help:"Number of minor collection cycles completed since the program was started." + + let ocaml_gc_major_collections = + simple_metric ~metric_type:Counter "ocaml_gc_major_collections" (fun () -> float_of_int (!current).Gc.major_collections) + ~help:"Number of major collection cycles completed since the program was started." + + let ocaml_gc_heap_words = + simple_metric ~metric_type:Gauge "ocaml_gc_heap_words" (fun () -> float_of_int (!current).Gc.heap_words) + ~help:"Total size of the major heap, in words." + + let ocaml_gc_compactions = + simple_metric ~metric_type:Counter "ocaml_gc_compactions" (fun () -> float_of_int (!current).Gc.compactions) + ~help:"Number of heap compactions since the program was started." + + let ocaml_gc_top_heap_words = + simple_metric ~metric_type:Counter "ocaml_gc_top_heap_words" (fun () -> float_of_int (!current).Gc.top_heap_words) + ~help:"Maximum size reached by the major heap, in words." + + let process_cpu_seconds_total = + simple_metric ~metric_type:Counter "process_cpu_seconds_total" Sys.time + ~help:"Total user and system CPU time spent in seconds." + + let metrics = [ + ocaml_gc_allocated_bytes; + ocaml_gc_major_words; + ocaml_gc_minor_collections; + ocaml_gc_major_collections; + ocaml_gc_heap_words; + ocaml_gc_compactions; + ocaml_gc_top_heap_words; + process_cpu_seconds_total; + ] +end + +open Lwt.Infix + +module Cohttp(Server : Cohttp_lwt.S.Server) = struct + let callback _conn req _body = + let open Cohttp in + let uri = Request.uri req in + match Request.meth req, Uri.path uri with + | `GET, "/metrics" -> + Prometheus.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 () + | _ -> Server.respond_error ~status:`Bad_request ~body:"Bad request" () +end + +let () = + CollectorRegistry.(register_pre_collect default) Runtime.update; + let add (info, collector) = + CollectorRegistry.(register default) info collector in + List.iter add Runtime.metrics diff --git a/prometheus/app/prometheus_app.mli b/prometheus/app/prometheus_app.mli new file mode 100644 index 000000000000..f9c3c71df3e5 --- /dev/null +++ b/prometheus/app/prometheus_app.mli @@ -0,0 +1,26 @@ +(** Report metrics for Prometheus. + See: https://prometheus.io/ + + Notes: + + - This module is intended to be used by applications that export Prometheus metrics. + Libraries should only link against the `Prometheus` module. + + - This module automatically initialises itself and registers some standard collectors relating to + GC statistics, as recommended by Prometheus. + + - This module does not depend on [Unix], and so can be used in unikernels. + *) + +module TextFormat_0_0_4 : sig + val output : Prometheus.CollectorRegistry.snapshot Fmt.t +end +(** Format a snapshot in Prometheus's text format, version 0.0.4. *) + +module Cohttp (S : Cohttp_lwt.S.Server) : sig + val callback : + S.conn -> + Cohttp.Request.t -> + Cohttp_lwt.Body.t -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t +end +(** A Cohttp callback for a web-server that exposes the Prometheus metrics. *) diff --git a/prometheus/app/prometheus_unix.ml b/prometheus/app/prometheus_unix.ml new file mode 100644 index 000000000000..eeecab929ccf --- /dev/null +++ b/prometheus/app/prometheus_unix.ml @@ -0,0 +1,108 @@ +open Prometheus + +module Metrics = struct + let namespace = "prometheus" + + let subsystem = "logs" + + let inc_messages = + let help = "Total number of messages logged" in + let c = + Counter.v_labels ~label_names:[ "level"; "src" ] ~help ~namespace + ~subsystem "messages_total" + in + fun lvl src -> + let lvl = Logs.level_to_string (Some lvl) in + Counter.inc_one @@ Counter.labels c [ lvl; src ] +end + +module Unix_runtime = struct + let start_time = Unix.gettimeofday () + + let simple_metric ~metric_type ~help name fn = + let info = { + MetricInfo. + name = MetricName.v name; + help; + metric_type; + label_names = []; + } + in + let collect () = + LabelSetMap.singleton [] [Sample_set.sample (fn ())] + in + info, collect + + let process_start_time_seconds = + simple_metric ~metric_type:Counter "process_start_time_seconds" (fun () -> start_time) + ~help:"Start time of the process since unix epoch in seconds." + + let metrics = [ + process_start_time_seconds; + ] +end + +type config = int option + +module Server = Prometheus_app.Cohttp(Cohttp_lwt_unix.Server) + +let serve = function + | None -> [] + | Some port -> + let mode = `TCP (`Port port) in + let callback = Server.callback in + let thread = Cohttp_lwt_unix.Server.create ~mode (Cohttp_lwt_unix.Server.make ~callback ()) in + [thread] + +let listen_prometheus = + let open! Cmdliner in + let doc = + Arg.info ~docs:"MONITORING OPTIONS" ~docv:"PORT" ~doc: + "Port on which to provide Prometheus metrics over HTTP." + ["listen-prometheus"] + in + Arg.(value @@ opt (some int) None doc) + +let opts = listen_prometheus + +let () = + let add (info, collector) = + CollectorRegistry.(register default) info collector in + List.iter add Unix_runtime.metrics + +module Logging = struct + let inc_counter = Metrics.inc_messages + + let pp_timestamp f x = + let open Unix in + let tm = localtime x in + Fmt.pf f "%04d-%02d-%02d %02d:%02d.%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) + tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec + + let reporter formatter = + let report src level ~over k msgf = + let k _ = over (); k () in + let src = Logs.Src.name src in + Metrics.inc_messages level src; + msgf @@ fun ?header ?tags:_ fmt -> + Fmt.kpf k formatter ("%a %a %a @[" ^^ fmt ^^ "@]@.") + pp_timestamp (Unix.gettimeofday ()) + Fmt.(styled `Magenta string) (Printf.sprintf "%14s" src) + Logs_fmt.pp_header (level, header) + in + { Logs.report = report } + + let set_level (src, level) = + let rec aux = function + | [] -> Logs.warn (fun f -> f "set_level: logger %S not registered; ignoring" src) + | x :: _ when Logs.Src.name x = src -> Logs.Src.set_level x (Some level) + | _ :: xs -> aux xs + in + aux (Logs.Src.list ()) + + let init ?(default_level=Logs.Info) ?(levels=[]) ?(formatter=Fmt.stderr) () = + Fmt_tty.setup_std_outputs (); + Logs.set_reporter (reporter formatter); + Logs.set_level (Some default_level); + List.iter set_level levels +end diff --git a/prometheus/app/prometheus_unix.mli b/prometheus/app/prometheus_unix.mli new file mode 100644 index 000000000000..69131e60b20f --- /dev/null +++ b/prometheus/app/prometheus_unix.mli @@ -0,0 +1,60 @@ +(** Report metrics for Prometheus. + See: https://prometheus.io/ + + Notes: + + - This module is intended to be used by applications that export Prometheus metrics. + Libraries should only link against the `Prometheus` module. + + - This module automatically initialises itself and registers some standard collectors relating to + GC statistics, as recommended by Prometheus. + + - This extends [Prometheus_app] with support for cmdliner option parsing, a server pre-configured + for Unix, and a start-time metric that uses [Unix.gettimeofday]. + *) + +type config + +val serve : config -> unit Lwt.t list +(** [serve config] starts a Cohttp server according to config. + It returns a singleton list containing the thread to monitor, + or an empty list if no server is configured. *) + +val opts : config Cmdliner.Term.t +(** [opts] is the extra command-line options to offer Prometheus + monitoring. *) + +(** Report metrics for messages logged. *) +module Logging : sig + val init : + ?default_level:Logs.level -> + ?levels:(string * Logs.level) list -> + ?formatter:Format.formatter -> + unit -> unit + (** Initialise the Logs library with a reporter that reports prometheus metrics too. + The reporter is configured to log to stderr and the log messages include a + timestamp and the event's source. + + A server will typically use the following code to initialise logging: + {[ + let () = Prometheus_app.Logging.init () + ]} + + Or: + {[ + let () = + Prometheus_unix.Logging.init () + ~default_level:Logs.Debug + ~levels:[ + "cohttp.lwt.io", Logs.Info; + ] + ]} + @param default_level The default log-level to use (default {!Logs.Info}). + @param levels Provides levels for specific log sources. + @param formatter A custom formatter (default {!Fmt.stderr}). *) + + val inc_counter : Logs.level -> string -> unit + (** [inc_counter level src] increments the count of messages logged by [src] at [level]. + The reporter installed by [init] calls this automatically, but you might want to + use this if you use your own reporter instead. *) +end diff --git a/prometheus/dune-project b/prometheus/dune-project new file mode 100644 index 000000000000..0b66deece9dc --- /dev/null +++ b/prometheus/dune-project @@ -0,0 +1,3 @@ +(lang dune 2.3) +(name prometheus) +(formatting disabled) diff --git a/prometheus/examples/dune b/prometheus/examples/dune new file mode 100644 index 000000000000..dffb6824a90a --- /dev/null +++ b/prometheus/examples/dune @@ -0,0 +1,4 @@ +(executable + (name example) + (enabled_if (>= %{ocaml_version} 4.08)) ; Work-around for dune bug #5621 + (libraries prometheus prometheus-app.unix cmdliner cohttp-lwt cohttp-lwt-unix)) diff --git a/prometheus/examples/example.ml b/prometheus/examples/example.ml new file mode 100644 index 000000000000..d56baecc1d4d --- /dev/null +++ b/prometheus/examples/example.ml @@ -0,0 +1,46 @@ +(** Run this with [example.native --listen-prometheus=9090]. + View the metrics with: + + curl http://localhost:9090/metrics + *) + +open Lwt.Infix + +module Metrics = struct + open Prometheus + + let namespace = "MyProg" + let subsystem = "main" + + let ticks_counted_total = + let help = "Total number of ticks counted" in + Counter.v ~help ~namespace ~subsystem "ticks_counted_total" +end + +let rec counter () = + Lwt_unix.sleep 1.0 >>= fun () -> + print_endline "Tick!"; + Prometheus.Counter.inc_one Metrics.ticks_counted_total; + counter () + +let main prometheus_config = + let threads = counter () :: Prometheus_unix.serve prometheus_config in + Lwt_main.run (Lwt.choose threads) + +open Cmdliner + +(* Optional: configure logging *) +let () = + Prometheus_unix.Logging.init () + ~default_level:Logs.Debug + ~levels:[ + "cohttp.lwt.io", Logs.Info; + ] + +let () = + Logs.info (fun f -> f "Logging initialised."); + print_endline "If run with the option --listen-prometheus=9090, this program serves metrics at\n\ + http://localhost:9090/metrics"; + let info = Cmd.info "example" in + let cmd = Cmd.v info Term.(const main $ Prometheus_unix.opts) in + exit @@ Cmd.eval cmd diff --git a/prometheus/prometheus-app.opam b/prometheus/prometheus-app.opam new file mode 100644 index 000000000000..45a312820586 --- /dev/null +++ b/prometheus/prometheus-app.opam @@ -0,0 +1,47 @@ +opam-version: "2.0" +synopsis: "Client library for Prometheus monitoring" +description: """\ +Applications can enable metric reporting using the `prometheus-app` opam package. +This depends on cohttp and can serve the metrics collected above over HTTP. + +The `prometheus-app.unix` ocamlfind library provides the `Prometheus_unix` module, +which includes a cmdliner option and pre-configured web-server. +See the `examples/example.ml` program for an example, which can be run as: + +```shell +$ dune exec -- examples/example.exe --listen-prometheus=9090 +If run with the option --listen-prometheus=9090, this program serves metrics at +http://localhost:9090/metrics +Tick! +Tick! +... +``` + +Unikernels can use `Prometheus_app` instead of `Prometheus_unix` to avoid the `Unix` dependency.""" +maintainer: "talex5@gmail.com" +authors: ["Thomas Leonard" "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.08"} + "dune" {>= "2.3"} + "prometheus" {= version} + "fmt" {>= "0.8.7"} + "re" + "cohttp-lwt" {>= "4.0.0"} + "cohttp-lwt-unix" {>= "4.0.0"} + "lwt" {>= "2.5.0"} + "cmdliner" + "alcotest" {with-test} + "alcotest-lwt" {with-test} + "asetmap" + "astring" + "logs" {>= "0.6.0"} +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/mirage/prometheus.git" diff --git a/prometheus/prometheus-app.version b/prometheus/prometheus-app.version new file mode 100644 index 000000000000..3b04cfb60da1 --- /dev/null +++ b/prometheus/prometheus-app.version @@ -0,0 +1 @@ +0.2 diff --git a/prometheus/prometheus.opam b/prometheus/prometheus.opam new file mode 100644 index 000000000000..95512bcf6c37 --- /dev/null +++ b/prometheus/prometheus.opam @@ -0,0 +1,30 @@ +opam-version: "2.0" +synopsis: "Client library for Prometheus monitoring" +maintainer: "talex5@gmail.com" +authors: ["Thomas Leonard" "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.01.0"} + "dune" {>= "2.3"} + "astring" + "asetmap" + "re" + "lwt" {>= "2.5.0"} +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/mirage/prometheus.git" +description: """ +To run services reliably, it is useful if they can report various metrics +(for example, heap size, queue lengths, number of warnings logged, etc). + +A monitoring service can be configured to collect this data regularly. +The data can be graphed to help understand the performance of the service over time, +or to help debug problems quickly. +It can also be used to send alerts if a service is down or behaving poorly. +""" diff --git a/prometheus/src/dune b/prometheus/src/dune new file mode 100644 index 000000000000..8ae5ebee23d1 --- /dev/null +++ b/prometheus/src/dune @@ -0,0 +1,4 @@ +(library + (name prometheus) + (public_name prometheus) + (libraries lwt astring asetmap re)) diff --git a/prometheus/src/prometheus.ml b/prometheus/src/prometheus.ml new file mode 100644 index 000000000000..7077824022e6 --- /dev/null +++ b/prometheus/src/prometheus.ml @@ -0,0 +1,405 @@ +open! Astring +open! Asetmap + +module type NAME_SPEC = sig + val valid : Re.re +end + +module type NAME = sig + type t = private string + val v : string -> t + val pp : Format.formatter -> t -> unit + val compare : t -> t -> int +end + +module Name(N : NAME_SPEC) : NAME = struct + type t = string + + let v name = + if not (Re.execp N.valid name) then + failwith (Format.asprintf "Invalid name %S" name); + name + + let compare = String.compare + + let pp = Format.pp_print_string +end + +let alphabet = Re.(alt [ rg 'a' 'z'; rg 'A' 'Z' ]) +module LabelName = struct + (* "^[a-zA-Z_][a-zA-Z0-9_]*$" *) + let start = Re.alt [ alphabet; Re.char '_' ] + let rest = Re.alt [ start; Re.digit ] + include Name(struct let valid = Re.compile @@ Re.seq [ Re.bos; start; Re.rep rest; Re.eos] end) +end +module MetricName = struct + (* "^[a-zA-Z_:][a-zA-Z0-9_:]*$" *) + let start = Re.alt [ LabelName.start; Re.char ':' ] + let rest = Re.alt [ start; Re.digit ] + include Name(struct let valid = Re.compile @@ Re.seq [ Re.bos; start; Re.rep rest; Re.eos] end) +end + +type metric_type = + | Counter + | Gauge + | Summary + | Histogram + +module LabelSet = struct + type t = string list + let compare (a:t) (b:t) = compare a b +end +module LabelSetMap = Map.Make(LabelSet) + +module MetricInfo = struct + type t = { + name : MetricName.t; + metric_type : metric_type; + help : string; + label_names : LabelName.t list; + } + + let pp_opt () = function + | None -> "" + | Some v -> v ^ "_" + + let v ~help ?(label_names=[]) ~metric_type ?namespace ?subsystem name = + let name = Printf.sprintf "%a%a%s" pp_opt namespace pp_opt subsystem name in + { + name = MetricName.v name; + metric_type; + help; + label_names; + } + + let compare a b = MetricName.compare a.name b.name +end + +module MetricFamilyMap = Map.Make(MetricInfo) + +module Sample_set = struct + type sample = { + ext : string; + value : float; + bucket : (LabelName.t * float) option; + } + + type t = sample list + + let sample ?(ext="") ?bucket value = { ext; value; bucket } +end + +module CollectorRegistry = struct + type t = { + mutable metrics : (unit -> Sample_set.t LabelSetMap.t ) MetricFamilyMap.t; + mutable metrics_lwt : (unit -> Sample_set.t LabelSetMap.t Lwt.t) MetricFamilyMap.t; + mutable pre_collect : (unit -> unit ) list; + mutable pre_collect_lwt : (unit -> unit Lwt.t) list; + } + + type snapshot = Sample_set.t LabelSetMap.t MetricFamilyMap.t + + let create () = { + metrics = MetricFamilyMap.empty; + metrics_lwt = MetricFamilyMap.empty; + pre_collect = []; + pre_collect_lwt = []; + } + + let default = create () + + let register_pre_collect t f = t.pre_collect <- f :: t.pre_collect + + let register_pre_collect_lwt t f = t.pre_collect_lwt <- f :: t.pre_collect_lwt + + let ensure_not_registered t info = + if MetricFamilyMap.mem info t.metrics || + MetricFamilyMap.mem info t.metrics_lwt + then failwith (Format.asprintf "%a already registered" MetricName.pp info.MetricInfo.name) + + let register t info collector = + ensure_not_registered t info; + t.metrics <- MetricFamilyMap.add info collector t.metrics + + let register_lwt t info collector = + ensure_not_registered t info; + t.metrics_lwt <- MetricFamilyMap.add info collector t.metrics_lwt + + open Lwt.Infix + + 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 collect t = + List.iter (fun f -> f ()) t.pre_collect; + Lwt_list.iter_p (fun f -> f ()) t.pre_collect_lwt >>= fun () -> + let metrics = MetricFamilyMap.map (fun f -> f ()) t.metrics in + map_p t.metrics_lwt >|= fun metrics_lwt -> + MetricFamilyMap.merge + (fun _ v1 v2 -> + match v1 with + | Some v1 -> Some v1 + | None -> v2) + metrics metrics_lwt + +end + +module type METRIC = sig + type family + type t + val v_labels : label_names:string list -> ?registry:CollectorRegistry.t -> help:string -> ?namespace:string -> ?subsystem:string -> string -> family + val labels : family -> string list -> t + val v_label : label_name:string -> ?registry:CollectorRegistry.t -> help:string -> ?namespace:string -> ?subsystem:string -> string -> (string -> t) + val v : ?registry:CollectorRegistry.t -> help:string -> ?namespace:string -> ?subsystem:string -> string -> t +end + +module type CHILD = sig + type t + 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 + include METRIC with type t = Child.t +end = struct + type family = { + metric : MetricInfo.t; + mutable children : Child.t LabelSetMap.t; + } + + type t = Child.t + + let collect t = + 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 = { + metric; + children = LabelSetMap.empty; + } in + CollectorRegistry.register registry metric (fun () -> collect t); + t + + let labels t label_values = + assert (List.length t.metric.MetricInfo.label_names = List.length label_values); + match LabelSetMap.find label_values t.children with + | Some child -> child + | None -> + let child = Child.create () in + t.children <- LabelSetMap.add label_values child t.children; + child + + let v_label ~label_name ?registry ~help ?namespace ?subsystem name = + let family = v_labels ~label_names:[label_name] ?registry ~help ?namespace ?subsystem name in + fun x -> labels family [x] + + let v ?registry ~help ?namespace ?subsystem name = + let family = v_labels ~help ?registry ?namespace ?subsystem name ~label_names:[] in + labels family [] +end + +module Counter = struct + include Metric(struct + type t = float ref + let create () = ref 0.0 + let values t = [Sample_set.sample !t] + let metric_type = Counter + let validate_label _ = () + end) + + let inc_one t = + t := !t +. 1.0 + + let inc t v = + assert (v >= 0.0); + t := !t +. v +end + +module Gauge = struct + include Metric(struct + type t = float ref + let create () = ref 0.0 + let values t = [Sample_set.sample !t] + let metric_type = Gauge + let validate_label _ = () + end) + + let inc t v = + t := !t +. v + let inc_one t = inc t 1.0 + + let dec t x = inc t (-. x) + let dec_one t = dec t 1.0 + + let set t v = + t := v + + let track_inprogress t fn = + inc_one t; + Lwt.finalize fn (fun () -> dec_one t; Lwt.return_unit) + + let time t gettimeofday fn = + let start = gettimeofday () in + Lwt.finalize fn + (fun () -> + let finish = gettimeofday () in + inc t (finish -. start); + Lwt.return_unit + ) +end + +module Summary = struct + module Child = struct + type t = { + mutable count : float; + mutable sum : float; + } + let create () = { count = 0.0; sum = 0.0 } + let values t = + [ + Sample_set.sample ~ext:"_sum" t.sum; + 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) + + let observe t v = + let open Child in + t.count <- t.count +. 1.0; + 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 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/prometheus/src/prometheus.mli b/prometheus/src/prometheus.mli new file mode 100644 index 000000000000..e053680af1a9 --- /dev/null +++ b/prometheus/src/prometheus.mli @@ -0,0 +1,213 @@ +(** Collect metrics for Prometheus. + See: https://prometheus.io/ + + Notes: + + - The Prometheus docs require that client libraries are thread-safe. We interpret this to mean safe + with Lwt threads, NOT with native threading. + + - 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. +*) + +type metric_type = + | Counter + | Gauge + | Summary + | Histogram + +module type NAME = sig + type t = private string + + val v : string -> t + (** Raises an exception if the name is not valid. *) + + val pp : Format.formatter -> t -> unit + + val compare : t -> t -> int +end +(** A string that meets some additional requirements. *) + +module MetricName : NAME +(** A valid name for a metric. *) + +module LabelName : NAME +(** A valid name for a label. *) + +module MetricInfo : sig + type t = { + name : MetricName.t; + metric_type : metric_type; + help : string; + label_names : LabelName.t list; + } +end +(** Metadata about a metric. *) + +module LabelSetMap : Asetmap.Map.S with type key = string list +(** A map indexed by a set of labels. *) + +module MetricFamilyMap : Asetmap.Map.S with type key = MetricInfo.t +(** A map indexed by metric families. *) + +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 + (** A collection of values that together represent a single sample. + For a counter, each reading is just a single value, but more complex types + require multiple values. + For example, a "summary" sample set contains "_sum" and "_count" values. + *) + + val sample : ?ext:string -> ?bucket:(LabelName.t * float) -> float -> sample +end + +module CollectorRegistry : sig + type t + (** A collection of metrics to be monitored. *) + + type snapshot = Sample_set.t LabelSetMap.t MetricFamilyMap.t + (** The result of reading a set of metrics. *) + + val create : unit -> t + (** [create ()] is a fresh registry. This is mostly useful for testing. *) + + val default : t + (** The default registry. *) + + val collect : t -> snapshot Lwt.t + (** Read the current value of each metric. *) + + val register : t -> MetricInfo.t -> (unit -> Sample_set.t LabelSetMap.t) -> unit + (** [register t metric collector] adds [metric] to the set of metrics being collected. + 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 + (** [register_lwt t metric collector] is the same as [register t metrics collector] + but [collector] returns [Sample_set.t LabelSetMap.t Lwt.t]. *) + + val register_pre_collect : t -> (unit -> unit) -> unit + (** [register_pre_collect t fn] arranges for [fn ()] to be called at the start + of each collection. This is useful if one expensive call provides + 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]. *) +end +(** A collection of metric reporters. Usually, only {!CollectorRegistry.default} is used. *) + +module type METRIC = sig + type family + (** A collection of metrics that are the same except for their labels. + e.g. "Number of HTTP responses" *) + + type t + (** A particular metric. + e.g. "Number of HTTP responses with code=404" *) + + val v_labels : label_names:string list -> ?registry:CollectorRegistry.t -> help:string -> ?namespace:string -> ?subsystem:string -> string -> family + (** [v_labels ~label_names ~help ~namespace ~subsystem name] is a family of metrics with full name + [namespace_subsystem_name] and documentation string [help]. Each metric in the family will provide + a value for each of the labels. + The new family is registered with [registry] (default: {!CollectorRegistry.default}). *) + + val labels : family -> string list -> t + (** [labels family label_values] is the metric in [family] with these values for the labels. + The order of the values must be the same as the order of the [label_names] passed to [v_labels]; + you may wish to write a wrapper function with labelled arguments to avoid mistakes. + If this is called multiple times with the same set of values, the existing metric will be returned. *) + + val v_label : label_name:string -> ?registry:CollectorRegistry.t -> help:string -> ?namespace:string -> ?subsystem:string -> string -> (string -> t) + (** [v_label] is a convenience wrapper around [v_labels] for the case where there is a single label. + The result is a function from the single label's value to the metric. *) + + val v : ?registry:CollectorRegistry.t -> help:string -> ?namespace:string -> ?subsystem:string -> string -> t + (** [v] is a convenience wrapper around [v_labels] for the case where there are no labels. *) +end +(** Operations common to all types of metric. *) + +module Counter : sig + include METRIC + val inc_one : t -> unit + val inc : t -> float -> unit + (** [inc t v] increases [t] by [v], which must be non-negative. *) +end +(** A counter is a cumulative metric that represents a single numerical value that only ever goes up. *) + +module Gauge : sig + include METRIC + + val inc_one : t -> unit + val inc : t -> float -> unit + (** [inc t v] increases the current value of the guage by [v]. *) + + val dec_one : t -> unit + val dec : t -> float -> unit + (** [dec t v] decreases the current value of the guage by [v]. *) + + val set : t -> float -> unit + (** [set t v] sets the current value of the guage to [v]. *) + + val track_inprogress : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t + (** [track_inprogress t f] increases the value of the gauge by one while [f ()] is running. *) + + val time : t -> (unit -> float) -> (unit -> 'a Lwt.t) -> 'a Lwt.t + (** [time t gettime f] calls [gettime ()] before and after executing [f ()] and + increases the metric by the difference. + *) +end +(** A gauge is a metric that represents a single numerical value that can arbitrarily go up and down. *) + +module Summary : sig + include METRIC + + val observe : t -> float -> unit + (** [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 + (** [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. *) + +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/prometheus/tests/dune b/prometheus/tests/dune new file mode 100644 index 000000000000..8a23e948f900 --- /dev/null +++ b/prometheus/tests/dune @@ -0,0 +1,4 @@ +(test + (name test) + (package prometheus-app) + (libraries prometheus prometheus-app alcotest alcotest-lwt)) diff --git a/prometheus/tests/test.ml b/prometheus/tests/test.ml new file mode 100644 index 000000000000..c4d2467c4770 --- /dev/null +++ b/prometheus/tests/test.ml @@ -0,0 +1,179 @@ +open! Astring +open Prometheus +open Prometheus_app + +open Lwt.Infix + +let test_metrics () = + let registry = CollectorRegistry.create () in + let requests = + let label_names = ["method"; "path"] in + Counter.v_labels ~label_names ~registry ~help:"Requests" ~namespace:"dkci" ~subsystem:"tests" "requests" in + let m = Counter.v ~registry ~help:"Test \\counter:\n1" "tests" in + Counter.inc_one m; + let get_index = Counter.labels requests ["GET"; "\"\\-\n"] in + let post_login = Counter.labels requests ["POST"; "/login"] in + Counter.inc get_index 5.; + Counter.inc post_login 2.; + let post_login2 = Counter.labels requests ["POST"; "/login"] in + Counter.inc_one post_login2; + CollectorRegistry.collect registry >|= fun collected -> + let output = Fmt.to_to_string TextFormat_0_0_4.output collected in + Alcotest.(check string) "Text output" + "#HELP dkci_tests_requests Requests\n\ + #TYPE dkci_tests_requests counter\n\ + dkci_tests_requests{method=\"GET\", path=\"\\\"\\\\-\\n\"} 5.000000\n\ + dkci_tests_requests{method=\"POST\", path=\"/login\"} 3.000000\n\ + #HELP tests Test \\\\counter:\\n1\n\ + #TYPE tests counter\n\ + tests 1.000000\n\ + " + output + +let test_lwt_collectors () = + let registry = CollectorRegistry.create () in + 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 + CollectorRegistry.register_lwt registry metric_info collector + in + (* Test register_lwt *) + register_counter ~name:"counter_1" ~help:"The first counter" 1.0; + register_counter ~name:"counter_2" ~help:"The second counter" 2.0; + 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_1 The first counter\n\ + #TYPE counter_1 counter\n\ + counter_1 1.000000\n\ + #HELP counter_2 The second counter\n\ + #TYPE counter_2 counter\n\ + counter_2 2.000000\n" + 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; + CollectorRegistry.collect registry >|= fun collected -> + let output = Fmt.to_to_string TextFormat_0_0_4.output collected 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.120000\n\ + dkci_tests_requests_count{method=\"GET\", path=\"/foo\"} 1.000000\n\ + dkci_tests_requests_bucket{le=\"+Inf\", method=\"GET\", path=\"/foo\"} 1.000000\n\ + dkci_tests_requests_bucket{le=\"0.500000\", method=\"GET\", path=\"/foo\"} 1.000000\n\ + dkci_tests_requests_bucket{le=\"0.250000\", method=\"GET\", path=\"/foo\"} 1.000000\n\ + dkci_tests_requests_sum{method=\"PUT\", path=\"/bar\"} 0.330000\n\ + dkci_tests_requests_count{method=\"PUT\", path=\"/bar\"} 1.000000\n\ + dkci_tests_requests_bucket{le=\"+Inf\", method=\"PUT\", path=\"/bar\"} 1.000000\n\ + dkci_tests_requests_bucket{le=\"0.500000\", method=\"PUT\", path=\"/bar\"} 1.000000\n\ + dkci_tests_requests_bucket{le=\"0.250000\", method=\"PUT\", path=\"/bar\"} 0.000000\n\ + " + output + +(* "^[a-zA-Z_][a-zA-Z0-9_]*$" *) +let valid_labels = [ + "_"; + "a"; + "aA0b1B9c8C7z6Z5y4Y3x2X1"; + "_______"; +] + +let invalid_labels = [ + ""; + "1"; + "a bad label"; +] + +let check_valid_label label () = + let _l: LabelName.t = LabelName.v label in + () + +let check_invalid_label label () = + let valid = + try + let _l: LabelName.t = LabelName.v label in + true + with _ -> false in + if valid then + failwith (label ^ " should be an invalid label") + +let test_valid_labels_set = List.map (fun label -> + label, `Quick, fun () -> Lwt.return @@ check_valid_label label () +) valid_labels + +let test_invalid_labels_set = List.map (fun label -> + label, `Quick, fun () -> Lwt.return @@ check_invalid_label label () +) invalid_labels + +let check_valid_metric metric () = + let _m: MetricName.t = MetricName.v metric in + () + +let check_invalid_metric metric () = + let valid = + try + let _m: MetricName.t = MetricName.v metric in + true + with _ -> false in + if valid then + failwith (metric ^ " should be an invalid metric") + +(* "^[a-zA-Z_:][a-zA-Z0-9_:]*$" *) +let valid_metrics = [ + "_"; + ":"; + "aA0b1B9c8C7z6Z5y4Y3x:2X1"; + ":::::::"; +] + +let invalid_metrics = [ + ""; + "1"; + "a bad metric"; +] + +let test_valid_metrics_set = List.map (fun metric -> + metric, `Quick, fun () -> Lwt.return @@ check_valid_metric metric () +) valid_metrics + +let test_invalid_metrics_set = List.map (fun metric -> + metric, `Quick, fun () -> Lwt.return @@ check_invalid_metric metric () +) invalid_metrics + +let test_set = [ + "Metrics", `Quick, test_metrics; + "Lwt collectors",`Quick, test_lwt_collectors; + "Histogram", `Quick, test_histogram; +] + +let () = + Lwt_main.run @@ Alcotest_lwt.run "prometheus" [ + "main", test_set; + "valid_labels", test_valid_labels_set; + "invalid_labels", test_invalid_labels_set; + "valid_metrics", test_valid_metrics_set; + "invalid_metrics", test_invalid_metrics_set; + ] diff --git a/prometheus/tests/test.mli b/prometheus/tests/test.mli new file mode 100644 index 000000000000..e69de29bb2d1 -- GitLab From f7a79b0cddd8ef616c220189f8fa67295ea0338c Mon Sep 17 00:00:00 2001 From: Gabriel Moise Date: Mon, 1 Jul 2024 15:48:13 +0100 Subject: [PATCH 2/3] Prometheus: Mark as data only (ignored by dune) for now --- dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dune b/dune index c3c7d8e6c601..bf853fa18147 100644 --- a/dune +++ b/dune @@ -1,6 +1,6 @@ (vendored_dirs vendors) -(data_only_dirs _opam-repo-for-release) +(data_only_dirs _opam-repo-for-release prometheus) (env (_ -- GitLab From 1e160a08c6cc05560b09a0ad21bea506478f9281 Mon Sep 17 00:00:00 2001 From: Gabriel Moise Date: Mon, 1 Jul 2024 15:49:10 +0100 Subject: [PATCH 3/3] Manifest: Exclude prometheus from build-file generation --- manifest/main.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/manifest/main.ml b/manifest/main.ml index d67806a132c0..ba88add8f878 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -72,6 +72,8 @@ let exclude filename = | ["opam"; "mandatory-for-make.opam"] -> true (* opam-repository is used by scripts/opam-release.sh *) | "opam-repository" :: _ -> true + (* prometheus is imported as data-only for now to ease review of its monorepotisation. *) + | "prometheus" :: _ -> true (* We need to tell Dune about excluding directories without defining targets in those directories. Therefore we hand write some Dune in these. *) | "src" :: "riscv" :: _ -> true -- GitLab