Revision 5e19e357b79a1626c3f27e918e50d21e3fe66c74 authored by Diane Gallois-Wong on 03 October 2022, 16:23:32 UTC, committed by Marge Bot on 10 October 2022, 09:36:45 UTC
- Validate: rename application_info to block_finalization_info - Validate: remove unneeded Alpha_context - Apply: update module name Validate_operation -> Validate in a comment - Apply & Contract_storage: use Lwt_tzresult_syntax (notably, fail is now implicitly Error_monad.fail)
1 parent c3a3cf5
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 = Lwt_log_core.level =
| Debug
| Info
| Notice
| Warning
| Error
| Fatal
let should_log ~level ~sink_level =
(* Same criteria as [Lwt_log_core.log] *)
level >= sink_level
module Level = struct
type t = level
let default = Info
let to_lwt_log t = t
let to_string = Lwt_log_core.string_of_level
let of_string = Lwt_log_core.level_of_string
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 : string list -> t
val make_sanitized : string list -> t
val to_lwt_log : t -> Lwt_log_core.section
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; lwt_log_section : Lwt_log_core.section}
include Compare.Make (struct
type nonrec t = t
let compare = Stdlib.compare
end)
let empty = {path = []; lwt_log_section = Lwt_log_core.Section.make ""}
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;
lwt_log_section = Lwt_log_core.Section.make (String.concat "." 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 to_lwt_log s = s.lwt_log_section
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 "%s" (String.concat "." 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
(Lwt_log_core.Section.name (Section.to_lwt_log section))
!registered_sections
module type EVENT_DEFINITION = sig
type t
val section : Section.t option
val name : string
val doc : string
val pp : short:bool -> Format.formatter -> t -> unit
val encoding : t Data_encoding.t
val level : t -> level
end
module type EVENT = sig
include EVENT_DEFINITION
val emit : ?section:Section.t -> (unit -> 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 handle :
t ->
'a event_definition ->
?section:Section.t ->
(unit -> '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 module S = (val definition : SINK with type t = a) in
S.handle ?section sink def v
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 ~short:false 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 (fun fmt ss ->
Format.fprintf
fmt
"%s"
(String.concat "." (Section.to_string_list ss))))
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 =
(* In order to evaluate the event at most once, we wrap it in a
`Lazy.t`: *)
let x = lazy (x ()) in
All_sinks.handle (module E) section (fun () -> Lazy.force 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 = 'a -> unit tzresult Lwt.t
let emit simple_event parameters =
Lwt.try_bind
(fun () -> simple_event 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:@ %a@]@."
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@]@."
(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 ~short (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
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 -> Format.pp_print_space 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 not short then List.iter print_field fields ;
if !first_field then Format.fprintf fmt "@]" else 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 ~short fmt () = pp_log_message ~short parsed_msg fmt []
let encoding = with_version ~name Data_encoding.unit
let level _ = level
end in
let module Event = Make (Definition) in
fun () -> Event.emit ?section (fun () -> ())
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 ~short fmt f1 =
pp_log_message
~short
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
fun parameter -> Event.emit ?section (fun () -> 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 ~short fmt (f1, f2) =
pp_log_message
~short
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
fun parameters -> Event.emit ?section (fun () -> 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 ~short fmt (f1, f2, f3) =
pp_log_message
~short
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
fun parameters -> Event.emit ?section (fun () -> 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 ~short fmt (f1, f2, f3, f4) =
pp_log_message
~short
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
fun parameters -> Event.emit ?section (fun () -> 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 ~short fmt (f1, f2, f3, f4, f5) =
pp_log_message
~short
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
fun parameters -> Event.emit ?section (fun () -> 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 ~short fmt (f1, f2, f3, f4, f5, f6) =
pp_log_message
~short
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
fun parameters -> Event.emit ?section (fun () -> 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 ~short fmt (f1, f2, f3, f4, f5, f6, f7) =
pp_log_message
~short
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
fun parameters -> Event.emit ?section (fun () -> 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 ~short fmt (f1, f2, f3, f4, f5, f6, f7, f8) =
pp_log_message
~short
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
fun parameters -> Event.emit ?section (fun () -> parameters)
end
module Legacy_logging = struct
module type LOG = sig
val debug : ('a, Format.formatter, unit, unit) format4 -> 'a
val log_info : ('a, Format.formatter, unit, unit) format4 -> 'a
val log_notice : ('a, Format.formatter, unit, unit) format4 -> 'a
val warn : ('a, Format.formatter, unit, unit) format4 -> 'a
val log_error : ('a, Format.formatter, unit, unit) format4 -> 'a
val fatal_error : ('a, Format.formatter, unit, unit) format4 -> 'a
val lwt_debug : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
val lwt_log_info : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
val lwt_log_notice : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
val lwt_warn : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
val lwt_log_error : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
val lwt_fatal_error : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
end
open Tezos_stdlib
type ('a, 'b) msgf =
(('a, Format.formatter, unit, 'b) format4 -> ?tags:Tag.set -> 'a) ->
?tags:Tag.set ->
'b
type ('a, 'b) log = ('a, 'b) msgf -> 'b
module type SEMLOG = sig
module Tag = Tag
val debug : ('a, unit) log
val log_info : ('a, unit) log
val log_notice : ('a, unit) log
val warn : ('a, unit) log
val log_error : ('a, unit) log
val fatal_error : ('a, unit) log
val lwt_debug : ('a, unit Lwt.t) log
val lwt_log_info : ('a, unit Lwt.t) log
val lwt_log_notice : ('a, unit Lwt.t) log
val lwt_warn : ('a, unit Lwt.t) log
val lwt_log_error : ('a, unit Lwt.t) log
val lwt_fatal_error : ('a, unit Lwt.t) log
val event : string Tag.def
val exn : exn Tag.def
end
module Make_event (P : sig
val name : string
end) =
struct
let name_split = String.split_on_char '.' P.name
let section = Section.make name_split
module Definition = struct
let name = "legacy_logging_event-" ^ String.concat "-" name_split
type t = {
message : string;
section : Section.t;
level : level;
tags : Tag.set;
}
let make ?(tags = Tag.empty) level message =
{message; section; level; tags}
let v0_encoding =
let open Data_encoding in
conv
(fun {message; section; level; tags} ->
(message, section, level, tags))
(fun (message, section, level, tags) ->
{message; section; level; tags})
(obj4
(req "message" string)
(req "section" Section.encoding)
(req "level" Level.encoding)
(dft
"tags"
(conv
(fun tags -> Format.asprintf "%a" Tag.pp_set tags)
(fun _ -> Tag.empty)
string)
Tag.empty))
let encoding =
Data_encoding.With_version.(encoding ~name (first_version v0_encoding))
let pp ~short:_ ppf {message; _} =
let open Format in
fprintf ppf "%s" message
let doc = "Generic event legacy / string-based information logging."
let level {level; _} = level
let section = Some section
end
let () = registered_sections := String.Set.add P.name !registered_sections
module Event = Make (Definition)
let emit_async level fmt ?tags =
Format.kasprintf
(fun message ->
Lwt.ignore_result
(Event.emit ~section (fun () -> Definition.make ?tags level message)))
fmt
let emit_lwt level fmt ?tags =
let open Lwt_syntax in
Format.kasprintf
(fun message ->
let* r =
Event.emit ~section (fun () -> Definition.make ?tags level message)
in
match r with
| Ok () -> Lwt.return_unit
| Error el -> Format.kasprintf Lwt.fail_with "%a" pp_print_trace el)
fmt
end
module Make (P : sig
val name : string
end) =
struct
include Make_event (P)
let emit_async = emit_async ?tags:None
let debug f = emit_async Debug f
let log_info f = emit_async Info f
let log_notice f = emit_async Notice f
let warn f = emit_async Warning f
let log_error f = emit_async Error f
let fatal_error f = emit_async Fatal f
let emit_lwt = emit_lwt ?tags:None
let lwt_debug f = emit_lwt Debug f
let lwt_log_info f = emit_lwt Info f
let lwt_log_notice f = emit_lwt Notice f
let lwt_warn f = emit_lwt Warning f
let lwt_log_error f = emit_lwt Error f
let lwt_fatal_error f = emit_lwt Fatal f
end
module Make_semantic (P : sig
val name : string
end) =
struct
include Make_event (P)
let debug (f : ('a, unit) msgf) = f (emit_async Debug) ?tags:None
let log_info f = f (emit_async Info) ?tags:None
let log_notice f = f (emit_async Notice) ?tags:None
let warn f = f (emit_async Warning) ?tags:None
let log_error f = f (emit_async Error) ?tags:None
let fatal_error f = f (emit_async Fatal) ?tags:None
let lwt_debug f = f (emit_lwt Debug) ?tags:None
let lwt_log_info f = f (emit_lwt Info) ?tags:None
let lwt_log_notice f = f (emit_lwt Notice) ?tags:None
let lwt_warn f = f (emit_lwt Warning) ?tags:None
let lwt_log_error f = f (emit_lwt Error) ?tags:None
let lwt_fatal_error f = f (emit_lwt Fatal) ?tags:None
module Tag = Tag
let event =
Tag.def
~doc:"String identifier for the class of event being logged"
"event"
Format.pp_print_text
let exn =
Tag.def ~doc:"Exception which was detected" "exception" (fun f e ->
Format.pp_print_text f (Printexc.to_string e))
end
end
module Error_event = struct
type t = {
message : string option;
severity : [`Fatal | `Recoverable];
trace : Error_monad.error list;
}
let make ?message ?(severity = `Recoverable) trace () =
{message; trace; severity}
module Definition = struct
let section = None
let name = "error-event"
type nonrec t = t
let encoding =
let open Data_encoding in
let v0_encoding =
conv
(fun {message; trace; severity} -> (message, severity, trace))
(fun (message, severity, trace) -> {message; severity; trace})
(obj3
(opt "message" string)
(req
"severity"
(string_enum [("fatal", `Fatal); ("recoverable", `Recoverable)]))
(req "trace" (list Error_monad.error_encoding)))
in
With_version.(encoding ~name (first_version v0_encoding))
let pp ~short:_ f x =
Format.fprintf
f
"%s:@ %s"
name
(match x.message with Some x -> x | None -> "")
let doc = "Generic event for any kind of error."
let level {severity; _} =
match severity with `Fatal -> Fatal | `Recoverable -> Error
end
include (Make (Definition) : EVENT with type t := t)
let log_error_and_recover ?section ?message ?severity f =
let open Lwt_syntax in
let* r = f () in
match r with
| Ok () -> Lwt.return_unit
| Error el -> (
let* r = emit ?section (fun () -> make ?message ?severity el ()) in
match r with
| Ok () -> Lwt.return_unit
| Error el ->
Format.kasprintf
Lwt_log_core.error
"Error while emitting error logging event !! %a"
pp_print_trace
el)
end
module Debug_event = struct
type t = {message : string; attachment : Data_encoding.Json.t}
let make ?(attach = `Null) message () = {message; attachment = attach}
let v0_encoding =
let open Data_encoding in
conv
(fun {message; attachment} -> (message, attachment))
(fun (message, attachment) -> {message; attachment})
(obj2 (req "message" string) (req "attachment" json))
module Definition = struct
let section = None
let name = "debug-event"
type nonrec t = t
let encoding =
Data_encoding.With_version.(encoding ~name (first_version v0_encoding))
let pp ~short:_ ppf {message; attachment} =
let open Format in
fprintf ppf "%s:@ %s@ %a" name message Data_encoding.Json.pp attachment
let doc = "Generic event for semi-structured debug information."
let level _ = Debug
end
include (Make (Definition) : EVENT with type t := t)
end
module Lwt_worker_event = struct
type t = {name : string; event : [`Started | `Ended | `Failed of string]}
let v0_encoding =
let open Data_encoding in
conv
(fun {name; event} -> (name, event))
(fun (name, event) -> {name; event})
(obj2
(req "name" string)
(req
"event"
(union
[
case
~title:"started"
(Tag 0)
(obj1 (req "kind" (constant "started")))
(function `Started -> Some () | _ -> None)
(fun () -> `Started);
case
~title:"ended"
(Tag 1)
(obj1 (req "kind" (constant "ended")))
(function `Ended -> Some () | _ -> None)
(fun () -> `Ended);
case
~title:"failed"
(Tag 2)
(obj2
(req "kind" (constant "failed"))
(req "exception" string))
(function `Failed s -> Some ((), s) | _ -> None)
(fun ((), s) -> `Failed s);
])))
module Definition = struct
let section = None
let name = "lwt-worker-event"
type nonrec t = t
let encoding =
Data_encoding.With_version.(encoding ~name (first_version v0_encoding))
let pp ~short:_ ppf {name; event} =
let open Format in
fprintf
ppf
"Worker %s:@ %a"
name
(fun fmt -> function
| `Failed msg -> fprintf ppf "Failed with %s" msg
| `Ended -> fprintf fmt "Ended"
| `Started -> fprintf fmt "Started")
event
let doc = "Generic event for callers of the function Lwt_utils.worker."
let level {event; _} =
match event with `Failed _ -> Error | `Started | `Ended -> Debug
end
include (Make (Definition) : EVENT with type t := t)
let on_event name event =
let section = Section.make_sanitized ["lwt-worker"; name] in
Error_event.log_error_and_recover
~message:(Printf.sprintf "Trying to emit worker event for %S" name)
~severity:`Fatal
(fun () -> emit ~section (fun () -> {name; event}))
let on_event name event =
Lwt.catch
(fun () -> on_event name event)
(fun exc ->
Format.eprintf
"@[<hv 2>Failed to log event:@ %s@]@."
(Printexc.to_string exc) ;
Lwt.return_unit)
end
module Lwt_log_sink = struct
(* let default_template = "$(date) - $(section): $(message)" *)
let default_section = Lwt_log_core.Section.main
module Sink : SINK = struct
type t = unit
let uri_scheme = "lwt-log"
let configure _ = Lwt_result_syntax.return_unit
let handle (type a) () m ?section (v : unit -> a) =
let open Lwt_syntax in
let module M = (val m : EVENT_DEFINITION with type t = a) in
protect (fun () ->
let ev = v () in
let level = M.level ev in
let section =
Option.fold ~some:Section.to_lwt_log section ~none:default_section
in
(* Only call printf if the event is to be printed. *)
if should_log ~level ~sink_level:(Lwt_log_core.Section.level section)
then
let* () =
Format.kasprintf
(Lwt_log_core.log ~section ~level)
"%a"
(M.pp ~short:false)
ev
in
return_ok_unit
else return_ok_unit)
let close _ =
let open Lwt_syntax in
let* () = Lwt_log_core.close !Lwt_log_core.default in
return_ok_unit
end
include Sink
let () = All_sinks.register (module Sink)
end
Computing file changes ...