log reporter style renderer

src/log_reporter.ml

@@ -1,69 +1,60 @@
-let detail_tag : string Logs.Tag.def =
-  Logs.Tag.def "Detail tag" ~doc:"" Fmt.string
+let pp_timestamp = Fmt.fmt "%09.04f"
 
-let detail s = Logs.Tag.(empty |> add detail_tag s)
-let time_anchor = Mirage_ptime.now () |> Ptime.to_span
+let pp_header ppf (lvl, h) =
+  match h with
+  | Some h -> Fmt.pf ppf "[%s]" h
+  | None -> (
+      match lvl with
+      | Logs.App -> ()
+      | Info -> Fmt.pf ppf "[INFO]"
+      | Debug -> Fmt.pf ppf "[DEBUG]"
+      | Warning -> Fmt.pf ppf "[WARNING]"
+      | Error -> Fmt.pf ppf "[ERROR]")
 
-let color_of_log_level = function
+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 "%09.04f")) 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 pp_src_name ppf src =
+  if Logs.Src.equal Logs.default src then ()
+  else Fmt.pf ppf "%s: " (Logs.Src.name src)
+
+let create ~t0 : Logs.reporter =
   let report src lvl ~over k msgf =
+    let pp_timestamp =
+      Fmt.styled `Faint (Fmt.styled (`Fg `White) pp_timestamp)
+    in
+    let pp_header = Fmt.styled (`Fg (log_level_color lvl)) pp_header in
+    let pp_src_name = Fmt.styled `Cyan pp_src_name in
     let ppf =
       match lvl with
-      | Logs.App -> stdout
-      | Error | Warning | Info | Debug -> stderr
+      | Logs.App -> Fmt.stdout
+      | Error | Warning | Info | Debug -> Fmt.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 (Mirage_ptime.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
+    let pp h _tags k user_fmt =
+      let t1 = Mkernel.clock_monotonic () in
+      let dt = Float.of_int (t1 - t0) /. 1_000_000_000. in
+      let k ppf = Fmt.kpf k ppf "@." in
+      let k ppf = Fmt.kpf k ppf user_fmt in
+      Fmt.kpf k ppf "%a %a %a" pp_timestamp dt pp_header (lvl, h) pp_src_name
         src
     in
-    msgf @@ fun ?header ?tags fmt -> with_detail header tags k fmt
+    msgf @@ fun ?header ?tags user_fmt -> pp header tags k user_fmt
   in
   { report }
 
-(*
-let set_level_secmods lvl =
-  let secmod_srcs = [ Secmod_rsa.src; Secmod_eddsa.src ] in
-  List.iter (fun src -> Logs.Src.set_level src lvl) secmod_srcs;
-  ()
-*)
-
-let setup level =
-  (*     set_level_secmods level; *)
-  (*
-  let l = Logs.Src.list () in
-  let l =
-    List.filter (fun src -> Logs.Src.name src = "mnet.happy_eyeballs") l
-  in
-  List.iter (fun src -> Logs.Src.set_level src None) l;
-*)
-  Logs.set_level ~all:false level;
+let setup ~t0 =
+  let reporter = create ~t0 in
+  let style_renderer = `Ansi_tty in
+  let all = false in
+  let level = Some Logs.Info in
+  (* - *)
+  Fmt.set_style_renderer Fmt.stdout style_renderer;
+  Fmt.set_style_renderer Fmt.stderr style_renderer;
+  Logs.set_level ~all level;
   Logs.Src.set_level Logs.default level;
-  Logs.set_reporter reporter;
-  ()
+  Logs.set_reporter reporter

src/mte.ml

@@ -50,11 +50,11 @@ let routes =
 
 module RNG = Mirage_crypto_rng.Fortuna
 
-let log_level = Some Logs.Info
+let t0 = Mkernel.clock_monotonic ()
 
 let () =
   let ( let@ ) finally fn = Fun.protect ~finally fn in
-  Log_reporter.setup log_level;
+  Log_reporter.setup ~t0;
   let rng =
     let rng () = Mirage_crypto_rng_mkernel.initialize (module RNG) in
     Mkernel.map rng Mkernel.[]

src/respond.ml

@@ -1,9 +1,9 @@
 let pp_status ppf status =
   match status with
   | #H2.Status.standard as status ->
-      Fmt.pf ppf "HTTP [%d %s]" (H2.Status.to_code status)
+      Fmt.pf ppf "HTTP status: %d %s" (H2.Status.to_code status)
         (H2.Status.default_reason_phrase status)
-  | _ -> Fmt.pf ppf "HTTP [%d]" (H2.Status.to_code status)
+  | _ -> Fmt.pf ppf "HTTP %d" (H2.Status.to_code status)
 
 let empty status =
   Logs.info (fun m -> m "%a" pp_status status);
@@ -41,10 +41,8 @@ let map_err_status err =
 let error req err =
   let status = map_err_status err in
   let hint = Result.err_to_string err in
-  let log_lvl =
-    if H2.Status.is_server_error status then Logs.Error else Logs.Warning
-  in
-  Logs.msg log_lvl (fun m -> m "%a %s" pp_status status hint);
+  let log = if H2.Status.is_server_error status then Logs.err else Logs.warn in
+  log (fun m -> m "%a %s" pp_status status hint);
   let body = Api.ErrorDetail.make ~hint (-1) in
   respond_json req Api.ErrorDetail.jsont status body