src/mte.ml

@@ -13,60 +13,6 @@
     You should have received a copy of the GNU Affero General Public License
     along with this program.  If not, see <https://www.gnu.org/licenses/>. *)
 
-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 () =
-  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;
-  ()
-
 let error_detail ?hint _status =
   let open Api in
   let code = -1 in
@@ -170,7 +116,7 @@ let routes =
   ]
 
 let () =
-  (*Logs.set_reporter (Logs_fmt.reporter ());*)
+  Util.Log_reporter.setup ();
   let cfg =
     let port = Config.Exchange.port in
     let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, port)) in
@@ -186,5 +132,6 @@ let () =
       [ Devices.db_connection; Devices.secmod_signkey; Devices.secmod_denom ]
   in
   let middlewares = Vif.Middlewares.[] in
-  Logs.info (fun m -> m ~tags:(detail "~~!") "Starting MTE server");
+  Logs.info (fun m ->
+      m ~tags:(Util.Log_reporter.detail "~~!") "Starting MTE server");
   Vif.run ~cfg ~devices ~middlewares routes env

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