Response.of_file: add error handling (#103)

* Response.of_file: add error handling

* test on 4.13 and down to 4.10

* fix test in ci

.github/workflows/test.yml

@@ -11,7 +11,7 @@ jobs:
       fail-fast: false
       matrix:
         # Tests only on 2 latest versions as macOS runners are more expensive
-        ocamlVersion: [4_11, 4_12]
+        ocamlVersion: [4_12, 4_13]
     steps:
     - uses: actions/checkout@v2
       with:
@@ -29,7 +29,7 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        ocamlVersion: [4_08, 4_10, 4_11, 4_12]
+        ocamlVersion: [4_11, 4_12, 4_13]
     steps:
     - uses: actions/checkout@v2
       with:

lib/http1.ml

@@ -29,7 +29,6 @@
  * POSSIBILITY OF SUCH DAMAGE.
  *---------------------------------------------------------------------------*)
 
-open Monads
 module Piaf_body = Body
 
 module type BODY = Body.BODY

lib/http2.ml

@@ -29,8 +29,6 @@
  * POSSIBILITY OF SUCH DAMAGE.
  *---------------------------------------------------------------------------*)
 
-open Monads
-
 let make_error_handler real_handler type_ error =
   let error : Error.client =
     match error with

lib/monads.ml

@@ -28,15 +28,30 @@
  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  * POSSIBILITY OF SUCH DAMAGE.
  *---------------------------------------------------------------------------*)
+module Option = struct
+  include Option
 
-module Lwt = struct
-  include Lwt
+  let ( let+ ) option f = Option.map f option
 
-  module Syntax = struct
-    let ( let+ ) x f = map f x
+  let ( let* ) = Option.bind
 
-    let ( let* ) = bind
-  end
+  let ( and* ) o1 o2 =
+    match o1, o2 with Some x, Some y -> Some (x, y) | _ -> None
+end
+
+module Result = struct
+  include Result
+
+  let ( let+ ) result f = map f result
+
+  let ( let* ) = bind
+
+  let ( and* ) r1 r2 =
+    match r1, r2 with
+    | Ok x, Ok y ->
+      Ok (x, y)
+    | Ok _, Error e | Error e, Ok _ | Error e, Error _ ->
+      Error e
 end
 
 module Lwt_result = struct
@@ -50,3 +65,37 @@ module Lwt_result = struct
     let ( let* ) = bind
   end
 end
+
+module Bindings = struct
+  (* use `let*` / `let+` for Lwt. These are the ones we're going to end up
+   * using the most *)
+  include Lwt.Syntax
+
+  (* Option *)
+  open Option
+
+  let ( let*? ) = ( let* )
+
+  let ( let+? ) = ( let+ )
+
+  let ( and*? ) = ( and* )
+
+  (* Result *)
+
+  open Result
+
+  let ( let*! ) = ( let* )
+
+  let ( let+! ) = ( let+ )
+
+  let ( and*! ) = ( and* )
+
+  (* Lwt_result *)
+  open Lwt_result.Syntax
+
+  let ( let**! ) = ( let* )
+
+  let ( let++! ) = ( let+ )
+
+  let ( and**! ) = ( and* )
+end

lib/piaf.mli

@@ -542,7 +542,7 @@ module Response : sig
     :  ?version:Versions.HTTP.t
     -> ?headers:Headers.t
     -> string
-    -> t Lwt.t
+    -> (t, Error.t) Lwt_result.t
 
   val persistent_connection : t -> bool
 

lib/response.ml

@@ -29,7 +29,7 @@
  * POSSIBILITY OF SUCH DAMAGE.
  *---------------------------------------------------------------------------*)
 
-open Monads
+open Monads.Bindings
 module Status = H2.Status
 
 type t =
@@ -63,12 +63,19 @@ let of_stream ?version ?headers ~body status =
 
 (* TODO: accept buffer for I/O, so that caller can pool buffers? *)
 let of_file ?version ?(headers = Headers.empty) path =
-  let open Lwt.Syntax in
   let mime = Magic_mime.lookup path in
   let headers =
     Headers.(add_unless_exists headers Well_known.content_type mime)
   in
-  let* channel = Lwt_io.open_file ~flags:[ O_RDONLY ] ~mode:Lwt_io.input path in
+  let**! channel =
+    Lwt.catch
+      (fun () ->
+        let+ channel =
+          Lwt_io.open_file ~flags:[ O_RDONLY ] ~mode:Lwt_io.input path
+        in
+        Ok channel)
+      (fun exn -> Lwt_result.fail (`Exn exn))
+  in
   let+ length = Lwt_io.length channel in
   let remaining = ref (Int64.to_int length) in
   let stream =
@@ -89,11 +96,12 @@ let of_file ?version ?(headers = Headers.empty) path =
   in
   Lwt.on_success (Lwt_stream.closed stream) (fun () ->
       Lwt.ignore_result (Lwt_io.close channel));
-  create
-    ?version
-    ~headers
-    ~body:(Body.of_string_stream ~length:`Chunked stream)
-    `OK
+  Ok
+    (create
+       ?version
+       ~headers
+       ~body:(Body.of_string_stream ~length:`Chunked stream)
+       `OK)
 
 let upgrade ?version ?(headers = Headers.empty) upgrade_handler =
   create

lib_test/dune

@@ -3,13 +3,18 @@
  (modules test_cookies)
  (libraries alcotest piaf))
 
+(generate_sites_module
+ (module cert_sites)
+ (sourceroot))
+
 (test
  (name test_client)
  (libraries alcotest alcotest-lwt piaf logs.fmt dune-site)
  (modules helper_server test_client cert_sites)
  (deps
   (source_tree "./certificates")))
 
-(generate_sites_module
- (module cert_sites)
- (sourceroot))
+(test
+ (name test_response)
+ (libraries alcotest alcotest-lwt piaf logs.fmt)
+ (modules test_response))

lib_test/test_client.ml

@@ -1,6 +1,5 @@
 open Lwt.Syntax
 open Piaf
-module Result = Stdlib.Result
 
 let ( // ) = Filename.concat
 

lib_test/test_response.ml

@@ -0,0 +1,66 @@
+open Lwt.Syntax
+open Piaf
+
+let test_of_file _ () =
+  let+ response = Response.of_file "./test_response.ml" in
+  Alcotest.(check string)
+    "expected status 200"
+    "200"
+    (Status.to_string (Result.get_ok response).status);
+  Alcotest.(check (Alcotest.of_pp Headers.pp_hum))
+    "expected header"
+    (Headers.of_list [ Headers.Well_known.content_type, "text/x-ocaml" ])
+    (Result.get_ok response).headers
+
+let test_of_file_nonexistent _ () =
+  let+ response = Response.of_file "./does_not_exist.ml" in
+  Alcotest.(
+    check
+      (result (Alcotest.of_pp Response.pp_hum) (Alcotest.of_pp Error.pp_hum)))
+    "expected error"
+    (Error (`Exn (Unix.Unix_error (Unix.ENOENT, "open", "./does_not_exist.ml"))))
+    response
+
+let suite =
+  [ ( "response"
+    , List.map
+        (fun (desc, ty, f) -> Alcotest_lwt.test_case desc ty f)
+        [ "of_file", `Quick, test_of_file
+        ; "non-existent of_file", `Quick, test_of_file_nonexistent
+        ] )
+  ]
+
+let () =
+  let setup_log ?style_renderer level =
+    let pp_header src ppf (l, h) =
+      if l = Logs.App then
+        Format.fprintf ppf "%a" Logs_fmt.pp_header (l, h)
+      else
+        let x =
+          match Array.length Sys.argv with
+          | 0 ->
+            Filename.basename Sys.executable_name
+          | _n ->
+            Filename.basename Sys.argv.(0)
+        in
+        let x =
+          if Logs.Src.equal src Logs.default then
+            x
+          else
+            Logs.Src.name src
+        in
+        Format.fprintf ppf "%s: %a " x Logs_fmt.pp_header (l, h)
+    in
+    let format_reporter =
+      let report src =
+        let { Logs.report } = Logs_fmt.reporter ~pp_header:(pp_header src) () in
+        report src
+      in
+      { Logs.report }
+    in
+    Fmt_tty.setup_std_outputs ?style_renderer ();
+    Logs.set_level ~all:true (Some level);
+    Logs.set_reporter format_reporter
+  in
+  setup_log Debug;
+  Lwt_main.run (Alcotest_lwt.run "Piaf client tests" suite)

nix/sources.nix

@@ -2,7 +2,7 @@
 let
   overlays =
     builtins.fetchTarball
-      https://github.com/anmonteiro/nix-overlays/archive/1c7f1673.tar.gz;
+      https://github.com/anmonteiro/nix-overlays/archive/5acabdcb.tar.gz;
 
 in
 import "${overlays}/boot.nix" {