diff --git a/CHANGES b/CHANGES index cd8fedd7fd..793b655e4a 100644 --- a/CHANGES +++ b/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) diff --git a/Makefile b/Makefile index 046b547b8b..67b53bb999 100644 --- a/Makefile +++ b/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 diff --git a/bin/cohttp_proxy_lwt.ml b/bin/cohttp_proxy_lwt.ml index 5c116c001d..919db01d17 100644 --- a/bin/cohttp_proxy_lwt.ml +++ b/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 diff --git a/lib/request.ml b/lib/request.ml index dca4a32e97..2f9b64367a 100644 --- a/lib/request.ml +++ b/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" diff --git a/lwt/cohttp_lwt.ml b/lwt/cohttp_lwt.ml index 10dbe5b215..fa1b02d25d 100644 --- a/lwt/cohttp_lwt.ml +++ b/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) diff --git a/lwt/cohttp_lwt.mli b/lwt/cohttp_lwt.mli index f7681188a6..8809508a38 100644 --- a/lwt/cohttp_lwt.mli +++ b/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 -> diff --git a/opam b/opam index ba0d2d9cd4..1cd4beef16 100644 --- a/opam +++ b/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"}