Do not omit mandatory null content-length headers.

CHANGES.md

@@ -1,4 +1,6 @@
 ## Unreleased
+
+- do not omit mandatory null Content-Length headers (mefyl #985)
 - cohttp-async, cohttp-curl-async: compatibility with core/async v0.16.0 (mseri, dkalinichenko-js #976)
 - cohttp-lwt server: call conn_closed before drainig the body of response on error (pirbo #982)
 - cohttp-eio: Relax socket interface requirement on `Server.connection_handler`. (mefyl #983)

cohttp/src/request.ml

@@ -199,9 +199,9 @@ module Make (IO : S.IO) = struct
     in
     let headers = req.headers in
     let headers =
-      match Http.Request.has_body req with
-      | `Yes | `Unknown -> Header.add_transfer_encoding headers req.encoding
-      | `No -> headers
+      if Http.Method.body_allowed req.meth then
+        Header.add_transfer_encoding headers req.encoding
+      else headers
     in
     IO.write oc fst_line >>= fun _ -> Header_IO.write headers oc
 

cohttp/test/dune

@@ -26,7 +26,7 @@
  (name test_request)
  (modules test_request)
  (forbidden_libraries base)
- (libraries cohttp alcotest fmt))
+ (libraries alcotest cohttp fmt http_bytebuffer))
 
 (rule
  (alias runtest)

cohttp/test/test_request.ml

@@ -255,6 +255,88 @@ let uri_round_trip _ =
 
 let () = Printexc.record_backtrace true
 
+module Buffer = struct
+  include Http_bytebuffer.Bytebuffer
+
+  include
+    Http_bytebuffer.Bytebuffer.Make
+      (struct
+        type 'a t = 'a
+
+        let ( >>= ) v f = f v
+        let ( >>| ) v f = f v
+        let return v = v
+      end)
+      (struct
+        type src = string
+
+        let refill s buffer ~pos ~len =
+          if String.equal s "" then `Eof
+          else
+            let len = min len (String.length s) in
+            let () = Bytes.blit_string s 0 buffer pos len in
+            `Ok len
+      end)
+end
+
+module Test_io = struct
+  type 'a t = 'a
+
+  let ( >>= ) v f = f v
+  let return v = v
+
+  type ic = Buffer.t
+  type oc = Buffer.t
+  type conn = unit
+
+  let refill _ = `Eof
+
+  let with_input_buffer b ~f =
+    let contents = Buffer.to_string b in
+    let res, read = f contents ~pos:0 ~len:(String.length contents) in
+    let () = Buffer.drop b read in
+    res
+
+  let read_line buffer = Buffer.read_line buffer ""
+  let read buffer = Buffer.read buffer ""
+  let write buffer string = Buffer.refill buffer string |> ignore
+  let flush _ = ()
+end
+
+module Request = Request.Private.Make (Test_io)
+
+let null_content_length_header () =
+  let output = Buffer.create 1024 in
+  let () =
+    let r =
+      Cohttp.Request.make_for_client ~chunked:false ~body_length:0L `PUT
+        (Uri.of_string "http://someuri.com")
+    in
+    Request.write_header r output
+  in
+  Alcotest.(check string)
+    "null content-length header are sent"
+    "PUT / HTTP/1.1\r\n\
+     host: someuri.com\r\n\
+     user-agent: ocaml-cohttp/\r\n\
+     content-length: 0\r\n\
+     \r\n"
+    (Buffer.to_string output)
+
+let useless_null_content_length_header () =
+  let output = Buffer.create 1024 in
+  let () =
+    let r =
+      Cohttp.Request.make_for_client ~chunked:false ~body_length:0L `GET
+        (Uri.of_string "http://someuri.com")
+    in
+    Request.write_header r output
+  in
+  Alcotest.(check string)
+    "null content-length header are not sent for bodyless methods"
+    "GET / HTTP/1.1\r\nhost: someuri.com\r\nuser-agent: ocaml-cohttp/\r\n\r\n"
+    (Buffer.to_string output)
+
 let () =
   Alcotest.run "test_request"
     [
@@ -275,6 +357,10 @@ let () =
           ( "from both optional argument and headers",
             `Quick,
             encoding_header_opt_argument );
+          ("null content-length", `Quick, null_content_length_header);
+          ( "useless null content-length",
+            `Quick,
+            useless_null_content_length_header );
         ] );
       ( "Parse URI",
         [

http/src/http.ml

@@ -702,6 +702,11 @@ module Method = struct
     | "CONNECT" -> `CONNECT
     | s -> `Other s
 
+  (* Defined for method types in RFC7231 *)
+  let body_allowed = function
+    | `GET | `HEAD | `CONNECT | `TRACE -> false
+    | `DELETE | `POST | `PUT | `PATCH | `OPTIONS | `Other _ -> true
+
   let compare (a : t) (b : t) = Stdlib.compare a b
   let pp fmt t = Format.fprintf fmt "%s" (to_string t)
 end
@@ -792,10 +797,7 @@ module Request = struct
 
   (* Defined for method types in RFC7231 *)
   let has_body req =
-    match req.meth with
-    | `GET | `HEAD | `CONNECT | `TRACE -> `No
-    | `DELETE | `POST | `PUT | `PATCH | `OPTIONS | `Other _ ->
-        Transfer.has_body req.encoding
+    if Method.body_allowed req.meth then Transfer.has_body req.encoding else `No
 
   let make ?(meth = `GET) ?(version = `HTTP_1_1) ?(headers = Header.empty)
       ?scheme resource =

http/src/http.mli

@@ -21,6 +21,11 @@ module Method : sig
     | `Other of string ]
 
   val compare : t -> t -> int
+
+  val body_allowed : t -> bool
+  (** [body_allowed meth] returns whether [meth] allows a payload body to be
+      present per RFC7231. *)
+
   val of_string : string -> t
   val to_string : t -> string
   val pp : Format.formatter -> t -> unit