diff --git a/cohttp-lwt-unix/src/debug.ml b/cohttp-lwt-unix/src/debug.ml index d54ddc149f..23d77c48ea 100644 --- a/cohttp-lwt-unix/src/debug.ml +++ b/cohttp-lwt-unix/src/debug.ml @@ -29,8 +29,14 @@ 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 () in - Lwt.ignore_result (Lwt.finalize write unblock : unit Lwt.t); + let unblock () = over (); Lwt.return_unit in + Lwt.ignore_result @@ Lwt.catch + (fun () -> (Lwt.finalize write unblock : unit Lwt.t)) + (fun e -> + Logs.warn (fun f -> + f "Flushing stderr failed: %s" (Printexc.to_string e)); + Lwt.return_unit + ); k () in msgf @@ fun ?header:_ ?tags:_ fmt -> diff --git a/cohttp-lwt-unix/src/net.ml b/cohttp-lwt-unix/src/net.ml index 503b8dad52..a0d2665423 100644 --- a/cohttp-lwt-unix/src/net.ml +++ b/cohttp-lwt-unix/src/net.ml @@ -17,7 +17,7 @@ (* Miscellaneous net-helpers used by Cohttp. Ideally, these will disappear * into some connection-management framework such as andrenth/release *) -open Lwt +open Lwt.Infix module IO = Io @@ -42,10 +42,15 @@ let connect_uri ~ctx uri = >>= fun client -> Conduit_lwt_unix.connect ~ctx:ctx.ctx client -let close c = Lwt.catch (fun () -> Lwt_io.close c) (fun _ -> return_unit) +let close c = Lwt.catch + (fun () -> Lwt_io.close c) + (fun e -> + Logs.warn (fun f -> f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return_unit + ) -let close_in ic = ignore_result (close ic) +let close_in ic = Lwt.ignore_result (close ic) -let close_out oc = ignore_result (close oc) +let close_out oc = Lwt.ignore_result (close oc) -let close ic oc = ignore_result (close ic >>= fun () -> close oc) +let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close oc) diff --git a/cohttp-lwt-unix/src/server.ml b/cohttp-lwt-unix/src/server.ml index 6a080db85b..1e5e0382c5 100644 --- a/cohttp-lwt-unix/src/server.ml +++ b/cohttp-lwt-unix/src/server.ml @@ -2,7 +2,7 @@ module Server_core = Cohttp_lwt.Make_server (Io) include Server_core -open Lwt +open Lwt.Infix let src = Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt server module" module Log = (val Logs.src_log src : Logs.LOG) @@ -20,8 +20,8 @@ let respond_file ?headers ~fname () = (* Check this isnt a directory first *) (fname |> Lwt_unix.stat >>= fun s -> if Unix.(s.st_kind <> S_REG) - then fail Isnt_a_file - else return_unit) >>= fun () -> + then Lwt.fail Isnt_a_file + else Lwt.return_unit) >>= fun () -> let count = 16384 in Lwt_io.open_file ~buffer:(Lwt_bytes.create count) @@ -38,16 +38,23 @@ let respond_file ?headers ~fname () = (fun m -> m "Error resolving file %s (%s)" fname (Printexc.to_string exn)); - return_none) + Lwt.return_none) ) in Lwt.on_success (Lwt_stream.closed stream) (fun () -> - ignore_result (Lwt_io.close ic)); + Lwt.ignore_result @@ Lwt.catch + (fun () -> Lwt_io.close ic) + (fun e -> + Log.warn (fun f -> + f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return_unit + ) + ); let body = Cohttp_lwt.Body.of_stream stream in let mime_type = Magic_mime.lookup fname in let headers = Cohttp.Header.add_opt_unless_exists headers "content-type" mime_type in let res = Cohttp.Response.make ~status:`OK ~encoding ~headers () in - return (res, body) + Lwt.return (res, body) ) (function | Unix.Unix_error(Unix.ENOENT,_,_) | Isnt_a_file -> respond_not_found () diff --git a/cohttp-mirage/src/client.ml b/cohttp-mirage/src/client.ml index 51a02a94f8..dd5ea62059 100644 --- a/cohttp-mirage/src/client.ml +++ b/cohttp-mirage/src/client.ml @@ -47,7 +47,11 @@ module Net_IO = struct let close_out _ = () let close ic _oc = Lwt.ignore_result @@ Lwt.catch (fun () -> Channel.close ic) - (fun _ -> Lwt.return @@ Ok ()) + (fun e -> + Logs.warn (fun f -> + f "Closing channel failed: %s" (Printexc.to_string e)); + Lwt.return @@ Ok () + ) end let ctx resolver conduit = { Net_IO.resolver; conduit }