From cdeed9091c552c771ebfbd7ac34f2a4d11a5e475 Mon Sep 17 00:00:00 2001 From: mefyl Date: Fri, 30 Jun 2023 14:46:34 +0200 Subject: [PATCH] Do not omit null content-length headers. Content-Length, even if null, is mandatory for unchunked request which method may allow a body. --- CHANGES.md | 2 + cohttp/src/request.ml | 6 +-- cohttp/test/dune | 2 +- cohttp/test/test_request.ml | 86 +++++++++++++++++++++++++++++++++++++ http/src/http.ml | 10 +++-- http/src/http.mli | 1 + 6 files changed, 99 insertions(+), 8 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 53c94d4e7a..815e433c1a 100644 --- a/CHANGES.md +++ b/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) diff --git a/cohttp/src/request.ml b/cohttp/src/request.ml index 4c4ab9ece4..f60fd00fbf 100644 --- a/cohttp/src/request.ml +++ b/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 diff --git a/cohttp/test/dune b/cohttp/test/dune index 4c7eac9c2e..617cd8d61a 100644 --- a/cohttp/test/dune +++ b/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) diff --git a/cohttp/test/test_request.ml b/cohttp/test/test_request.ml index d6e0f71675..28c734487e 100644 --- a/cohttp/test/test_request.ml +++ b/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", [ diff --git a/http/src/http.ml b/http/src/http.ml index 13d4a8bf6a..6301943fd6 100644 --- a/http/src/http.ml +++ b/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 = diff --git a/http/src/http.mli b/http/src/http.mli index 7e8be95a08..59bd6bd579 100644 --- a/http/src/http.mli +++ b/http/src/http.mli @@ -21,6 +21,7 @@ module Method : sig | `Other of string ] val compare : t -> t -> int + val body_allowed : t -> bool val of_string : string -> t val to_string : t -> string val pp : Format.formatter -> t -> unit