Revisit logs in cohttp-lwt

CHANGES.md

@@ -1,5 +1,6 @@
 ## current
 
+- lwt, lwt_unix: Improve use of logs and the documentation, fix bug in the Debug.enable_debug function (mseri #772)
 - lwt_jsoo: Fix exception on connection errors in chrome (mefyl #761)
 - lwt_jsoo: Fix `Lwt.wakeup_exn` `Invalid_arg` exception when a js
   stack overflow happens in the XHR completion handler (mefyl #762).

README.md

@@ -404,9 +404,19 @@ folder in the sources
 
 ## Debugging
 
-You can activate some runtime debugging for the servers by setting `COHTTP_DEBUG` to any value different from `0` or `false`, and it will set a default debug-level logger on stdout. Note: If you turn on the debugging on the `cohttp-lwt-server` example, you need to make sure you also pass the `-vvv` option, which forces the debug level of the logger.
+You can activate some runtime debugging for the servers by setting `COHTTP_DEBUG` to any value different from `0` or `false`, and it will set a default debug-level logger on stdout.
 
-Since both Cohttp and Conduit use `Logs` for debugging output, you can enable custom debugging in your code (if needed) by adding something like the following to your code (courtesy of @dinosaure)
+Since both Cohttp and Conduit use `Logs` for debugging output, you can enable custom debugging in your code (if needed). For example, if you intend to make use of the `COHTTP_DEBUG` env variable, you could simply use
+
+```ocaml
+let () =
+  if not @@ Debug.debug_active () then (
+    Fmt_tty.setup_std_outputs ();
+    Logs.set_level ~all:true level;
+    Logs.set_reporter Debug.default_reporter);
+```
+
+Of course you are free to completely override it and use your own reporters, for example by adding something like the following to your code (courtesy of @dinosaure).
 
 ```ocaml
 let reporter ppf =

cohttp-lwt-unix/bin/cohttp_curl_lwt.ml

@@ -48,15 +48,12 @@ let client uri ofile meth' =
       | None -> output_body Lwt_io.stdout
       | Some fname -> Lwt_io.with_file ~mode:Lwt_io.output fname output_body)
 
-let run_client verbose ofile uri meth =
-  Lwt_main.run
-    ( (if verbose then (
-       (* activate debug sets the reporter *)
-       Cohttp_lwt_unix.Debug.activate_debug ();
-       Log.debug (fun d -> d ">>> Debug active");
-       return ())
-      else return ())
-    >>= fun () -> client uri ofile meth )
+let run_client level ofile uri meth =
+  if not @@ Debug.debug_active () then (
+    Fmt_tty.setup_std_outputs ();
+    Logs.set_level ~all:true level;
+    Logs.set_reporter Debug.default_reporter);
+  Lwt_main.run (client uri ofile meth)
 
 open Cmdliner
 
@@ -77,9 +74,7 @@ let meth =
   let doc = "Set http method" in
   Arg.(value & opt string "GET" & info [ "X"; "request" ] ~doc)
 
-let verb =
-  let doc = "Display additional debugging to standard error." in
-  Arg.(value & flag & info [ "v"; "verbose" ] ~doc)
+let verb = Logs_cli.level ()
 
 let ofile =
   let doc = "Output filename to store the URI into." in

cohttp-lwt-unix/bin/cohttp_proxy_lwt.ml

@@ -73,8 +73,12 @@ let start_proxy port host verbose cert key () =
   in
   Server.create ~mode config
 
-let lwt_start_proxy port host verbose cert key =
-  Lwt_main.run (start_proxy port host verbose cert key ())
+let lwt_start_proxy port host level cert key =
+  if not @@ Debug.debug_active () then (
+    Fmt_tty.setup_std_outputs ();
+    Logs.set_level ~all:true level;
+    Logs.set_reporter Debug.default_reporter);
+  Lwt_main.run (start_proxy port host (level <> None) cert key ())
 
 open Cmdliner
 
@@ -86,9 +90,7 @@ let port =
   let doc = "TCP port to listen on." in
   Arg.(value & opt int 8080 & info [ "p" ] ~docv:"PORT" ~doc)
 
-let verb =
-  let doc = "Logging output to console." in
-  Arg.(value & flag & info [ "v"; "verbose" ] ~doc)
+let verb = Logs_cli.level ()
 
 let ssl_cert =
   let doc = "SSL certificate file." in

cohttp-lwt-unix/bin/cohttp_server_lwt.ml

@@ -128,11 +128,11 @@ let start_server docroot port host index tls () =
   let ctx = Cohttp_lwt_unix.Net.init ~ctx () in
   Server.create ~ctx ~mode config
 
-let lwt_start_server docroot port host index verbose tls =
-  if verbose <> None then (
-    (* activate_debug sets the reporter *)
-    Cohttp_lwt_unix.Debug.activate_debug ();
-    Logs.set_level verbose);
+let lwt_start_server docroot port host index level tls =
+  if not @@ Debug.debug_active () then (
+    Fmt_tty.setup_std_outputs ();
+    Logs.set_level ~all:true level;
+    Logs.set_reporter Debug.default_reporter);
   Lwt_main.run (start_server docroot port host index tls ())
 
 open Cmdliner

cohttp-lwt-unix/bin/dune

@@ -1,6 +1,6 @@
 (executables
  (names cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt)
  (libraries cohttp-lwt-unix cohttp_server logs logs.lwt logs.fmt logs.cli
-   cmdliner conduit-lwt)
+   cmdliner conduit-lwt fmt.tty)
  (package cohttp-lwt-unix)
  (public_names cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt))

cohttp-lwt-unix/src/debug.ml

@@ -19,7 +19,7 @@ let debug_active () = !_debug_active
 
 open Lwt.Infix
 
-let default_reporter (file_descr, ppf) =
+let reporter file_descr ppf =
   let ppf, flush =
     let buf = Buffer.create 0x100 in
     ( Fmt.with_buffer ~like:ppf buf,
@@ -62,18 +62,21 @@ let default_reporter (file_descr, ppf) =
   in
   { Logs.report }
 
-let set_log =
+let default_reporter = reporter Lwt_unix.stderr Fmt.stderr
+
+let set_logger =
   lazy
-    ((* If no reporter has been set by the application, set default one
+    (if
+     (* If no reporter has been set by the application, set default one
         that prints to stderr *)
-     if Logs.reporter () == Logs.nop_reporter then
-       Logs.set_level @@ Some Logs.Debug;
-     Logs.set_reporter (default_reporter (Lwt_unix.stderr, Fmt.stderr)))
+     Logs.reporter () == Logs.nop_reporter
+    then Logs.set_reporter default_reporter)
 
 let activate_debug () =
-  Lazy.force set_log;
   if not !_debug_active then (
     _debug_active := true;
+    Lazy.force set_logger;
+    Logs.set_level ~all:true (Some Logs.Debug);
     Logs.debug (fun f -> f "Cohttp debugging output is active"))
 
 let () =

cohttp-lwt-unix/src/debug.mli

@@ -16,10 +16,37 @@
 
 (** Debugging output for Cohttp Unix *)
 
+val default_reporter : Logs.reporter
+(** [default_reporter] provides a simple reporter that sends the logging output
+    to stderr. For example, the code below enables logging at level [level] to
+    stderr, using coloured output if possible.
+
+    {[
+      Fmt_tty.setup_std_outputs ();
+      Logs.set_level ~all:true (Some level);
+      Logs.set_reporter Debug.default_reporter
+    ]} *)
+
 val activate_debug : unit -> unit
 (** [activate_debug] enables debugging output that will be sent to standard
     error. *)
 
 val debug_active : unit -> bool
 (** [debug_active] returns true if [activate_debug] has been called and false
     otherwise *)
+
+(** {2 Selectively disable cohttp logging} *)
+
+(** It is possible to selectively disable cohttp internal logginb by filtering
+    over the various modules logs names as follows.
+
+    {[
+      (* Set log level v for all loggers, this does also affect cohttp internal loggers *)
+      Logs.set_level ~all:true level;
+      (* Disable all cohttp-lwt and cohttp-lwt-unix logs *)
+      List.iter (fun src ->
+          match Logs.Src.name src with
+          | "cohttp.lwt.io" | "cohttp.lwt.server" -> Logs.Src.set_level src None
+          | _ -> ())
+      @@ Logs.Src.list ()
+    ]} *)

cohttp-lwt-unix/src/io.mli

@@ -14,6 +14,11 @@
  *
   }}}*)
 
+(** The [Io] module contains the IO implementation for [cohttp-lwt-unix].
+
+    The {!Logs} source name for this module logger is ["cohttp.lwt.io"]. Refer
+    to the {!Debug} module for further details.*)
+
 include
   Cohttp_lwt.S.IO
     with type ic = Lwt_io.input_channel

cohttp-lwt-unix/src/server.ml

@@ -2,7 +2,8 @@ module Server_core = Cohttp_lwt.Make_server (Io)
 include Server_core
 open Lwt.Infix
 
-let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server module"
+let src =
+  Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt Unix server module"
 
 module Log = (val Logs.src_log src : Logs.LOG)
 

cohttp-lwt-unix/src/server.mli

@@ -1,5 +1,8 @@
 (** The [Server] module implements the full UNIX HTTP server interface,
-    including the UNIX-specific functions defined in {!S}. *)
+    including the UNIX-specific functions defined in {!S}.
+
+    The {!Logs} source name for this module logger is ["cohttp.lwt.server"].
+    Refer to the {!Debug} module for further details. *)
 
 include Cohttp_lwt.S.Server with module IO = Io
 

cohttp-lwt/src/server.mli

@@ -1,4 +1,8 @@
 (** The [Make] functor glues together a {!Cohttp.S.IO} implementation to send
     requests down a connection that is established by the user. The resulting
-    module satisfies the {!Server} module type. *)
+    module satisfies the {!Server} module type.
+
+    The {!Logs} source name for this module's logger is ["cohttp.lwt.server"].
+    Refer to the {!Debug} module for further details.*)
+
 module Make (IO : S.IO) : S.Server with module IO = IO