diff --git a/dune-project b/dune-project index 163a239d..5bd4e1f1 100644 --- a/dune-project +++ b/dune-project @@ -41,5 +41,6 @@ jsont cohttp ptime + logs (ocamlformat :with-dev-setup) )) diff --git a/mte.opam b/mte.opam index 1c4d5904..8bdbc121 100644 --- a/mte.opam +++ b/mte.opam @@ -28,6 +28,7 @@ depends: [ "jsont" "cohttp" "ptime" + "logs" "ocamlformat" {with-dev-setup} "odoc" {with-doc} ] diff --git a/src/dune b/src/dune index fb09a728..2a1a266a 100644 --- a/src/dune +++ b/src/dune @@ -24,7 +24,11 @@ fmt jsont cohttp - ptime)) + ptime + logs + logs.fmt + logs.threaded + fmt.tty)) (library ; crockford base32 (name b32) diff --git a/src/mte.ml b/src/mte.ml index b7b46b8a..7870e038 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -116,10 +116,11 @@ let routes = ] let () = + Util.Log_reporter.setup (); let cfg = let port = Config.Exchange.port in let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, port)) in - Vif.config sockaddr + Vif.config ~reporter:Logs.nop_reporter sockaddr in Miou_unix.run @@ fun () -> Caqti_miou.Switch.run @@ fun caqti_switch -> @@ -131,4 +132,6 @@ let () = [ Devices.db_connection; Devices.secmod_signkey; Devices.secmod_denom ] in let middlewares = Vif.Middlewares.[] in + Logs.info (fun m -> + m ~tags:(Util.Log_reporter.detail "~~!") "Starting MTE server"); Vif.run ~cfg ~devices ~middlewares routes env diff --git a/src/util.ml b/src/util.ml index 8d5d1f8b..785958c9 100644 --- a/src/util.ml +++ b/src/util.ml @@ -114,3 +114,59 @@ module Bin_rsa = struct | Error (`Msg e) -> Fmt.failwith "rsa priv_of_octets failure: %s@." e | Ok v -> v end + +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 log_level_color = 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 = fst v |> log_level_color 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 = 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 () = + Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true (); + Logs.set_reporter reporter; + Logs.set_level ~all:false (Some Logs.Debug); + Logs.Src.set_level Logs.default (Some Logs.Debug); + Logs_threaded.enable (); + Printexc.record_backtrace true; + () +end