Merge pull request #184 from inhabitedtype/fix-parse-error-cases

Fix parse error cases

examples/async/async_get.ml

@@ -4,8 +4,6 @@ open Async
 open Httpaf
 open Httpaf_async
 
-let error_handler _ = assert false
-
 let main port host () =
   let where_to_connect = Tcp.Where_to_connect.of_host_and_port { host; port } in
   Tcp.connect_sock where_to_connect
@@ -15,7 +13,7 @@ let main port host () =
     let headers = Headers.of_list [ "host", host ] in
     let request_body =
       Client.request
-        ~error_handler
+        ~error_handler:Httpaf_examples.Client.error_handler
         ~response_handler
         socket
         (Request.create ~headers `GET "/")

examples/async/async_post.ml

@@ -4,8 +4,6 @@ open Async
 open Httpaf
 open Httpaf_async
 
-let error_handler _ = assert false
-
 let main port host () =
   let where_to_connect = Tcp.Where_to_connect.of_host_and_port { host; port } in
   Tcp.connect_sock where_to_connect
@@ -21,7 +19,7 @@ let main port host () =
     in
     let request_body =
       Client.request
-        ~error_handler
+        ~error_handler:Httpaf_examples.Client.error_handler
         ~response_handler
         socket
         (Request.create ~headers `POST "/")

examples/lib/httpaf_examples.ml

@@ -9,6 +9,18 @@ let text = "CHAPTER I. Down the Rabbit-Hole  Alice was beginning to get very tir
 let text = Bigstringaf.of_string ~off:0 ~len:(String.length text) text
 
 module Client = struct
+ exception Response_error
+
+  let error_handler error =
+    let error =
+      match error with
+      | `Malformed_response err -> Format.sprintf "Malformed response: %s" err
+      | `Invalid_response_body_length _ -> "Invalid body length"
+      | `Exn exn -> Format.sprintf "Exn raised: %s" (Exn.to_string exn)
+    in
+    Format.eprintf "Error handling response: %s\n%!" error;
+  ;;
+
   let print ~on_eof response response_body =
     match response with
     | { Response.status = `OK; _ } as response ->

examples/lwt/lwt_get.ml

@@ -5,8 +5,6 @@ module Arg = Caml.Arg
 open Httpaf
 open Httpaf_lwt_unix
 
-let error_handler _ = assert false
-
 let main port host =
   Lwt_unix.getaddrinfo host (Int.to_string port) [Unix.(AI_FAMILY PF_INET)]
   >>= fun addresses ->
@@ -20,7 +18,7 @@ let main port host =
   let headers = Headers.of_list [ "host", host ] in
   let request_body =
     Client.request
-      ~error_handler
+      ~error_handler:Httpaf_examples.Client.error_handler
       ~response_handler
       socket
       (Request.create ~headers `GET "/")

examples/lwt/lwt_post.ml

@@ -5,8 +5,6 @@ module Arg = Caml.Arg
 open Httpaf
 open Httpaf_lwt_unix
 
-let error_handler _ = assert false
-
 let main port host =
   Lwt_io.(read stdin)
   >>= fun body ->
@@ -28,7 +26,7 @@ let main port host =
   in
   let request_body =
     Client.request
-      ~error_handler
+      ~error_handler:Httpaf_examples.Client.error_handler
       ~response_handler
       socket
       (Request.create ~headers `POST "/")

lib/parse.ml

@@ -325,7 +325,7 @@ module Reader = struct
     then `Close
     else (
       match t.parse_state with
-      | Fail _    -> `Close
+      | Fail err  -> `Error err
       | Done      -> `Read
       | Partial _ -> `Read
     )

lib_test/test_client_connection.ml

@@ -2,13 +2,28 @@ open Httpaf
 open Helpers
 open Client_connection
 
+let response_error_pp_hum fmt = function
+  | `Malformed_response str ->
+    Format.fprintf fmt "Malformed_response: %s" str
+  | `Invalid_response_body_length resp ->
+    Format.fprintf fmt "Invalid_response_body_length: %s" (response_to_string resp)
+  | `Exn exn ->
+    Format.fprintf fmt "Exn (%s)" (Printexc.to_string exn)
+;;
+
 module Response = struct
   include Response
 
   let pp = pp_hum
   let equal x y = x = y
 end
 
+module Alcotest = struct
+  include Alcotest
+
+  let response_error = of_pp response_error_pp_hum
+end
+
 let feed_string t str =
   let len = String.length str in
   let input = Bigstringaf.of_string str ~off:0 ~len in
@@ -218,10 +233,41 @@ let test_input_shrunk () =
     !error_message
 ;;
 
+let test_failed_response_parse () =
+  let request' = Request.create `GET "/" in
+
+  let test response bytes_read expected_error =
+    let error = ref None in
+    let body, t =
+      request
+        request'
+        ~response_handler:(fun _ _ -> assert false)
+        ~error_handler:(fun e -> error := Some e)
+    in
+    Body.close_writer body;
+    write_request t request';
+    writer_closed t;
+    reader_ready t;
+    let len = feed_string t response in
+    Alcotest.(check int) "bytes read" len bytes_read;
+    connection_is_shutdown t;
+    Alcotest.(check (option response_error)) "Response error"
+      (Some expected_error) !error;
+  in
+
+  test "HTTP/1.1 200\r\n\r\n" 12 (`Malformed_response ": char ' '");
+
+  let response =
+    Response.create `OK ~headers:(Headers.of_list ["Content-length", "-1"])
+  in
+  test (response_to_string response) 39 (`Invalid_response_body_length response);
+;;
+
 let tests =
   [ "GET"         , `Quick, test_get
   ; "Response EOF", `Quick, test_response_eof
   ; "Response header order preserved", `Quick, test_response_header_order
   ; "report_exn"  , `Quick, test_report_exn
   ; "input_shrunk", `Quick, test_input_shrunk
+  ; "failed response parse", `Quick, test_failed_response_parse
   ]

lib_test/test_server_connection.ml

@@ -2,6 +2,23 @@ open Httpaf
 open Helpers
 open Server_connection
 
+let request_error_pp_hum fmt = function
+  | `Bad_request           -> Format.fprintf fmt "Bad_request"
+  | `Bad_gateway           -> Format.fprintf fmt "Bad_gateway"
+  | `Internal_server_error -> Format.fprintf fmt "Internal_server_error"
+  | `Exn exn               -> Format.fprintf fmt "Exn (%s)" (Printexc.to_string exn)
+;;
+
+module Alcotest = struct
+  include Alcotest
+
+  let request_error = Alcotest.of_pp request_error_pp_hum
+
+  let request = Alcotest.of_pp (fun fmt req ->
+    Format.fprintf fmt "%s" (request_to_string req))
+  ;;
+end
+
 let feed_string t str =
   let len = String.length str in
   let input = Bigstringaf.of_string str ~off:0 ~len in
@@ -566,6 +583,72 @@ Accept-Language: en-US,en;q=0.5\r\n\r\n";
   writer_closed t;
 ;;
 
+let test_failed_request_parse () =
+  let error_handler_fired = ref false in
+  let error_handler ?request error start_response =
+    error_handler_fired := true;
+    Alcotest.(check (option request)) "No parsed request"
+      None request;
+    Alcotest.(check request_error) "Request error"
+      `Bad_request error;
+    start_response Headers.empty |> Body.close_writer;
+  in
+  let request_handler _reqd = assert false in
+  let t = create ~error_handler request_handler in
+  reader_ready t;
+  let writer_woken_up = ref false in
+  writer_yielded t;
+  yield_writer t (fun () ->
+    writer_woken_up := true);
+  let len = feed_string t "GET /v1/b HTTP/1.1\r\nHost : example.com\r\n\r\n" in
+  (* Reads through the end of "Host" *)
+  Alcotest.(check int) "partial read" 24 len;
+  Alcotest.(check bool) "Writer not woken up"
+    false !writer_woken_up;
+  Alcotest.check read_operation "reader closed"
+    `Close (next_read_operation t);
+  Alcotest.(check bool) "Error handler fired"
+    true !error_handler_fired;
+  Alcotest.(check bool) "Writer woken up"
+    true !writer_woken_up;
+  write_response t (Response.create `Bad_request);
+;;
+
+let test_bad_request () =
+  (* A `Bad_request is returned in a number of cases surrounding
+     transfer-encoding or content-length headers. *)
+  let request =
+    Request.create `GET "/"
+      ~headers:(Headers.of_list ["content-length", "-1"])
+  in
+  let error_handler_fired = ref false in
+  let error_handler ?request:request' error start_response =
+    error_handler_fired := true;
+    Alcotest.(check (option request)) "Parsed request"
+      (Some request) request';
+    Alcotest.(check request_error) "Request error"
+      `Bad_request error;
+    start_response Headers.empty |> Body.close_writer;
+  in
+  let request_handler _reqd = assert false in
+  let t = create ~error_handler request_handler in
+  reader_ready t;
+  let writer_woken_up = ref false in
+  writer_yielded t;
+  yield_writer t (fun () ->
+    writer_woken_up := true);
+  read_request t request;
+  Alcotest.(check bool) "Writer not woken up"
+    false !writer_woken_up;
+  Alcotest.check read_operation "reader closed"
+    `Close (next_read_operation t);
+  Alcotest.(check bool) "Error handler fired"
+    true !error_handler_fired;
+  Alcotest.(check bool) "Writer woken up"
+    true !writer_woken_up;
+  write_response t (Response.create `Bad_request);
+;;
+
 let tests =
   [ "initial reader state"  , `Quick, test_initial_reader_state
   ; "shutdown reader closed", `Quick, test_reader_is_closed_after_eof
@@ -587,4 +670,6 @@ let tests =
   ; "blocked write on chunked encoding", `Quick, test_blocked_write_on_chunked_encoding
   ; "writer unexpected eof", `Quick, test_unexpected_eof
   ; "input shrunk", `Quick, test_input_shrunk
+  ; "failed request parse", `Quick, test_failed_request_parse
+  ; "bad request", `Quick, test_bad_request
   ]