Logs: get rid of more Lwt

cohttp-lwt-unix/bin/cohttp_curl_lwt.ml

@@ -18,27 +18,27 @@
 open Lwt
 open Cohttp
 open Cohttp_lwt_unix
-module D = Cohttp_lwt_unix.Debug
 
-let debug f = if D.debug_active () then Logs_lwt.debug f else return ()
+let src = Logs.Src.create "cohttp.lwt.curl" ~doc:"Cohttp Lwt curl implementation"
+module Log = (val Logs.src_log src : Logs.LOG)
 
 let client uri ofile meth' =
-  debug (fun d -> d "Client with URI %s" (Uri.to_string uri)) >>= fun () ->
+  Log.debug (fun d -> d "Client with URI %s" (Uri.to_string uri));
   let meth = Cohttp.Code.method_of_string meth' in
-  debug (fun d -> d "Client %s issued" meth') >>= fun () ->
+  Log.debug (fun d -> d "Client %s issued" meth');
   Client.call meth uri >>= fun (resp, body) ->
   let status = Response.status resp in
-  debug (fun d ->
+  Log.debug (fun d ->
     d "Client %s returned: %s" meth' (Code.string_of_status status)
-  ) >>= fun () ->
+  );
   (* TODO follow redirects *)
   match Code.is_success (Code.code_of_status status) with
   | false ->
     prerr_endline (Code.string_of_status status);
     exit 1
   | true ->
     Cohttp_lwt.Body.length body >>= fun (len, body) ->
-    debug (fun d -> d "Client body length: %Ld" len) >>= fun () ->
+    Log.debug (fun d -> d "Client body length: %Ld" len);
     Cohttp_lwt.Body.to_string body >>= fun _s ->
     let output_body c =
       Lwt_stream.iter_s (Lwt_io.fprint c) (Cohttp_lwt.Body.to_stream body) in
@@ -50,8 +50,10 @@ let run_client verbose ofile uri meth =
   Lwt_main.run (
     (if verbose
     then (
+      (* activate debug sets the reporter *)
       Cohttp_lwt_unix.Debug.activate_debug ();
-      debug (fun d -> d ">>> Debug active") >>= fun () -> return ())
+      Log.debug (fun d -> d ">>> Debug active");
+      return ())
     else return ())
     >>= fun () ->
     client uri ofile meth

cohttp-lwt-unix/bin/cohttp_server_lwt.ml

@@ -21,7 +21,9 @@ open Cohttp_lwt_unix
 
 open Cohttp_server
 
-let log_src = Logs.Src.create "cohttp-lwt-unix.bin.server"
+let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server"
+module Log = (val Logs.src_log src : Logs.LOG)
+
 
 let method_filter meth (res,body) = match meth with
   | `HEAD -> Lwt.return (res,`Empty)
@@ -83,11 +85,11 @@ let handler ~info ~docroot ~index (ch,_conn) req _body =
   let uri = Cohttp.Request.uri req in
   let path = Uri.path uri in
   (* Log the request to the console *)
-  Logs_lwt.debug ~src:log_src (fun m -> m
+  Log.debug (fun m -> m
     "%s %s %s"
     (Cohttp.(Code.string_of_method (Request.meth req)))
     path
-    (Sexplib.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))) >>= fun () ->
+    (Sexplib.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch)));
   (* Get a canonical filename from the URL and docroot *)
   match Request.meth req with
   | (`GET | `HEAD) as meth ->
@@ -101,10 +103,10 @@ let handler ~info ~docroot ~index (ch,_conn) req _body =
       ~body:(html_of_method_not_allowed meth (String.concat "," allowed) path info) ()
 
 let start_server docroot port host index tls () =
-  Logs_lwt.info (fun m -> m "Listening for HTTP request on: %s %d" host port) >>= fun () ->
+  Log.info (fun m -> m "Listening for HTTP request on: %s %d" host port);
   let info = Printf.sprintf "Served by Cohttp/Lwt listening on %s:%d" host port in
   let conn_closed (ch,_conn) =
-    Logs.debug ~src:log_src (fun m -> m "connection %s closed"
+    Log.debug (fun m -> m "connection %s closed"
       (Sexplib.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch))) in
   let callback = handler ~info ~docroot ~index in
   let config = Server.make ~callback ~conn_closed () in
@@ -117,33 +119,12 @@ let start_server docroot port host index tls () =
   let ctx = Cohttp_lwt_unix.Net.init ~ctx () in
   Server.create ~ctx ~mode config
 
-(* The example of Lwt-aware reporter in Logs' documentation *)
-let lwt_reporter () =
-  let buf_fmt ~like =
-    let b = Buffer.create 512 in
-    Fmt.with_buffer ~like b,
-    fun () -> let m = Buffer.contents b in Buffer.reset b; m
-  in
-  let app, app_flush = buf_fmt ~like:Fmt.stdout in
-  let dst, dst_flush = buf_fmt ~like:Fmt.stderr in
-  let reporter = Logs_fmt.reporter ~app ~dst () in
-  let report src level ~over k msgf =
-    let k () =
-      let write () = match level with
-      | Logs.App -> Lwt_io.write Lwt_io.stdout (app_flush ())
-      | _ -> Lwt_io.write Lwt_io.stderr (dst_flush ())
-      in
-      let unblock () = over (); Lwt.return_unit in
-      Lwt.finalize write unblock |> Lwt.ignore_result;
-      k ()
-    in
-    reporter.Logs.report src level ~over:(fun () -> ()) k msgf;
-  in
-  { Logs.report = report }
-
 let lwt_start_server docroot port host index verbose tls =
-  Logs.set_level verbose;
-  Logs.set_reporter (lwt_reporter ());
+  if verbose <> None then begin
+    (* activate_debug sets the reporter *)
+    Cohttp_lwt_unix.Debug.activate_debug ();
+    Logs.set_level verbose
+  end;
   Lwt_main.run (start_server docroot port host index tls ())
 
 

cohttp-lwt-unix/src/debug.ml

@@ -18,6 +18,8 @@ let _debug_active = ref false
 let debug_active () = !_debug_active
 
 let default_reporter () =
+  (* Note: we want the logging operation to not block the other operation.
+   * Hence, the reporter creates Lwt promises. *)
   let fmtr, fmtr_flush =
     let b = Buffer.create 512 in
     ( Fmt.with_buffer ~like:Fmt.stdout b
@@ -27,8 +29,8 @@ let default_reporter () =
   let report _src _level ~over k msgf =
     let k _ =
       let write () = Lwt_io.write Lwt_io.stderr (fmtr_flush ()) in
-      let unblock () = over (); Lwt.return_unit in
-      Lwt.finalize write unblock |> Lwt.ignore_result;
+      let unblock () = over (); Lwt.return () in
+      Lwt.ignore_result (Lwt.finalize write unblock : unit Lwt.t);
       k ()
     in
     msgf @@ fun ?header:_ ?tags:_ fmt ->

cohttp-lwt-unix/src/debug.mli

@@ -16,7 +16,6 @@
 
 (** Debugging output for Cohttp Unix *)
 
-
 val activate_debug : unit -> unit
 (** [activate_debug] enables debugging output that will be sent to
     standard error. *)

cohttp-lwt-unix/src/io.ml

@@ -14,7 +14,6 @@
  *
   }}}*)
 
-module CD = Debug
 let () =
   if Sys.os_type <> "Win32" then
     Sys.(set_signal sigpipe Signal_ignore);
@@ -27,39 +26,27 @@ type ic = Lwt_io.input_channel
 type oc = Lwt_io.output_channel
 type conn = Conduit_lwt_unix.flow
 
-let src = Logs.Src.create "cohttp.lwt" ~doc:"Cohttp Lwt IO module"
-module Log = (val Logs_lwt.src_log src : Logs_lwt.LOG)
+let src = Logs.Src.create "cohttp.lwt.io" ~doc:"Cohttp Lwt IO module"
+module Log = (val Logs.src_log src : Logs.LOG)
 
 let read_line ic =
-  if CD.debug_active () then
-    Lwt_io.read_line_opt ic >>= function
-    | None ->
-      Log.debug (fun f -> f  "<<< EOF")
-      >>= fun () ->  Lwt.return_none
-    | Some l as x ->
-      Log.debug (fun f -> f  "<<< %s" l)
-      >>= fun () ->  Lwt.return x
-  else
-    Lwt_io.read_line_opt ic
+  Lwt_io.read_line_opt ic >>= function
+  | None ->
+    Log.debug (fun f -> f  "<<< EOF");
+    Lwt.return_none
+  | Some l as x ->
+    Log.debug (fun f -> f  "<<< %s" l);
+    Lwt.return x
 
 let read ic count =
   let count = min count Sys.max_string_length in
-  if CD.debug_active () then
-    Lwt_io.read ~count ic
-    >>= fun buf ->
-    Log.debug (fun f -> f  "<<<[%d] %s" count buf)
-    >>= fun () -> return buf
-  else
-    Lwt_io.read ~count ic
+  Lwt_io.read ~count ic >>= fun buf ->
+  Log.debug (fun f -> f  "<<<[%d] %s" count buf);
+  Lwt.return buf
 
 let write oc buf =
-  if CD.debug_active () then (
-    Log.debug (fun f -> f  ">>> %s" (String.trim buf)) >>= fun () ->
-    Lwt_io.write oc buf
-  )
-  else (
-    ( Lwt_io.write oc buf )
-  )
+  Log.debug (fun f -> f  ">>> %s" (String.trim buf));
+  Lwt_io.write oc buf
 
 let flush oc =
   Lwt_io.flush oc

cohttp-lwt-unix/src/server.ml

@@ -4,7 +4,8 @@ module Server_core = Cohttp_lwt.Make_server (Io)
 include Server_core
 open Lwt
 
-let log_src = Logs.Src.create "cohttp-lwt-unix.server"
+let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server module"
+module Log = (val Logs.src_log src : Logs.LOG)
 
 let blank_uri = Uri.of_string ""
 
@@ -33,7 +34,7 @@ let respond_file ?headers ~fname () =
               | "" -> None
               | buf -> Some buf)
             (fun exn ->
-               Logs.debug ~src:log_src
+               Log.debug
                  (fun m -> m "Error resolving file %s (%s)"
                    fname
                    (Printexc.to_string exn));

cohttp-lwt-unix/test/test_sanity.ml

@@ -12,6 +12,9 @@ let chunk_body = ["one"; ""; " "; "bar"; ""]
 
 let leak_repeat = 1024
 
+let () = Debug.activate_debug ()
+let () = Logs.set_level (Some Info)
+
 let server =
   [ (* t *)
     Server.respond_string ~status:`OK ~body:message ();
@@ -97,12 +100,12 @@ let ts =
       Client.callv uri reqs >>= fun resps ->
       let resps = Lwt_stream.map_s (fun (_, b) -> Body.to_string b) resps in
       Lwt_stream.fold (fun b i ->
-          Lwt_log.ign_info_f "Request %i\n" i;
+          Logs.info (fun f -> f "Request %i\n" i);
           begin match i with
             | 0 -> assert_equal b "one"
             | 1 ->
               assert_equal b "two";
-              Lwt_log.ign_info "Sending extra request";
+              Logs.info (fun f -> f "Sending extra request");
               push (Some (r 3))
             | 2 ->
               assert_equal b "three";

cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml

@@ -13,6 +13,9 @@ let const = Cohttp_test.const
 
 let response_sequence = Cohttp_test.response_sequence Lwt.fail_with
 
+let () = Debug.activate_debug ()
+let () = Logs.set_level (Some Info)
+
 let temp_server ?port spec callback =
   let port = match port with
     | None -> Cohttp_test.next_port ()
@@ -32,12 +35,12 @@ let temp_server ?port spec callback =
 
 let test_server_s ?port ?(name="Cohttp Server Test") spec f =
   temp_server ?port spec begin fun uri ->
-    Lwt_log.ign_info_f "Test %s running on %s" name (Uri.to_string uri);
+    Logs.info (fun f -> f "Test %s running on %s" name (Uri.to_string uri));
     let tests = f uri in
     let results =
       tests
       |> Lwt_list.map_s (fun (name, test) ->
-        Lwt_log.ign_debug_f "Running %s" name;
+        Logs.info (fun f -> f "Running %s" name);
         let res = Lwt.try_bind test
                     (fun () -> return `Ok)
                     (fun exn -> return (`Exn exn)) in