Add log warnings for uncaught exceptions

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 ->

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)

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 ()

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 }