WIP: revert some logging changes which might have caused stack overflow

scripts/licenses.ml

@@ -785,7 +785,7 @@ All rights reserved.
     link = "https://github.com/mirage/mirage-protocols/blob/37aa4a86f9f423bb7fe1d70c8a71331060a45048/LICENSE.md";
     text = isc;
   }
-  | "psq.0.2.0" -> {
+  | "psq.0.2.0" | "psq.0.2.1" -> {
     link = "https://github.com/pqwy/psq/blob/beeaf9396655d195f9a20243102c9773d826d3b0/LICENSE.md";
     text = {|
     Copyright (c) 2016 David Kaloper Meršinjak
@@ -1003,7 +1003,7 @@ might be covered by the GNU Lesser General Public License.
 
     |} ^ mit
   }
-  | "lru.0.3.0" -> {
+  | "lru.0.3.0" | "lru.0.3.1" -> {
     link = "https://github.com/pqwy/lru/blob/3a0b5f9effa86f6615501a648069b9a12c5096e5/LICENSE.md";
     text = {|
     Copyright (c) 2016 David Kaloper Meršinjak

src/bin/logging.ml

@@ -5,95 +5,28 @@
     let s = Unix.gettimeofday () in
     let tm = Unix.gmtime s in
     let nsecs = Float.rem s Float.one *. 1e9 |> int_of_float in
-    Fmt.pf f "%04d-%02d-%02dT%02d:%02d:%02d.%09dZ" (tm.tm_year + 1900) (tm.tm_mon + 1)
+    Fmt.pf f "time=\"%04d-%02d-%02dT%02d:%02d:%02d.%09dZ\"" (tm.tm_year + 1900) (tm.tm_mon + 1)
       tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec nsecs
 
-let process = Filename.basename Sys.argv.(0)
-
-let with_lock m f x =
-  Mutex.lock m;
-  try
-    let result = f x in
-    Mutex.unlock m;
-    result
-  with e ->
-    Mutex.unlock m;
-    raise e
-
-let buffer = Buffer.create 128
-let m = Mutex.create ()
-let c = Condition.create ()
-let shutdown_requested = ref false
-let shutdown_done = ref false
-
-let shutdown () =
-  with_lock m
-    (fun () ->
-      shutdown_requested := true;
-      Buffer.add_string buffer "logging system has shutdown";
-      Condition.broadcast c;
-      while not !shutdown_done do
-        Condition.wait c m;
-      done
-    ) ()
-
 let reporter =
-  let max_buffer_size = 65536 in
-  let dropped_bytes = ref 0 in
-  let (_: Thread.t) = Thread.create (fun () ->
-    let rec next () = match Buffer.contents buffer with
-      | "" ->
-        Condition.wait c m;
-        next ()
-      | data ->
-        let dropped = !dropped_bytes in
-        dropped_bytes := 0;
-        Buffer.reset buffer;
-        data, dropped in
-    let should_continue () = match Buffer.contents buffer with
-      | "" ->
-        if !shutdown_requested then begin
-          shutdown_done := true;
-          Condition.broadcast c;
-        end;
-        not !shutdown_done
-      | _ -> true (* more logs to print *) in
-    let rec loop () =
-      let data, dropped = with_lock m next () in
-      (* Block writing to stderr without the buffer mutex held. Logging may continue into the buffer. *)
-      output_string stderr data;
-      if dropped > 0 then begin
-        output_string stderr (Printf.sprintf "%d bytes of logs dropped\n" dropped)
-      end;
-      flush stderr;
-      if with_lock m should_continue () then loop () in
-    loop ()
-  ) () in
-  let buffer_fmt = Format.formatter_of_buffer buffer in
-
-
   let report src level ~over k msgf =
     let k _ =
-      Condition.broadcast c;
       over ();
       k ()
     in
     let src = Logs.Src.name src in
-    msgf @@ fun ?header:_ ?tags:_ fmt ->
+    let with_stamp _h _tags k fmt =
       let level = Logs.level_to_string (Some level) in
-      with_lock m
-        (fun () ->
-          let destination =
-            if Buffer.length buffer > max_buffer_size then begin
-              Format.make_formatter (fun _ _ _ -> ()) (fun () -> ())
-            end else buffer_fmt in
-          Format.kfprintf k destination
-            ("[%a][%a][%a] %a: " ^^ fmt ^^ "@.")
-            pp_ptime ()
-            Fmt.string process
-            Fmt.string level
-            Fmt.string src
-        ) ()
+
+      Fmt.kpf k Fmt.stderr
+        ("\r%a level=%a @[msg=\"%a: " ^^ fmt ^^ "\"@]@.")
+        pp_ptime ()
+        Fmt.string level
+        Fmt.string src
+
+    in
+    msgf @@ fun ?header ?tags fmt ->
+    with_stamp header tags k fmt
   in
   { Logs.report }
 

src/hostnet/hostnet_dns.ml

@@ -85,12 +85,12 @@ module Policy(Files: Sig.FILES) = struct
             Files.read_file resolv_conf
             >>= function
             | Error (`Msg m) ->
-              Log.info (fun f -> f "reading %s: %s" resolv_conf m);
+              Log.warn (fun f -> f "reading %s: %s" resolv_conf m);
               Lwt.return_unit
             | Ok txt ->
               begin match Dns_forward.Config.Unix.of_resolv_conf txt with
               | Error (`Msg m) ->
-                Log.err (fun f -> f "parsing %s: %s" resolv_conf m);
+                Log.warn (fun f -> f "parsing %s: %s" resolv_conf m);
                 Lwt.return_unit
               | Ok servers ->
                 add ~priority:2 ~config:(`Upstream servers);

src/hostnet/hostnet_http.ml

@@ -219,7 +219,7 @@ module Make
     with e ->
       Lwt.return (Error (`Msg (Printf.sprintf "parsing json: %s" (Printexc.to_string e))))
 
-  let to_string t = Ezjsonm.to_string ~minify:true @@ to_json t
+  let to_string t = Ezjsonm.to_string ~minify:false @@ to_json t
 
   let create ?http ?https ?exclude ?(transparent_http_ports=[ 80 ]) ?(transparent_https_ports=[ 443 ]) ?(allow_enabled=false) ?(allow=[]) ?(allow_error_msg = default_error_msg) () =
     let http = match http with None -> None | Some x -> proxy_of_string x in

src/hostnet/slirp.ml

@@ -1,7 +1,7 @@
 open Lwt.Infix
 
 let src =
-  let src = Logs.Src.create "slirp" ~doc:"Mirage TCP/IP <-> socket proxy" in
+  let src = Logs.Src.create "usernet" ~doc:"Mirage TCP/IP <-> socket proxy" in
   Logs.Src.set_level src (Some Logs.Info);
   src