fix(async): do not read pipe to check if its empty (#1059)

this isn't safe as it drops chunks from the user

Signed-off-by: Rudi Grinberg <[email protected]>

cohttp-async/src/body.ml

@@ -20,19 +20,8 @@ let drain = function #B.t -> return () | `Pipe p -> Pipe.drain p
 
 let is_empty (body : t) =
   match body with
-  | #B.t as body -> return (B.is_empty body)
-  | `Pipe pipe -> (
-      Deferred.repeat_until_finished () @@ fun () ->
-      Pipe.values_available pipe >>= function
-      | `Eof -> return (`Finished true)
-      | `Ok -> (
-          match Pipe.peek pipe with
-          | None -> return (`Finished true)
-          | Some "" -> (
-              Pipe.read pipe >>| function
-              | `Eof -> `Finished true
-              | `Ok _ -> `Repeat ())
-          | Some _ -> return (`Finished false)))
+  | #B.t as body -> if B.is_empty body then `True else `False
+  | `Pipe _ -> `Unknown
 
 let to_pipe = function
   | `Empty -> Pipe.of_list []

cohttp-async/src/body.mli

@@ -7,7 +7,7 @@ type t = [ Cohttp.Body.t | `Pipe of string Pipe.Reader.t ] [@@deriving sexp_of]
 include Cohttp.S.Body with type t := t
 
 val drain : t -> unit Deferred.t
-val is_empty : t -> bool Deferred.t
+val is_empty : t -> [ `True | `False | `Unknown ]
 val to_string : t -> string Deferred.t
 val to_string_list : t -> string list Deferred.t
 val to_pipe : t -> string Pipe.Reader.t

cohttp-async/src/client.ml

@@ -137,17 +137,18 @@ let call ?interrupt ?ssl_config ?headers ?(chunked = false) ?(body = `Empty)
       Body.Private.disable_chunked_encoding body >>| fun (body, body_length) ->
       ( Cohttp.Request.make_for_client ?headers ~chunked ~body_length meth uri,
         body )
-  | true -> (
-      Body.is_empty body >>| function
-      | true ->
-          (* Don't used chunked encoding with an empty body *)
-          ( Cohttp.Request.make_for_client ?headers ~chunked:false
-              ~body_length:0L meth uri,
-            body )
-      | false ->
-          (* Use chunked encoding if there is a body *)
-          (Cohttp.Request.make_for_client ?headers ~chunked:true meth uri, body)
-      ))
+  | true ->
+      Deferred.return
+        (match Body.is_empty body with
+        | `True ->
+            (* Don't used chunked encoding with an empty body *)
+            ( Cohttp.Request.make_for_client ?headers ~chunked:false
+                ~body_length:0L meth uri,
+              body )
+        | `Unknown | `False ->
+            (* Use chunked encoding if there is a body *)
+            ( Cohttp.Request.make_for_client ?headers ~chunked:true meth uri,
+              body )))
   >>= fun (req, body) -> request ?interrupt ?ssl_config ~body ~uri req
 
 let get ?interrupt ?ssl_config ?headers uri =

cohttp-async/test/test_async_integration.ml

@@ -101,39 +101,13 @@ let ts =
         Body.to_string body >>| fun body ->
         assert_equal ~printer "expert 2" body
       in
-      let check_body_empty_status () =
-        let is_empty = Cohttp_async.Body.is_empty in
-        let tests =
-          [
-            ("empty pipe", Pipe.of_list [], true);
-            ("pipe with elements", Pipe.of_list [ "foo"; "bar" ], false);
-            ( "pipe with empty items at the beginning",
-              Pipe.of_list [ ""; "baz" ],
-              false );
-            ("Pipe with empty strings", Pipe.of_list [ ""; ""; "" ], true);
-          ]
-        in
-        Deferred.List.iter ~how:`Sequential tests
-          ~f:(fun (msg, pipe, expected) ->
-            is_empty (`Pipe pipe) >>| fun real ->
-            assert_equal ~msg expected real)
-        >>= fun () ->
-        let b = Pipe.of_list [ ""; ""; "foo"; "bar" ] in
-        is_empty (`Pipe b) >>= fun _ ->
-        Pipe.to_list b >>| fun real ->
-        let msg =
-          "Checking if pipe is empty consumes all leading empty strings"
-        in
-        assert_equal ~msg [ "foo"; "bar" ] real
-      in
       [
         ("empty chunk test", empty_chunk);
         ("large response", large_response);
         ("large request", large_request);
         ("pipelined chunk test", pipelined_chunk);
         ("large chunked response", large_chunked_response);
         ("expert response", expert_pipelined);
-        ("check body is_empty status for pipes", check_body_empty_status);
       ])
 
 let () =