From 7022bf8f9468dd6ccbc62e247dfefa36fc9be9ec Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Thu, 11 Nov 2021 17:29:31 -0800 Subject: [PATCH] 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 | 4 +-- lib/http1.ml | 1 - lib/http2.ml | 2 -- lib/monads.ml | 61 +++++++++++++++++++++++++++++++---- lib/piaf.mli | 2 +- lib/response.ml | 24 +++++++++----- lib_test/dune | 11 +++++-- lib_test/test_client.ml | 1 - lib_test/test_response.ml | 66 ++++++++++++++++++++++++++++++++++++++ nix/sources.nix | 2 +- 10 files changed, 149 insertions(+), 25 deletions(-) create mode 100644 lib_test/test_response.ml diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 36b9171f..6cbdb950 100644 --- a/.github/workflows/test.yml +++ b/.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: diff --git a/lib/http1.ml b/lib/http1.ml index 3c0d904f..ad1ab6d3 100644 --- a/lib/http1.ml +++ b/lib/http1.ml @@ -29,7 +29,6 @@ * POSSIBILITY OF SUCH DAMAGE. *---------------------------------------------------------------------------*) -open Monads module Piaf_body = Body module type BODY = Body.BODY diff --git a/lib/http2.ml b/lib/http2.ml index 0fbddbbb..c8ab8f3b 100644 --- a/lib/http2.ml +++ b/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 diff --git a/lib/monads.ml b/lib/monads.ml index a89d3a1f..b80bd174 100644 --- a/lib/monads.ml +++ b/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 diff --git a/lib/piaf.mli b/lib/piaf.mli index aab393ab..f4c2e04e 100644 --- a/lib/piaf.mli +++ b/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 diff --git a/lib/response.ml b/lib/response.ml index 96d54e9a..eda1c681 100644 --- a/lib/response.ml +++ b/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 diff --git a/lib_test/dune b/lib_test/dune index 94aacbc1..bc308fae 100644 --- a/lib_test/dune +++ b/lib_test/dune @@ -3,6 +3,10 @@ (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) @@ -10,6 +14,7 @@ (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)) diff --git a/lib_test/test_client.ml b/lib_test/test_client.ml index b5bdc69e..50da50d9 100644 --- a/lib_test/test_client.ml +++ b/lib_test/test_client.ml @@ -1,6 +1,5 @@ open Lwt.Syntax open Piaf -module Result = Stdlib.Result let ( // ) = Filename.concat diff --git a/lib_test/test_response.ml b/lib_test/test_response.ml new file mode 100644 index 00000000..5c76f31c --- /dev/null +++ b/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) diff --git a/nix/sources.nix b/nix/sources.nix index cf8b93ab..f642581a 100644 --- a/nix/sources.nix +++ b/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" {