60 lines
2 KiB
OCaml
60 lines
2 KiB
OCaml
module Log_reporter = struct
|
|
let detail_tag : string Logs.Tag.def =
|
|
Logs.Tag.def "Detail tag" ~doc:"" Fmt.string
|
|
|
|
let detail s = Logs.Tag.(empty |> add detail_tag s)
|
|
let time_anchor = Ptime_clock.now () |> Ptime.to_span
|
|
|
|
let color_of_log_level = function
|
|
| Logs.App -> `White
|
|
| Error -> `Red
|
|
| Warning -> `Yellow
|
|
| Info -> `Blue
|
|
| Debug -> `Magenta
|
|
|
|
let reporter : Logs.reporter =
|
|
let open Fmt in
|
|
let pp_timestamp = styled `Faint (styled (`Fg `White) (fmt "%04.02f")) in
|
|
let pp_header ppf v =
|
|
let color = color_of_log_level (fst v) in
|
|
let pp = styled (`Fg color) Logs.pp_header in
|
|
pf ppf "%a" pp v
|
|
in
|
|
let pp_src_name =
|
|
let pp = using Logs.Src.name (styled `Cyan (fmt "%s: ")) in
|
|
fun ppf v -> if not @@ Logs.Src.equal Logs.default v then pp ppf v
|
|
in
|
|
let pp_detail = option (styled `Green (fmt " (%s)")) in
|
|
let report src lvl ~over k msgf =
|
|
let ppf =
|
|
match lvl with
|
|
| Logs.App -> stdout
|
|
| Error | Warning | Info | Debug -> stderr
|
|
in
|
|
let k _ppf = over (); k () in
|
|
let with_detail h tags k user_fmt =
|
|
let detail = Option.bind tags (Logs.Tag.find detail_tag) in
|
|
let timestamp =
|
|
Ptime.sub_span (Ptime_clock.now ()) time_anchor
|
|
|> Option.map Ptime.to_float_s
|
|
|> Option.value ~default:0.
|
|
in
|
|
let k ppf = kpf k ppf "%a@." pp_detail detail in
|
|
let k ppf = kpf k ppf user_fmt in
|
|
kpf k ppf "%a %a %a" pp_timestamp timestamp pp_header (lvl, h)
|
|
pp_src_name src
|
|
in
|
|
msgf @@ fun ?header ?tags fmt -> with_detail header tags k fmt
|
|
in
|
|
{ report }
|
|
|
|
let setup () =
|
|
(*Logs.Src.set_level Secmod_rsa.src (Some Logs.Debug);*)
|
|
let level = Some Logs.Info in
|
|
Logs.set_level ~all:false level;
|
|
Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ();
|
|
Logs.Src.set_level Logs.default level;
|
|
Logs_threaded.enable ();
|
|
Logs.set_reporter reporter;
|
|
()
|
|
end
|