From 732a039baa422ba29afc0b59a23939544c90a42a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 12 Apr 2018 10:35:53 +0800 Subject: [PATCH 1/4] Remove uses of deprecated Lwt_logs Use recommended Logs_lwt instead. --- cohttp-lwt-unix/bin/cohttp_server_lwt.ml | 17 ++++++++++------- cohttp-lwt-unix/src/server.ml | 7 ++++++- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml index deb514f022..071a221d88 100644 --- a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -21,6 +21,8 @@ open Cohttp_lwt_unix open Cohttp_server +let log_src = Logs.Src.create "cohttp-lwt-unix.bin.server" + let method_filter meth (res,body) = match meth with | `HEAD -> Lwt.return (res,`Empty) | _ -> Lwt.return (res,body) @@ -81,10 +83,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 *) - Lwt_log.debug_f "%s %s %s" + Logs_lwt.debug ~src:log_src (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))) >>= fun () -> (* Get a canonical filename from the URL and docroot *) match Request.meth req with | (`GET | `HEAD) as meth -> @@ -98,11 +101,11 @@ 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 () = - Lwt_log.info_f "Listening for HTTP request on: %s %d" host port >>= fun () -> + Logs_lwt.info (fun m -> m "Listening for HTTP request on: %s %d" host port) >>= fun () -> let info = Printf.sprintf "Served by Cohttp/Lwt listening on %s:%d" host port in let conn_closed (ch,_conn) = - Lwt_log.ign_debug_f "connection %s closed" - (Sexplib.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch)) in + Logs.debug ~src:log_src (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 let mode = match tls with @@ -117,8 +120,8 @@ let start_server docroot port host index tls () = let lwt_start_server docroot port host index verbose tls = (match List.length verbose with | 0 -> () - | 1 -> Lwt_log_core.(add_rule "*" Info) - | _ -> Lwt_log_core.(add_rule "*" Debug)); + | 1 -> Logs.set_level (Some Logs.Info) + | _ -> Logs.set_level (Some Logs.Debug)); Lwt_main.run (start_server docroot port host index tls ()) open Cmdliner diff --git a/cohttp-lwt-unix/src/server.ml b/cohttp-lwt-unix/src/server.ml index 0efc09469b..4beebd3e61 100644 --- a/cohttp-lwt-unix/src/server.ml +++ b/cohttp-lwt-unix/src/server.ml @@ -4,6 +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 blank_uri = Uri.of_string "" let resolve_file ~docroot ~uri = @@ -31,7 +33,10 @@ let respond_file ?headers ~fname () = | "" -> None | buf -> Some buf) (fun exn -> - Lwt_log.ign_debug ~exn ("Error resolving file " ^ fname); + Logs.debug ~src:log_src + (fun m -> m "Error resolving file %s (%s)" + fname + (Printexc.to_string exn)); return_none) ) in Lwt.on_success (Lwt_stream.closed stream) (fun () -> From 4e250b1cbdf5a938cb4aa7838c8f59ff7e13e5f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 12 Apr 2018 10:43:14 +0800 Subject: [PATCH 2/4] Use Logs_cli.level for verbosity flag --- cohttp-lwt-unix/bin/cohttp_server_lwt.ml | 9 ++------- cohttp-lwt-unix/bin/jbuild | 2 +- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml index 071a221d88..ef51efeefe 100644 --- a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -118,10 +118,7 @@ let start_server docroot port host index tls () = Server.create ~ctx ~mode config let lwt_start_server docroot port host index verbose tls = - (match List.length verbose with - | 0 -> () - | 1 -> Logs.set_level (Some Logs.Info) - | _ -> Logs.set_level (Some Logs.Debug)); + Logs.set_level verbose; Lwt_main.run (start_server docroot port host index tls ()) open Cmdliner @@ -138,9 +135,7 @@ let index = let doc = "Name of index file in directory." in Arg.(value & opt string "index.html" & info ["i"] ~docv:"INDEX" ~doc) -let verb = - let doc = "Logging output to console." in - Arg.(value & flag_all & info ["v"; "verbose"] ~doc) +let verb = Logs_cli.level () let tls = let doc = "TLS certificate files." in diff --git a/cohttp-lwt-unix/bin/jbuild b/cohttp-lwt-unix/bin/jbuild index 7e562dafc1..93a68b322d 100644 --- a/cohttp-lwt-unix/bin/jbuild +++ b/cohttp-lwt-unix/bin/jbuild @@ -2,6 +2,6 @@ (executables ((names (cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt)) - (libraries (cohttp-lwt-unix cohttp_server cmdliner)) + (libraries (cohttp-lwt-unix cohttp_server logs.cli cmdliner)) (package cohttp-lwt-unix) (public_names (cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)))) From 7dca2236d9642646d0184be8f53174c6d34c0236 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 13 Apr 2018 09:40:42 +0800 Subject: [PATCH 3/4] Explicit dependencies to logs.lwt in build files --- cohttp-lwt-unix/bin/jbuild | 8 +++++++- cohttp-lwt-unix/src/jbuild | 1 + 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/cohttp-lwt-unix/bin/jbuild b/cohttp-lwt-unix/bin/jbuild index 93a68b322d..4923b7ee5b 100644 --- a/cohttp-lwt-unix/bin/jbuild +++ b/cohttp-lwt-unix/bin/jbuild @@ -2,6 +2,12 @@ (executables ((names (cohttp_curl_lwt cohttp_proxy_lwt cohttp_server_lwt)) - (libraries (cohttp-lwt-unix cohttp_server logs.cli cmdliner)) + (libraries + (cohttp-lwt-unix + cohttp_server + logs + logs.lwt + logs.cli + cmdliner)) (package cohttp-lwt-unix) (public_names (cohttp-curl-lwt cohttp-proxy-lwt cohttp-server-lwt)))) diff --git a/cohttp-lwt-unix/src/jbuild b/cohttp-lwt-unix/src/jbuild index addfaf3299..c5d318f5f4 100644 --- a/cohttp-lwt-unix/src/jbuild +++ b/cohttp-lwt-unix/src/jbuild @@ -7,6 +7,7 @@ (preprocess (pps (ppx_sexp_conv))) (libraries (fmt + logs logs.lwt conduit-lwt-unix magic-mime From cc80e63f4b2835cf5bd7971613a2e397f9dbb497 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 13 Apr 2018 09:52:39 +0800 Subject: [PATCH 4/4] Set Lwt-aware reporter in cohttp-lwt-unix/bin --- cohttp-lwt-unix/bin/cohttp_server_lwt.ml | 26 ++++++++++++++++++++++++ cohttp-lwt-unix/bin/jbuild | 1 + 2 files changed, 27 insertions(+) diff --git a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml index ef51efeefe..04695d21ca 100644 --- a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -117,10 +117,36 @@ 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 ()); Lwt_main.run (start_server docroot port host index tls ()) + open Cmdliner let host = diff --git a/cohttp-lwt-unix/bin/jbuild b/cohttp-lwt-unix/bin/jbuild index 4923b7ee5b..3c1737274c 100644 --- a/cohttp-lwt-unix/bin/jbuild +++ b/cohttp-lwt-unix/bin/jbuild @@ -7,6 +7,7 @@ cohttp_server logs logs.lwt + logs.fmt logs.cli cmdliner)) (package cohttp-lwt-unix)