Better Request handling of transfer-encoding

CHANGES

@@ -15,6 +15,12 @@ New features and bug fixes:
   an override wasn't supplied, and to initialise a fresh Header value
   if none is present.
 * Do not override user-supplied headers in `post_form` or `redirect`.
+* `Request.has_body` does not permit a body to be set for methods that
+  RFC7231 forbids from having one (`HEAD`, `GET` and `DELETE`).
+* `Request.make` does not inject a `transfer-encoding` header if there
+  is no body present in the request (#246).
+* `Server.respond` no longer overrides user-supplied headers that
+  specify the `content-length` or `transfer-encoding` headers (#268).
 
 0.15.2 (2015-02-15):
 * When transfer encoding is unknown, read until EOF when body size is unknown. (#241)

Makefile

@@ -42,3 +42,11 @@ generate:
 clean:
 	ocamlbuild -clean
 	rm -f setup.data setup.log setup.bin
+
+revdep:
+	opam switch system || true
+	opam switch remove -y cohttp-revdeps || true
+	opam switch -A system cohttp-revdeps
+	opam pin -y add cohttp .
+	for i in `opam list -s --rec --depends-on=cohttp`; do opam install -y -j 4 $$i; done
+	opam switch system

bin/cohttp_proxy_lwt.ml

@@ -25,25 +25,40 @@ open Cohttp_lwt_unix
 
 let handler ~verbose (ch,conn) req body =
   let uri = Cohttp.Request.uri req in
-  let path = Uri.path uri in
   (* Log the request to the console *)
-  printf "%s %s %s\n%!"
+  if verbose then eprintf "--> %s %s %s\n%!"
     (Cohttp.(Code.string_of_method (Request.meth req)))
     (Uri.to_string uri)
-    (Sexplib.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch));
-  (* Fetch the URI *)
-  let headers = Request.headers req in
+    (Sexplib.Sexp.to_string_hum (Request.sexp_of_t req));
+  (* Strip out hop-by-hop connection headers *)
+  let headers =
+    Request.headers req |> fun h ->
+    Header.remove h "accept-encoding" |> fun h ->
+    Header.remove h "content-length" |> fun h ->
+    Header.remove h "transfer-encoding" |> fun h ->
+    Header.remove h "connection" |> fun h ->
+    Header.add h "accept-encoding" "identity"
+  in
+  (* Fetch the remote URI *)
   let meth = Request.meth req in
-  Client.call ~headers meth uri >>= fun (resp, body) ->
-  let headers = Response.headers resp in
+  Client.call ~headers ~body meth uri >>= fun (resp, body) ->
+  if verbose then
+    eprintf "<-- %s %s\n%!"
+      (Uri.to_string (Request.uri req))
+      (Sexplib.Sexp.to_string_hum (Response.sexp_of_t resp));
   let status = Response.status resp in
+  let headers =
+    Response.headers resp |> fun h ->
+    Header.remove h "transfer-encoding" |> fun h ->
+    Header.remove h "content-length" |> fun h ->
+    Header.remove h "connection"
+  in
   Server.respond ~headers ~status ~body ()
 
 let start_proxy port host verbose cert key () =
   printf "Listening for HTTP request on: %s %d\n%!" host port;
-  let info = sprintf "Served by Cohttp/Lwt listening on %s:%d" host port in
   let conn_closed (ch,conn) =
-    printf "connection %s closed\n%!"
+    printf "Connection %s closed\n%!"
       (Sexplib.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch)) in
   let callback = handler ~verbose in
   let config = Server.make ~callback ~conn_closed () in

lib/request.ml

@@ -119,7 +119,11 @@ module Make(IO : S.IO) = struct
       let encoding = Header.get_transfer_encoding headers in
       return (`Ok { headers; meth; uri; version; encoding })
 
-  let has_body req = Transfer.has_body req.encoding
+  (* Defined for method types in RFC7231 *)
+  let has_body req =
+    match req.meth with
+    | `GET | `HEAD | `DELETE -> `No
+    | `POST | `PUT | `PATCH | `OPTIONS | `Other _ -> Transfer.has_body req.encoding
 
   let make_body_reader req ic = Transfer_IO.make_reader req.encoding ic
   let read_body_chunk = Transfer_IO.read
@@ -136,7 +140,10 @@ module Make(IO : S.IO) = struct
                      | Some p -> ":" ^ string_of_int p
                      | None -> ""
                     ) in
-    let headers = Header.add_transfer_encoding headers req.encoding in
+    let headers =
+      match has_body req with
+      | `Yes | `Unknown -> Header.add_transfer_encoding headers req.encoding
+      | `No -> headers in
     IO.write oc fst_line >>= fun _ ->
     iter (IO.write oc) (Header.to_lines headers) >>= fun _ ->
     IO.write oc "\r\n"

lwt/cohttp_lwt.ml

@@ -298,7 +298,14 @@ module Make_server(IO:IO)
     Filename.concat docroot rel_path
 
   let respond ?headers ?(flush=true) ~status ~body () =
-    let encoding = Cohttp_lwt_body.transfer_encoding body in
+    let encoding = 
+      match headers with
+      | None -> Cohttp_lwt_body.transfer_encoding body
+      | Some headers ->
+         match Header.get_transfer_encoding headers with
+         | Transfer.Unknown -> Cohttp_lwt_body.transfer_encoding body
+         | t -> t
+    in
     let res = Response.make ~status ~flush ~encoding ?headers () in
     return (res, body)
 

lwt/cohttp_lwt.mli

@@ -181,7 +181,11 @@ module type Server = sig
   (** [respond ?headers ?flush ~status ~body] will respond to an HTTP
     request with the given [status] code and response [body].  If
     [flush] is true, then every response chunk will be flushed to
-    the network rather than being buffered. [flush] is true by default. *)
+    the network rather than being buffered. [flush] is true by default. 
+    The transfer encoding will be detected from the [body] value and
+    set to chunked encoding if it cannot be determined immediately.
+    You can override the encoding by supplying an appropriate [Content-length]
+    or [Transfer-encoding] in the [headers] parameter. *)
   val respond :
     ?headers:Cohttp.Header.t ->
     ?flush:bool ->

opam

@@ -33,7 +33,7 @@ depends: [
   "ocamlfind" {build}
   "cmdliner" {build & >= "0.9.4"}
   "re"
-  "uri" {>= "1.5.0"}
+  "uri" {>= "1.8.0"}
   "fieldslib" {>= "109.20.00"}
   "sexplib" {>= "109.53.00"}
   "conduit" {>= "0.7.0"}