Source file 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
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 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 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 TzString.Set.empty

let get_registered_sections () = !registered_sections

let register_section section =
  registered_sections :=
    TzString.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 =
    match Uri.scheme uri with
    | None -> fail (Activation_error (Missing_uri_scheme (Uri.to_string uri)))
    | Some scheme_to_activate ->
        let activate (type a) scheme definition =
          let module S = (val definition : SINK with type t = a) in
          S.configure uri >>=? fun sink ->
          return (Active {scheme; configuration = uri; definition; sink})
        in
        (match find_registered scheme_to_activate with
        | Some (Registered {scheme; definition}) -> activate scheme definition
        | None ->
            fail
              (Activation_error (Uri_scheme_not_registered (Uri.to_string uri))))
        >>=? fun act ->
        active := act :: !active ;
        return_unit

  let close () =
    let close_one (type a) sink definition =
      let module S = (val definition : SINK with type t = a) in
      S.close sink
    in
    List.iter_es
      (fun (Active {sink; definition; _}) -> close_one sink definition)
      !active

  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 [>>=?]
               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_error
              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_utils.dont_wait
      (fun exc -> raise exc) (* emit never lets exceptions escape *)
      (fun () -> emit simple_event parameters)

  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.unsafe_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
        match TzList.index_of variable_name variable_names with
        | None ->
            invalid_msg
              (Printf.sprintf "unbound variable: %S" variable_name)
              msg
        | Some index ->
            let acc = Variable index :: acc in
            let i = i + 1 in
            find_variable_begin acc i i
      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 := TzString.Set.add P.name !registered_sections

    module Event = Make (Definition)

    let emit_async level fmt ?tags =
      (* Prevent massive calls to kasprintf *)
      let log_section = Section.to_lwt_log section in
      if should_log ~level ~sink_level:(Lwt_log_core.Section.level log_section)
      then
        Format.kasprintf
          (fun message ->
            Lwt.ignore_result
              (Event.emit ~section (fun () ->
                   Definition.make ?tags level message)))
          fmt
      else Format.ifprintf Format.std_formatter fmt

    let emit_lwt level fmt ?tags =
      (* Prevent massive calls to kasprintf *)
      let log_section = Section.to_lwt_log section in
      if should_log ~level ~sink_level:(Lwt_log_core.Section.level log_section)
      then
        Format.kasprintf
          (fun message ->
            Event.emit ~section (fun () -> Definition.make ?tags level message)
            >>= function
            | Ok () -> Lwt.return_unit
            | Error el -> Format.kasprintf Lwt.fail_with "%a" pp_print_error el)
          fmt
      else Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter 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 =
    f () >>= function
    | Ok () -> Lwt.return_unit
    | Error el -> (
        emit ?section (fun () -> make ?message ?severity el ()) >>= function
        | Ok () -> Lwt.return_unit
        | Error el ->
            Format.kasprintf
              Lwt_log_core.error
              "Error while emitting error logging event !! %a"
              pp_print_error
              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 _ = return_unit

    let handle (type a) () m ?section (v : unit -> a) =
      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
            Format.kasprintf
              (Lwt_log_core.log ~section ~level)
              "%a"
              (M.pp ~short:false)
              ev
            >>= fun () -> return_unit
          else return_unit)

    let close _ =
      Lwt_log_core.close !Lwt_log_core.default >>= fun () -> return_unit
  end

  include Sink

  let () = All_sinks.register (module Sink)
end