Revision d0a99151704ed9575dbe9d8422ed25f86972bbc3 authored by Marge Bot on 19 January 2024, 11:29:07 UTC, committed by Marge Bot on 19 January 2024, 11:29:07 UTC
Co-authored-by: Eugen Zalinescu <eugen.zalinescu@nomadic-labs.com> Approved-by: Raphaƫl Cauderlier <raphael.cauderlier@nomadic-labs.com> Approved-by: Mohamed IGUERNLALA <iguer@functori.com> See merge request https://gitlab.com/tezos/tezos/-/merge_requests/11544
internal_event.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
module List = struct
include List
include Tezos_stdlib.TzList
end
module String = struct
include String
include Tezos_stdlib.TzString
module Set = Tezos_error_monad.TzLwtreslib.Set.Make (String)
end
let valid_char c =
match c with
| '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '@' | '-' | '_' | '+' | '=' | '~' ->
true
| _ -> false
let check_name_exn : string -> (string -> char -> exn) -> unit =
fun name make_exn ->
String.iter
(fun c -> if valid_char c then () else raise (make_exn name c))
name ;
()
(* Levels are declared from the lowest to the highest so that
polymorphic comparison can be used to check whether a message
should be printed. *)
type level = Debug | Info | Notice | Warning | Error | Fatal
let default_error_fallback_logger =
ref (fun s ->
Format.eprintf "%s" s ;
Lwt.return_unit)
module Level = struct
type t = level
let default = Info
let to_string = function
| Debug -> "debug"
| Info -> "info"
| Notice -> "notice"
| Warning -> "warning"
| Error -> "error"
| Fatal -> "fatal"
let of_string str =
let str = String.lowercase_ascii str in
match str with
| "debug" -> Some Debug
| "info" -> Some Info
| "notice" -> Some Notice
| "warning" -> Some Warning
| "error" -> Some Error
| "fatal" -> Some Fatal
| _ -> None
let encoding =
let open Data_encoding in
string_enum
(List.map
(fun l -> (to_string l, l))
[Debug; Info; Notice; Warning; Error; Fatal])
include Compare.Make (struct
type nonrec t = t
let compare = Stdlib.compare
end)
end
module Section : sig
type t
include Compare.S with type t := t
val empty : t
val make_sanitized : string list -> t
val name : t -> string
val is_prefix : prefix:t -> t -> bool
val encoding : t Data_encoding.t
val to_string_list : t -> string list
val pp : Format.formatter -> t -> unit
val equal : t -> t -> bool
end = struct
type t = {path : string list}
include Compare.Make (struct
type nonrec t = t
let compare = Stdlib.compare
end)
let empty = {path = []}
let name s = String.concat "." s.path
let make sl =
List.iter
(fun s ->
check_name_exn s (fun name char ->
Printf.ksprintf
(fun s -> Invalid_argument s)
"Internal_event.Section: invalid name %S (contains %c)"
name
char))
sl ;
{path = sl}
let make_sanitized sl =
List.map (String.map (fun c -> if valid_char c then c else '_')) sl |> make
let to_string_list s = s.path
let is_prefix ~prefix main =
try
let _ =
List.fold_left
(fun prev elt ->
match prev with
| t :: q when String.equal t elt -> q
| _ -> raise Not_found)
main.path
prefix.path
in
true
with Not_found -> false
let encoding =
let open Data_encoding in
conv (fun {path; _} -> path) (fun l -> make l) (list string)
let pp fmt section =
Format.fprintf
fmt
"%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.pp_print_char fmt '.')
Format.pp_print_string)
section.path
end
let registered_sections = ref String.Set.empty
let get_registered_sections () = String.Set.to_seq !registered_sections
let register_section section =
registered_sections :=
String.Set.add (Section.name section) !registered_sections
module type EVENT_DEFINITION = sig
type t
val section : Section.t option
val name : string
val doc : string
val pp : all_fields:bool -> block:bool -> Format.formatter -> t -> unit
val encoding : t Data_encoding.t
val level : level
end
module type EVENT = sig
include EVENT_DEFINITION
val emit : ?section:Section.t -> t -> unit tzresult Lwt.t
end
type 'a event_definition = (module EVENT_DEFINITION with type t = 'a)
module type SINK = sig
type t
val uri_scheme : string
val configure : Uri.t -> t tzresult Lwt.t
val should_handle : ?section:Section.t -> t -> _ event_definition -> bool
val handle :
t -> 'a event_definition -> ?section:Section.t -> 'a -> unit tzresult Lwt.t
val close : t -> unit tzresult Lwt.t
end
type 'a sink_definition = (module SINK with type t = 'a)
module All_sinks = struct
type registered =
| Registered : {
scheme : string;
definition : 'a sink_definition;
}
-> registered
type active =
| Active : {
scheme : string;
configuration : Uri.t;
sink : 'a;
definition : 'a sink_definition;
}
-> active
let registered : registered list ref = ref []
let active : active list ref = ref []
let find_registered scheme_to_find =
List.find
(function Registered {scheme; _} -> String.equal scheme scheme_to_find)
!registered
let register (type a) m =
let module S = (val m : SINK with type t = a) in
match find_registered S.uri_scheme with
| None ->
registered :=
Registered {scheme = S.uri_scheme; definition = m} :: !registered
| Some _ ->
(* This should be considered a programming error: *)
Printf.ksprintf
Stdlib.invalid_arg
"Internal_event: registering duplicate URI scheme: %S"
S.uri_scheme
type activation_error_reason =
| Missing_uri_scheme of string
| Uri_scheme_not_registered of string
type error += Activation_error of activation_error_reason
let () =
let description =
"Activation of an Internal Event SINK with an URI failed"
in
let title = "Internal Event Sink: Wrong Activation URI" in
register_error_kind
`Permanent
~id:"internal-event-activation-error"
~title
~description
~pp:
(fun ppf -> function
| Missing_uri_scheme uri ->
Format.fprintf ppf "%s: Missing URI scheme %S" title uri
| Uri_scheme_not_registered uri ->
Format.fprintf ppf "%s: URI scheme not registered %S" title uri)
Data_encoding.(
union
[
case
~title:"missing-uri-scheme"
(Tag 0)
(obj1 (req "missing-uri-scheme" (obj1 (req "uri" string))))
(function Missing_uri_scheme uri -> Some uri | _ -> None)
(fun uri -> Missing_uri_scheme uri);
case
~title:"non-registered-uri-scheme"
(Tag 2)
(obj1 (req "non-registered-uri-scheme" (obj1 (req "uri" string))))
(function Uri_scheme_not_registered uri -> Some uri | _ -> None)
(fun uri -> Uri_scheme_not_registered uri);
])
(function Activation_error reason -> Some reason | _ -> None)
(fun reason -> Activation_error reason)
let activate uri =
let open Lwt_result_syntax in
match Uri.scheme uri with
| None -> tzfail (Activation_error (Missing_uri_scheme (Uri.to_string uri)))
| Some scheme_to_activate ->
let* act =
match find_registered scheme_to_activate with
| None ->
tzfail
(Activation_error
(Uri_scheme_not_registered (Uri.to_string uri)))
| Some (Registered {scheme; definition}) ->
(* We need the intermediate function to introduce the type *)
let activate (type a) scheme definition =
let module S = (val definition : SINK with type t = a) in
let* sink = S.configure uri in
return (Active {scheme; configuration = uri; definition; sink})
in
activate scheme definition
in
active := act :: !active ;
return_unit
let close ?(except = fun _ -> false) () =
let open Lwt_syntax in
let close_one (type a) sink definition =
let module S = (val definition : SINK with type t = a) in
S.close sink
in
(* We want to filter the list in one Lwt-go (atomically), and only then
call close on the ones that are being deleted. *)
let next_active, to_close_list =
List.partition
(fun act ->
match act with Active {configuration; _} -> except configuration)
!active
in
active := next_active ;
(* We don't want one failure to prevent the attempt at closing as many
sinks as possible, so we record all errors and combine them: *)
let+ close_results =
List.map_s
(fun (Active {sink; definition; _}) -> close_one sink definition)
to_close_list
in
Result_syntax.tzjoin close_results
let handle def section v =
let handle (type a) sink definition =
let open Lwt_result_syntax in
let module S = (val definition : SINK with type t = a) in
if S.should_handle ?section sink def then S.handle ?section sink def v
else return_unit
in
List.iter_es
(function Active {sink; definition; _} -> handle sink definition)
!active
let pp_state fmt () =
let open Format in
let pp_list_of_sinks name list pp =
pp_open_box fmt 2 ;
pp_print_if_newline fmt () ;
pp_print_string fmt "* " ;
fprintf fmt "%s: [" name ;
pp_print_cut fmt () ;
pp_print_list
~pp_sep:(fun fmt () ->
pp_print_string fmt "," ;
pp_print_space fmt ())
pp
fmt
list ;
pp_close_box fmt () ;
pp_print_cut fmt () ;
pp_print_string fmt "]"
in
pp_open_box fmt 0 ;
pp_list_of_sinks
"Registered sinks"
!registered
(fun fmt (Registered {scheme; _}) -> fprintf fmt "\"%s://..\"" scheme) ;
pp_print_break fmt 2 0 ;
pp_list_of_sinks
"Active sinks"
!active
(fun fmt (Active {configuration; _}) ->
fprintf fmt "\"%a\"" Uri.pp_hum configuration) ;
pp_print_cut fmt () ;
pp_close_box fmt () ;
()
end
module Generic = struct
type definition =
| Definition :
(Section.t option * string * 'a event_definition)
-> definition
type event = Event : (string * 'a event_definition * 'a) -> event
type with_name = < doc : string ; name : string >
let json_schema (Definition (_, _, d)) :
< schema : Json_schema.schema ; with_name > =
let aux (type a) (ev : a event_definition) =
let module E = (val ev : EVENT_DEFINITION with type t = a) in
object
method name = E.name
method doc = E.doc
method schema = Data_encoding.Json.schema E.encoding
end
in
aux d
let explode_event (Event (_, def, ev)) =
let aux (type a) def ev =
let module M = (val def : EVENT_DEFINITION with type t = a) in
object
method name = M.name
method doc = M.doc
method pp fmt () = M.pp ~all_fields:true ~block:true fmt ev
method json = Data_encoding.Json.construct M.encoding ev
end
in
aux def ev
end
module All_definitions = struct
open Generic
let all : definition list ref = ref []
let registration_exn fmt =
Format.kasprintf
(fun s ->
(* This should be considered a programming error: *)
Invalid_argument ("Internal_event registration error: " ^ s))
fmt
let add (type a) ev =
let module E = (val ev : EVENT_DEFINITION with type t = a) in
match
List.find
(function Definition (s, n, _) -> E.section = s && E.name = n)
!all
with
| Some _ ->
raise
(registration_exn
"duplicate Event name: %a %S"
(Format.pp_print_option Section.pp)
E.section
E.name)
| None ->
check_name_exn
E.name
(registration_exn "invalid event name: %S contains '%c'") ;
all := Definition (E.section, E.name, ev) :: !all
let get () = !all
let find match_name =
List.find (function Definition (_, n, _) -> match_name n) !all
end
module Make (E : EVENT_DEFINITION) : EVENT with type t = E.t = struct
include E
let emit ?section x = All_sinks.handle (module E) section x
let () = All_definitions.add (module E)
end
module Simple = struct
(* This type is mostly there to make usage less error-prone, by
explicitly splitting the place where the partial application
takes place. Indeed, it is important that events are declared
only once. *)
type 'a t = {name : string; emit : 'a -> unit tzresult Lwt.t}
let emit simple_event parameters =
Lwt.try_bind
(fun () -> simple_event.emit parameters)
(function
| Ok () -> Lwt.return_unit
| Error trace ->
(* Having to handle errors when sending events would make the
code very heavy. We are much more likely to just use [let*]
to propagate the error, assuming that sending events cannot
fail. But consider this example:
- we log that we are going to do some cleanup, like remove
temporary directories...
- and then because we failed to log, we don't actually
clean the temporary directories.
Instead we just print the error on stderr. *)
Format.eprintf
"@[<hv 2>Failed to send event '%s':@ %a@]@."
simple_event.name
Error_monad.pp_print_trace
trace ;
Lwt.return_unit)
(fun exc ->
(* For the same reason we also just print exceptions *)
Format.eprintf
"@[<hv 2>Failed to send event '%s':@ %s@]@."
simple_event.name
(Printexc.to_string exc) ;
Lwt.return_unit)
let emit__dont_wait__use_with_care simple_event parameters =
Lwt.dont_wait
(fun () -> emit simple_event parameters)
(fun exc -> raise exc)
(* emit never lets exceptions escape *)
let make_section names =
match names with
| None -> None
| Some names ->
let section = Section.make_sanitized names in
register_section section ;
Some section
let pp_print_compact_float fmt value = Format.fprintf fmt "%g" value
let max_shortened_string_length = 64
let ellipsis = "[...]"
let pp_print_shortened_string fmt value =
let len = String.length value in
if len = 0 then Format.pp_print_string fmt "\"\""
else
let escape len =
let rec loop i =
if i >= len then false
else
match value.[i] with
| '\000' .. '\032' | '\127' .. '\255' ->
(* invisible character (including space) or non-ASCII: needs to be escaped *)
true
| '\033' .. '\126' ->
(* visible, non-space character *)
loop (i + 1)
in
loop 0
in
if String.length value > max_shortened_string_length then
let length_without_ellipsis =
max_shortened_string_length - String.length ellipsis
in
let prefix = String.sub value 0 length_without_ellipsis in
if escape length_without_ellipsis then
Format.fprintf fmt "\"%s%s\"" prefix ellipsis
else Format.fprintf fmt "%s%s" prefix ellipsis
else if escape len then Format.fprintf fmt "%S" value
else Format.pp_print_string fmt value
(* Default pretty-printer for parameters.
Simple types are printed in a compact way.
Structured types are not printed.
If [never_empty] is [false], do not print anything for:
- structured values, like objects;
- empty values, like null.
This is useful to ignore non-inline parameters in log messages.
If [never_empty] is [true], always print something.
This is useful for inline parameters. *)
let rec pp_human_readable :
'a. never_empty:bool -> 'a Data_encoding.t -> _ -> 'a -> _ =
fun (type a) ~never_empty (encoding : a Data_encoding.t) fmt (value : a) ->
match encoding.encoding with
| Null -> if never_empty then Format.pp_print_string fmt "N/A"
| Empty -> if never_empty then Format.pp_print_string fmt "N/A"
| Ignore -> if never_empty then Format.pp_print_string fmt "N/A"
| Constant name -> pp_print_shortened_string fmt name
| Bool -> Format.pp_print_bool fmt value
| Int8 -> Format.pp_print_int fmt value
| Uint8 -> Format.pp_print_int fmt value
| Int16 -> Format.pp_print_int fmt value
| Uint16 -> Format.pp_print_int fmt value
| Int31 -> Format.pp_print_int fmt value
| Int32 -> Format.fprintf fmt "%ld" value
| Int64 -> Format.fprintf fmt "%Ld" value
| N -> Format.pp_print_string fmt (Z.to_string value)
| Z -> Format.pp_print_string fmt (Z.to_string value)
| RangedInt _ -> Format.pp_print_int fmt value
| RangedFloat _ -> pp_print_compact_float fmt value
| Float -> pp_print_compact_float fmt value
| Bytes _ -> pp_print_shortened_string fmt (Bytes.to_string value)
| String _ -> pp_print_shortened_string fmt value
| Padded (encoding, _) -> pp_human_readable ~never_empty encoding fmt value
| String_enum (table, _) -> (
match Stdlib.Hashtbl.find_opt table value with
| None -> if never_empty then Format.pp_print_string fmt "N/A"
| Some (name, _) -> pp_print_shortened_string fmt name)
| Array _ -> if never_empty then Format.pp_print_string fmt "<array>"
| List _ -> if never_empty then Format.pp_print_string fmt "<list>"
| Obj (Req {encoding; _} | Dft {encoding; _}) ->
pp_human_readable ~never_empty encoding fmt value
| Obj (Opt {encoding; _}) ->
Option.iter (pp_human_readable ~never_empty encoding fmt) value
| Objs _ -> if never_empty then Format.pp_print_string fmt "<obj>"
| Tup encoding -> pp_human_readable ~never_empty encoding fmt value
| Tups _ -> if never_empty then Format.pp_print_string fmt "<tuple>"
| Union
{
cases =
[
Case {encoding; proj; _};
Case {encoding = {encoding = Null; _}; _};
];
_;
} -> (
(* Probably an [option] type or similar.
We only print the value if it is not null,
unless [never_empty] is [true]. *)
match proj value with
| None -> if never_empty then Format.pp_print_string fmt "null"
| Some value -> pp_human_readable ~never_empty encoding fmt value)
| Union _ -> if never_empty then Format.pp_print_string fmt "<union>"
| Mu _ -> if never_empty then Format.pp_print_string fmt "<recursive>"
| Conv {proj; encoding; _} ->
(* TODO: it may be worth it to take a look at [encoding]
before calling [proj], to try and predict whether the value
will actually be printed. *)
pp_human_readable ~never_empty encoding fmt (proj value)
| Describe {encoding; _} ->
pp_human_readable ~never_empty encoding fmt value
| Splitted {json_encoding; _} -> (
(* Generally, [Splitted] nodes imply that the JSON encoding
is more human-friendly, as JSON is a human-friendly
format. A typical example is Blake2B hashes.
So for log outputs we use the JSON encoding.
Unfortunately, [Json_encoding.t] is abstract so we have
to [construct] the JSON value and continue from here. *)
(* TODO: it may be worth it to take a look at [encoding]
before constructing the JSON value, to try and predict
whether the value will actually be printed (same as [Conv]). *)
match Json_encoding.construct json_encoding value with
| `Null -> if never_empty then Format.pp_print_string fmt "N/A"
| `Bool value -> Format.pp_print_bool fmt value
| `Float value -> pp_print_compact_float fmt value
| `String value -> pp_print_shortened_string fmt value
| `A _ -> if never_empty then Format.pp_print_string fmt "<list>"
| `O _ -> if never_empty then Format.pp_print_string fmt "<obj>")
| Dynamic_size {encoding; _} ->
pp_human_readable ~never_empty encoding fmt value
| Check_size {encoding; _} ->
pp_human_readable ~never_empty encoding fmt value
| Delayed make_encoding ->
pp_human_readable ~never_empty (make_encoding ()) fmt value
type parameter =
| Parameter :
string
* 'a Data_encoding.t
* 'a
* (Format.formatter -> 'a -> unit) option
-> parameter
type msg_atom = Text of string | Variable of int | Space
let invalid_msg reason msg =
invalid_arg
(Printf.sprintf
"Internal_event.Simple: invalid message string: %S: %s"
msg
reason)
let parse_msg variable_names msg =
let len = String.length msg in
let rec find_variable_begin acc atom_start i =
let add_text () =
if i <= atom_start then acc
else Text (String.sub msg atom_start (i - atom_start)) :: acc
in
if i >= len then add_text ()
else if msg.[i] = '{' then
let acc = add_text () in
let i = i + 1 in
find_variable_end acc i i
else if msg.[i] = ' ' then
let acc = Space :: add_text () in
let i = i + 1 in
find_variable_begin acc i i
else find_variable_begin acc atom_start (i + 1)
and find_variable_end acc atom_start i =
if i >= len then invalid_msg "unmatched '{'" msg
else if msg.[i] = '}' then
let variable_name = String.sub msg atom_start (i - atom_start) in
let rec loop index = function
| [] ->
invalid_msg
(Printf.sprintf "unbound variable: %S" variable_name)
msg
| varname :: _ when String.equal varname variable_name ->
let acc = Variable index :: acc in
let i = i + 1 in
find_variable_begin acc i i
| _ :: variable_names -> loop (index + 1) variable_names
in
loop 0 variable_names
else find_variable_end acc atom_start (i + 1)
in
find_variable_begin [] 0 0 |> List.rev
let pp_log_message ~all_fields ~block (msg : msg_atom list) fmt fields =
(* Add a boolean reference to each field telling whether the field was used. *)
let fields = List.map (fun field -> (field, ref false)) fields in
if block then Format.fprintf fmt "@[<hov 2>" ;
(* First, print [msg], including interpolated variables. *)
let pp_msg_atom = function
| Text text -> Format.pp_print_string fmt text
| Variable index -> (
match List.nth_opt fields index with
| None ->
(* Not supposed to happen, by construction.
But it's just logging, no need to fail here. *)
Format.pp_print_string fmt "???"
| Some (Parameter (_name, enc, value, pp), used) -> (
used := true ;
match pp with
| None -> pp_human_readable ~never_empty:true enc fmt value
| Some pp -> pp fmt value))
| Space ->
if block then Format.pp_print_space fmt () else Format.fprintf fmt " "
in
List.iter pp_msg_atom msg ;
(* Then, print variables that were not used by [msg]. *)
let first_field = ref true in
let print_field (Parameter (name, enc, value, pp), used) =
if not !used then
let value =
let pp =
match pp with
| None -> pp_human_readable ~never_empty:false enc
| Some pp -> pp
in
Format.asprintf "%a" pp value
in
if String.length value > 0 then
if !first_field then (
first_field := false ;
Format.fprintf fmt "@ (%s = %s" name value)
else Format.fprintf fmt ",@ %s = %s" name value
in
if all_fields then List.iter print_field fields ;
if not !first_field then Format.fprintf fmt ")" ;
if block then Format.fprintf fmt "@]"
let with_version ~name encoding =
Data_encoding.With_version.encoding
~name
(Data_encoding.With_version.first_version encoding)
let declare_0 ?section ~name ~msg ?(level = Info) () =
let section = make_section section in
let parsed_msg = parse_msg [] msg in
let module Definition : EVENT_DEFINITION with type t = unit = struct
type t = unit
let doc = msg
let section = section
let name = name
let pp ~all_fields ~block fmt () =
pp_log_message ~all_fields ~block parsed_msg fmt []
let encoding = with_version ~name Data_encoding.unit
let level = level
end in
let module Event = Make (Definition) in
{name; emit = (fun () -> Event.emit ?section ())}
let declare_1 (type a) ?section ~name ~msg ?(level = Info) ?pp1
(f1_name, (f1_enc : a Data_encoding.t)) =
let section = make_section section in
let parsed_msg = parse_msg [f1_name] msg in
let module Definition : EVENT_DEFINITION with type t = a = struct
type t = a
let doc = msg
let section = section
let name = name
let pp ~all_fields ~block fmt f1 =
pp_log_message
~all_fields
~block
parsed_msg
fmt
[Parameter (f1_name, f1_enc, f1, pp1)]
let encoding = with_version ~name f1_enc
let level = level
end in
let module Event = Make (Definition) in
{name; emit = (fun parameter -> Event.emit ?section parameter)}
let declare_2 (type a b) ?section ~name ~msg ?(level = Info) ?pp1
(f1_name, (f1_enc : a Data_encoding.t)) ?pp2
(f2_name, (f2_enc : b Data_encoding.t)) =
let section = make_section section in
let parsed_msg = parse_msg [f1_name; f2_name] msg in
let module Definition : EVENT_DEFINITION with type t = a * b = struct
type t = a * b
let doc = msg
let section = section
let name = name
let pp ~all_fields ~block fmt (f1, f2) =
pp_log_message
~all_fields
~block
parsed_msg
fmt
[
Parameter (f1_name, f1_enc, f1, pp1);
Parameter (f2_name, f2_enc, f2, pp2);
]
let encoding =
with_version ~name
@@ Data_encoding.obj2
(Data_encoding.req f1_name f1_enc)
(Data_encoding.req f2_name f2_enc)
let level = level
end in
let module Event = Make (Definition) in
{name; emit = (fun parameters -> Event.emit ?section parameters)}
let declare_3 (type a b c) ?section ~name ~msg ?(level = Info) ?pp1
(f1_name, (f1_enc : a Data_encoding.t)) ?pp2
(f2_name, (f2_enc : b Data_encoding.t)) ?pp3
(f3_name, (f3_enc : c Data_encoding.t)) =
let section = make_section section in
let parsed_msg = parse_msg [f1_name; f2_name; f3_name] msg in
let module Definition : EVENT_DEFINITION with type t = a * b * c = struct
type t = a * b * c
let doc = msg
let section = section
let name = name
let pp ~all_fields ~block fmt (f1, f2, f3) =
pp_log_message
~all_fields
~block
parsed_msg
fmt
[
Parameter (f1_name, f1_enc, f1, pp1);
Parameter (f2_name, f2_enc, f2, pp2);
Parameter (f3_name, f3_enc, f3, pp3);
]
let encoding =
with_version ~name
@@ Data_encoding.obj3
(Data_encoding.req f1_name f1_enc)
(Data_encoding.req f2_name f2_enc)
(Data_encoding.req f3_name f3_enc)
let level = level
end in
let module Event = Make (Definition) in
{name; emit = (fun parameters -> Event.emit ?section parameters)}
let declare_4 (type a b c d) ?section ~name ~msg ?(level = Info) ?pp1
(f1_name, (f1_enc : a Data_encoding.t)) ?pp2
(f2_name, (f2_enc : b Data_encoding.t)) ?pp3
(f3_name, (f3_enc : c Data_encoding.t)) ?pp4
(f4_name, (f4_enc : d Data_encoding.t)) =
let section = make_section section in
let parsed_msg = parse_msg [f1_name; f2_name; f3_name; f4_name] msg in
let module Definition : EVENT_DEFINITION with type t = a * b * c * d =
struct
type t = a * b * c * d
let doc = msg
let section = section
let name = name
let pp ~all_fields ~block fmt (f1, f2, f3, f4) =
pp_log_message
~all_fields
~block
parsed_msg
fmt
[
Parameter (f1_name, f1_enc, f1, pp1);
Parameter (f2_name, f2_enc, f2, pp2);
Parameter (f3_name, f3_enc, f3, pp3);
Parameter (f4_name, f4_enc, f4, pp4);
]
let encoding =
with_version ~name
@@ Data_encoding.obj4
(Data_encoding.req f1_name f1_enc)
(Data_encoding.req f2_name f2_enc)
(Data_encoding.req f3_name f3_enc)
(Data_encoding.req f4_name f4_enc)
let level = level
end in
let module Event = Make (Definition) in
{name; emit = (fun parameters -> Event.emit ?section parameters)}
let declare_5 (type a b c d e) ?section ~name ~msg ?(level = Info) ?pp1
(f1_name, (f1_enc : a Data_encoding.t)) ?pp2
(f2_name, (f2_enc : b Data_encoding.t)) ?pp3
(f3_name, (f3_enc : c Data_encoding.t)) ?pp4
(f4_name, (f4_enc : d Data_encoding.t)) ?pp5
(f5_name, (f5_enc : e Data_encoding.t)) =
let section = make_section section in
let parsed_msg =
parse_msg [f1_name; f2_name; f3_name; f4_name; f5_name] msg
in
let module Definition : EVENT_DEFINITION with type t = a * b * c * d * e =
struct
type t = a * b * c * d * e
let doc = msg
let section = section
let name = name
let pp ~all_fields ~block fmt (f1, f2, f3, f4, f5) =
pp_log_message
~all_fields
~block
parsed_msg
fmt
[
Parameter (f1_name, f1_enc, f1, pp1);
Parameter (f2_name, f2_enc, f2, pp2);
Parameter (f3_name, f3_enc, f3, pp3);
Parameter (f4_name, f4_enc, f4, pp4);
Parameter (f5_name, f5_enc, f5, pp5);
]
let encoding =
with_version ~name
@@ Data_encoding.obj5
(Data_encoding.req f1_name f1_enc)
(Data_encoding.req f2_name f2_enc)
(Data_encoding.req f3_name f3_enc)
(Data_encoding.req f4_name f4_enc)
(Data_encoding.req f5_name f5_enc)
let level = level
end in
let module Event = Make (Definition) in
{name; emit = (fun parameters -> Event.emit ?section parameters)}
let declare_6 (type a b c d e f) ?section ~name ~msg ?(level = Info) ?pp1
(f1_name, (f1_enc : a Data_encoding.t)) ?pp2
(f2_name, (f2_enc : b Data_encoding.t)) ?pp3
(f3_name, (f3_enc : c Data_encoding.t)) ?pp4
(f4_name, (f4_enc : d Data_encoding.t)) ?pp5
(f5_name, (f5_enc : e Data_encoding.t)) ?pp6
(f6_name, (f6_enc : f Data_encoding.t)) =
let section = make_section section in
let parsed_msg =
parse_msg [f1_name; f2_name; f3_name; f4_name; f5_name; f6_name] msg
in
let module Definition :
EVENT_DEFINITION with type t = a * b * c * d * e * f = struct
type t = a * b * c * d * e * f
let doc = msg
let section = section
let name = name
let pp ~all_fields ~block fmt (f1, f2, f3, f4, f5, f6) =
pp_log_message
~all_fields
~block
parsed_msg
fmt
[
Parameter (f1_name, f1_enc, f1, pp1);
Parameter (f2_name, f2_enc, f2, pp2);
Parameter (f3_name, f3_enc, f3, pp3);
Parameter (f4_name, f4_enc, f4, pp4);
Parameter (f5_name, f5_enc, f5, pp5);
Parameter (f6_name, f6_enc, f6, pp6);
]
let encoding =
with_version ~name
@@ Data_encoding.obj6
(Data_encoding.req f1_name f1_enc)
(Data_encoding.req f2_name f2_enc)
(Data_encoding.req f3_name f3_enc)
(Data_encoding.req f4_name f4_enc)
(Data_encoding.req f5_name f5_enc)
(Data_encoding.req f6_name f6_enc)
let level = level
end in
let module Event = Make (Definition) in
{name; emit = (fun parameters -> Event.emit ?section parameters)}
let declare_7 (type a b c d e f g) ?section ~name ~msg ?(level = Info) ?pp1
(f1_name, (f1_enc : a Data_encoding.t)) ?pp2
(f2_name, (f2_enc : b Data_encoding.t)) ?pp3
(f3_name, (f3_enc : c Data_encoding.t)) ?pp4
(f4_name, (f4_enc : d Data_encoding.t)) ?pp5
(f5_name, (f5_enc : e Data_encoding.t)) ?pp6
(f6_name, (f6_enc : f Data_encoding.t)) ?pp7
(f7_name, (f7_enc : g Data_encoding.t)) =
let section = make_section section in
let parsed_msg =
parse_msg
[f1_name; f2_name; f3_name; f4_name; f5_name; f6_name; f7_name]
msg
in
let module Definition :
EVENT_DEFINITION with type t = a * b * c * d * e * f * g = struct
type t = a * b * c * d * e * f * g
let doc = msg
let section = section
let name = name
let pp ~all_fields ~block fmt (f1, f2, f3, f4, f5, f6, f7) =
pp_log_message
~all_fields
~block
parsed_msg
fmt
[
Parameter (f1_name, f1_enc, f1, pp1);
Parameter (f2_name, f2_enc, f2, pp2);
Parameter (f3_name, f3_enc, f3, pp3);
Parameter (f4_name, f4_enc, f4, pp4);
Parameter (f5_name, f5_enc, f5, pp5);
Parameter (f6_name, f6_enc, f6, pp6);
Parameter (f7_name, f7_enc, f7, pp7);
]
let encoding =
with_version ~name
@@ Data_encoding.obj7
(Data_encoding.req f1_name f1_enc)
(Data_encoding.req f2_name f2_enc)
(Data_encoding.req f3_name f3_enc)
(Data_encoding.req f4_name f4_enc)
(Data_encoding.req f5_name f5_enc)
(Data_encoding.req f6_name f6_enc)
(Data_encoding.req f7_name f7_enc)
let level = level
end in
let module Event = Make (Definition) in
{name; emit = (fun parameters -> Event.emit ?section parameters)}
let declare_8 (type a b c d e f g h) ?section ~name ~msg ?(level = Info) ?pp1
(f1_name, (f1_enc : a Data_encoding.t)) ?pp2
(f2_name, (f2_enc : b Data_encoding.t)) ?pp3
(f3_name, (f3_enc : c Data_encoding.t)) ?pp4
(f4_name, (f4_enc : d Data_encoding.t)) ?pp5
(f5_name, (f5_enc : e Data_encoding.t)) ?pp6
(f6_name, (f6_enc : f Data_encoding.t)) ?pp7
(f7_name, (f7_enc : g Data_encoding.t)) ?pp8
(f8_name, (f8_enc : h Data_encoding.t)) =
let section = make_section section in
let parsed_msg =
parse_msg
[f1_name; f2_name; f3_name; f4_name; f5_name; f6_name; f7_name; f8_name]
msg
in
let module Definition :
EVENT_DEFINITION with type t = a * b * c * d * e * f * g * h = struct
type t = a * b * c * d * e * f * g * h
let doc = msg
let section = section
let name = name
let pp ~all_fields ~block fmt (f1, f2, f3, f4, f5, f6, f7, f8) =
pp_log_message
~all_fields
~block
parsed_msg
fmt
[
Parameter (f1_name, f1_enc, f1, pp1);
Parameter (f2_name, f2_enc, f2, pp2);
Parameter (f3_name, f3_enc, f3, pp3);
Parameter (f4_name, f4_enc, f4, pp4);
Parameter (f5_name, f5_enc, f5, pp5);
Parameter (f6_name, f6_enc, f6, pp6);
Parameter (f7_name, f7_enc, f7, pp7);
Parameter (f8_name, f8_enc, f8, pp8);
]
let encoding =
with_version ~name
@@ Data_encoding.obj8
(Data_encoding.req f1_name f1_enc)
(Data_encoding.req f2_name f2_enc)
(Data_encoding.req f3_name f3_enc)
(Data_encoding.req f4_name f4_enc)
(Data_encoding.req f5_name f5_enc)
(Data_encoding.req f6_name f6_enc)
(Data_encoding.req f7_name f7_enc)
(Data_encoding.req f8_name f8_enc)
let level = level
end in
let module Event = Make (Definition) in
{name; emit = (fun parameters -> Event.emit ?section parameters)}
end
module Lwt_worker_logger = struct
module Started_event = Make (struct
type t = unit
let section = None
let name = "lwt-worker_started"
let encoding = Data_encoding.constant "started"
let pp ~all_fields:_ ~block:_ ppf () = Format.fprintf ppf "started"
let doc = "Worker started event"
let level = Debug
end)
module Ended_event = Make (struct
type t = unit
let section = None
let name = "lwt-worker_ended"
let encoding = Data_encoding.constant "ended"
let pp ~all_fields:_ ~block:_ ppf () = Format.fprintf ppf "ended"
let doc = "Worker ended event"
let level = Debug
end)
module Failed_event = Make (struct
type t = string
let section = None
let name = "lwt-worker_failed"
let encoding = Data_encoding.(obj1 (req "error" string))
let pp ~all_fields:_ ~block:_ ppf error =
Format.fprintf ppf "failed with %s" error
let doc = "Worker failed event"
let level = Error
end)
let on_event name event =
let open Lwt_syntax in
let section = Section.make_sanitized ["lwt-worker"; name] in
let* r =
match event with
| `Started -> Started_event.emit ~section ()
| `Ended -> Ended_event.emit ~section ()
| `Failed msg -> Failed_event.emit ~section msg
in
match r with
| Ok () -> Lwt.return_unit
| Error errs ->
Format.kasprintf
!default_error_fallback_logger
"failed to log worker event:@ %a@\n"
Error_monad.pp_print_trace
errs
end
Computing file changes ...