Source file `metrics_lwt.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
(*
 * Copyright (c) 2018 Thomas Gazagnaire <thomas@gazagnaire.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open Metrics
open Lwt.Infix

let add_no_check_lwt src ?duration ?status tags f =
  let ret, unblock = Lwt.wait () in
  let k () = ret in
  let over () = Lwt.wakeup unblock () in
  report src ~over ~k tags (fun data k ->
      f data >>= fun data ->
      let data =
        match (duration, status) with
        | None, None -> data
        | Some d, None | None, Some d -> Data.cons d data
        | Some x, Some y -> Data.cons x (Data.cons y data)
      in
      init src data;
      k data)

let add src tags f =
  if is_active src then add_no_check_lwt src tags f else Lwt.return ()

let mk t f v = if t then Some (f v) else None

let run src tags g =
  if not (is_active src) then g ()
  else
    let d0 = now () in
    Lwt.catch (fun () -> g () >|= fun x -> Ok x) (fun e -> Lwt.return (Error e))
    >>= fun r ->
    let duration =
      mk (Src.duration (Src src)) duration (Int64.sub (now ()) d0)
    in
    let status x = mk (Src.status (Src src)) status x in
    match r with
    | Ok x ->
      add_no_check_lwt src tags ?duration
        ?status:(status `Ok)
        (fun f -> Lwt.return (f r))
      >|= fun () -> x
    | Error e ->
      add_no_check_lwt src tags ?duration
        ?status:(status `Error)
        (fun f -> Lwt.return (f r))
      >|= fun () -> raise e

let rrun src tags g =
  if not (is_active src) then g ()
  else
    let d0 = now () in
    Lwt.catch
      (fun () -> g () >|= fun x -> Ok x)
      (fun e -> Lwt.return (Error (`Exn e)))
    >>= fun r ->
    let duration =
      mk (Src.duration (Src src)) duration (Int64.sub (now ()) d0)
    in
    let status x = mk (Src.status (Src src)) status x in
    match r with
    | Ok (Ok _ as x) ->
      add_no_check_lwt src tags ?duration
        ?status:(status `Ok)
        (fun f -> Lwt.return (f x))
      >|= fun () -> x
    | Ok (Error e as x) ->
      add_no_check_lwt src tags ?duration
        ?status:(status `Error)
        (fun f -> Lwt.return (f (Error (`Error e))))
      >|= fun () -> x
    | Error (`Exn e as x) ->
      add_no_check_lwt src tags ?duration
        ?status:(status `Error)
        (fun f -> Lwt.return (f (Error x)))
      >|= fun () -> raise e

let periodic = ref []

let periodically src = periodic := src :: !periodic

let log_stats ~tags =
  let doc = "Statistics of the Logs library" in
  let data () =
    let warnings, errors = (Logs.warn_count (), Logs.err_count ()) in
    Data.v [ int "warnings" warnings; int "errors" errors ]
  in
  Src.v ~doc ~tags ~data "logs"

let init_periodic ?(gc = `Full) ?(logs = true) sleeper =
  (match gc with
  | `None -> ()
  | `Quick -> periodically (gc_quick_stat ~tags:Tags.[])
  | `Full -> periodically (gc_stat ~tags:Tags.[]));
  if logs then periodically (log_stats ~tags:Tags.[]);
  let collect () =
    List.iter
      (fun src -> Metrics.add src (fun x -> x) (fun d -> d ()))
      !periodic;
    Lwt.return_unit
  in
  let rec loop () = Lwt.join [ sleeper (); collect () ] >>= loop in
  Lwt.async loop