From fcff6d387209273cff113a1ddf85ca2af6a8e309 Mon Sep 17 00:00:00 2001 From: Bikal Lem Date: Wed, 8 Jun 2022 13:44:53 +0100 Subject: [PATCH 1/8] http: add Request.make Add `Request.make` so that we don't have to adorn `[@warning "-3"]` when creating `Request.t`. --- CHANGES.md | 1 + http/src/http.ml | 13 +++++++------ http/src/http.mli | 28 ++++++++++++++++++++++------ 3 files changed, 30 insertions(+), 12 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 98a35d7d15..6c7689f64c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,5 @@ ## Unreleased +- http: add Http.Request.make (bikallem #878) - http: add pretty printer functions (bikallem #880) - New eio based client and server on top of the http library (bikallem #857) - New curl based clients (rgrinberg #813) diff --git a/http/src/http.ml b/http/src/http.ml index a5f0fedc7a..aba1d71501 100644 --- a/http/src/http.ml +++ b/http/src/http.ml @@ -763,6 +763,11 @@ module Request = struct | `DELETE | `POST | `PUT | `PATCH | `OPTIONS | `Other _ -> Transfer.has_body req.encoding + let make ?(meth = `GET) ?(version = `HTTP_1_1) ?(headers = Header.empty) + ?scheme resource = + let encoding = Header.get_transfer_encoding headers in + { headers; meth; scheme; resource; version; encoding } + let pp fmt t = let open Format in pp_open_vbox fmt 0; @@ -800,12 +805,8 @@ module Response = struct | i -> i let make ?(version = `HTTP_1_1) ?(status = `OK) ?(flush = false) - ?(encoding = Transfer.Chunked) ?(headers = Header.empty) () = - let encoding = - match Header.get_transfer_encoding headers with - | Transfer.(Chunked | Fixed _) as enc -> enc - | Unknown -> encoding - in + ?(headers = Header.empty) () = + let encoding = Header.get_transfer_encoding headers in { encoding; headers; version; flush; status } let headers t = t.headers diff --git a/http/src/http.mli b/http/src/http.mli index 48ca971643..705477aabd 100644 --- a/http/src/http.mli +++ b/http/src/http.mli @@ -349,7 +349,12 @@ module Header : sig val get_content_range : t -> Int64.t option val get_connection_close : t -> bool + val get_transfer_encoding : t -> Transfer.encoding + (** [get_transfer_encoding h] checks the "content-length", "content-range" and + "transfer-encoding" headers to infer the transfer encoding. Uses Unknown + if nothing is found.*) + val add_transfer_encoding : t -> Transfer.encoding -> t val connection : t -> [ `Keep_alive | `Close | `Unknown of string ] option val get_location : t -> string option @@ -387,6 +392,19 @@ module Request : sig val is_keep_alive : t -> bool (** Return true whether the connection should be reused *) + val make : + ?meth:Method.t -> + ?version:Version.t -> + ?headers:Header.t -> + ?scheme:string -> + string -> + t + (** [make resource] is a value of {!type:t}. The default values for the + response, if not specified, are as follows: [meth] is [`GET], [version] is + [`HTTP_1_1], [headers] is [Header.empty] and [scheme] is [None]. The + request encoding value is determined via the + [Header.get_transfer_encoding] function.*) + val pp : Format.formatter -> t -> unit end @@ -423,15 +441,13 @@ module Response : sig ?version:Version.t -> ?status:Status.t -> ?flush:bool -> - ?encoding:Transfer.encoding -> ?headers:Header.t -> unit -> t - (** The response creates by [make ~encoding ~headers ()] has an encoding value - determined from the content of [headers] or if no proper header is - present, using the value of [encoding]. Checked headers are - "content-length", "content-range" and "transfer-encoding". The default - value of [encoding] is chunked. *) + (** [make ()] is a value of {!type:t}. The default values for the request, if + not specified, are: [status] is [`Ok], [version] is [`HTTP_1_1], [flush] + is [false] and [headers] is [Header.empty]. The request encoding value is + determined via the [Header.get_transfer_encoding] function. *) val pp : Format.formatter -> t -> unit end From 2fd192f30c8c32315794a0f012bba040b2ea003c Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 9 Jun 2022 15:04:22 +0200 Subject: [PATCH 2/8] cohttp: update request and responses in a retrocompatible way When doing this update, I realized that our responses are in general not compliant with the standard since https://tools.ietf.org/html/rfc7230#section-3.3.1 A server MUST NOT send a Transfer-Encoding header field in any response with a status code of 1xx (Informational) or 204 (No Content). A server MUST NOT send a Transfer-Encoding header field in any 2xx (Successful) response to a CONNECT request (Section 4.3.6 of [RFC7231]). But we add `transfer-encoding: unknown` to those responses (I am actually surprised that 304 is not part of those). Signed-off-by: Marcello Seri --- cohttp/src/request.ml | 27 ++++++++++----------------- cohttp/src/response.ml | 4 ++-- cohttp/src/s.ml | 15 ++++++++++----- 3 files changed, 22 insertions(+), 24 deletions(-) diff --git a/cohttp/src/request.ml b/cohttp/src/request.ml index c7f1ab40fa..33b800da3b 100644 --- a/cohttp/src/request.ml +++ b/cohttp/src/request.ml @@ -49,15 +49,9 @@ let scheme t = t.scheme let resource t = t.resource let version t = t.version let encoding t = t.encoding -let fixed_zero = Transfer.Fixed Int64.zero -let guess_encoding ?(encoding = fixed_zero) headers = - match Header.get_transfer_encoding headers with - | Transfer.(Chunked | Fixed _) as enc -> enc - | Unknown -> encoding - -let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding ?headers uri = - let headers = match headers with None -> Header.init () | Some h -> h in +let make ?(meth = `GET) ?(version = `HTTP_1_1) ?(encoding = Transfer.Unknown) + ?(headers = Header.init ()) uri = let headers = Header.add_unless_exists headers "host" (match Uri.scheme uri with @@ -81,15 +75,14 @@ let make ?(meth = `GET) ?(version = `HTTP_1_1) ?encoding ?headers uri = Header.add_authorization headers auth | _, _, _ -> headers in - let encoding = guess_encoding ?encoding headers in - { - meth; - version; - headers; - scheme = Uri.scheme uri; - resource = Uri.path_and_query uri; - encoding; - } + let scheme = Uri.scheme uri in + let resource = Uri.path_and_query uri in + let encoding = + match Header.get_transfer_encoding headers with + | Transfer.Unknown -> encoding + | encoding -> encoding + in + { headers; meth; scheme; resource; version; encoding } let is_keep_alive t = Http.Request.is_keep_alive t diff --git a/cohttp/src/response.ml b/cohttp/src/response.ml index 6b3983fc33..ef1bf95086 100644 --- a/cohttp/src/response.ml +++ b/cohttp/src/response.ml @@ -49,8 +49,8 @@ let make ?(version = `HTTP_1_1) ?(status = `OK) ?(flush = false) ?(encoding = Transfer.Chunked) ?(headers = Header.init ()) () = let encoding = match Header.get_transfer_encoding headers with - | Transfer.(Chunked | Fixed _) as enc -> enc - | Unknown -> encoding + | Transfer.Unknown -> encoding + | encoding -> encoding in { encoding; headers; version; flush; status } diff --git a/cohttp/src/s.ml b/cohttp/src/s.ml index 42afe1847a..dbf59ebdad 100644 --- a/cohttp/src/s.ml +++ b/cohttp/src/s.ml @@ -108,6 +108,11 @@ module type Request = sig ?headers:Header.t -> Uri.t -> t + (** [make ()] is a value of {!type:t}. The default values for the request, if + not specified, are: [status] is [`Ok], [version] is [`HTTP_1_1], [flush] + is [false] and [headers] is [Header.empty]. The request encoding value is + determined via the [Header.get_transfer_encoding] function and, if not + found, uses the default value [Transfer.Fixed 0]. *) val is_keep_alive : t -> bool (** Return true whether the connection should be reused *) @@ -152,11 +157,11 @@ module type Response = sig ?headers:Header.t -> unit -> t - (** The response creates by [make ~encoding ~headers ()] has an encoding value - determined from the content of [headers] or if no proper header is - present, using the value of [encoding]. Checked headers are - "content-length", "content-range" and "transfer-encoding". The default - value of [encoding] is chunked. *) + (** [make ()] is a value of {!type:t}. The default values for the request, if + not specified, are: [status] is [`Ok], [version] is [`HTTP_1_1], [flush] + is [false] and [headers] is [Header.empty]. The request encoding value is + determined via the [Header.get_transfer_encoding] function and, if not + found, uses the default value [Transfer.Chunked]. *) end module type Body = sig From 918dfff8a9df39e2335585347db1c18bc18d8e2c Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Sun, 12 Jun 2022 19:53:36 +0200 Subject: [PATCH 3/8] cohttp-lwt-jsoo: adapt to new http constructors Signed-off-by: Marcello Seri --- cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml index 5ed8a9cb11..63f74ad911 100644 --- a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml @@ -229,7 +229,7 @@ module Make_client_async (P : Params) = Make_api (struct let response = Lwt.( Header_io.parse channel >|= fun resp_headers -> - Http.Response.make ~version:`HTTP_1_1 + Cohttp.Response.make ~version:`HTTP_1_1 ~status:(C.Code.status_of_code xml##.status) ~flush:false (* ??? *) ~encoding:(CLB.transfer_encoding body) From e89bd22262d85aa385fe5082e560fcf226e66991 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Sun, 12 Jun 2022 19:54:14 +0200 Subject: [PATCH 4/8] cohttp-lwt-unix: adapt to new http constructors Signed-off-by: Marcello Seri --- cohttp-lwt-unix/src/server.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cohttp-lwt-unix/src/server.ml b/cohttp-lwt-unix/src/server.ml index 1ec7f8a8ae..fc29ae42ed 100644 --- a/cohttp-lwt-unix/src/server.ml +++ b/cohttp-lwt-unix/src/server.ml @@ -50,7 +50,7 @@ let respond_file ?headers ~fname () = let headers = Http.Header.add_opt_unless_exists headers "content-type" mime_type in - let res = Http.Response.make ~status:`OK ~encoding ~headers () in + let res = Cohttp.Response.make ~status:`OK ~encoding ~headers () in Lwt.return (res, body)) (function | Unix.Unix_error (Unix.ENOENT, _, _) | Isnt_a_file -> From 106ccc8e787d30bac7b91293af89d4def9a6a15f Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Sun, 12 Jun 2022 20:00:01 +0200 Subject: [PATCH 5/8] cohttp-lwt-unix: fix test_sanity.exe In the absence of an encoding in the headers, Http.Response.Make now defaults to Unknown, which makes the system hang unable to decide how to get the body. Signed-off-by: Marcello Seri --- cohttp-lwt-unix/test/test_sanity.ml | 12 +++++++++--- cohttp-lwt-unix/test/test_sanity_noisy.ml | 2 +- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml index b8f185d119..059a2e6b7c 100644 --- a/cohttp-lwt-unix/test/test_sanity.ml +++ b/cohttp-lwt-unix/test/test_sanity.ml @@ -48,12 +48,18 @@ let server = (fun _ _ -> Lwt.return (`Expert - ( Http.Response.make (), - fun _ic oc -> Lwt_io.write oc "8\r\nexpert 1\r\n0\r\n\r\n" ))); + (let headers = + Http.( + Header.add_transfer_encoding (Header.init ()) Transfer.Chunked) + in + ( Http.Response.make ~headers (), + fun _ic oc -> Lwt_io.write oc "8\r\nexpert 1\r\n0\r\n\r\n" )))); (fun _ _ -> Lwt.return (`Expert - ( Http.Response.make (), + ( (* Alternatively, cohttp.response.make injects the Chunked encoding when no + encoding is already in the headers. *) + Cohttp.Response.make (), fun ic oc -> Lwt_io.write oc "8\r\nexpert 2\r\n0\r\n\r\n" >>= fun () -> Lwt_io.flush oc >>= fun () -> diff --git a/cohttp-lwt-unix/test/test_sanity_noisy.ml b/cohttp-lwt-unix/test/test_sanity_noisy.ml index 4504a3cd05..e1ffe3dab0 100644 --- a/cohttp-lwt-unix/test/test_sanity_noisy.ml +++ b/cohttp-lwt-unix/test/test_sanity_noisy.ml @@ -7,7 +7,7 @@ module Body = Cohttp_lwt.Body module IO = Cohttp_lwt_unix.Private.IO let chunk_body = [ "one"; ""; " "; "bar"; "" ] -let () = Logs.set_level (Some Info) +let () = Logs.set_level (Some Warning) let () = Logs.set_reporter Logs.nop_reporter let check_logs test () = From 1aa8b1f49e95c6622f6b6233fca08b317e16aa21 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Mon, 13 Jun 2022 08:31:00 +0200 Subject: [PATCH 6/8] cohttp-async: use the correct Response constructor Signed-off-by: Marcello Seri --- cohttp-async/src/server.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cohttp-async/src/server.ml b/cohttp-async/src/server.ml index b147369df1..b76a24bf39 100644 --- a/cohttp-async/src/server.ml +++ b/cohttp-async/src/server.ml @@ -94,7 +94,7 @@ let handle_client handle_request sock rd wr = let respond ?(flush = true) ?(headers = Http.Header.init ()) ?(body = `Empty) status : response Deferred.t = let encoding = Body.transfer_encoding body in - let resp = Http.Response.make ~status ~flush ~encoding ~headers () in + let resp = Cohttp.Response.make ~status ~flush ~encoding ~headers () in return (resp, body) let respond_with_pipe ?flush ?headers ?(code = `OK) body = From b8a188e3508c8116ecf989bdfc07917244868192 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 16 Jun 2022 10:00:41 +0200 Subject: [PATCH 7/8] cohttp-async: fix test_helper It needs to construct responses with the correct transfer-encoding. Signed-off-by: Marcello Seri --- test_helpers/cohttp_async_test/src/cohttp_async_test.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test_helpers/cohttp_async_test/src/cohttp_async_test.ml b/test_helpers/cohttp_async_test/src/cohttp_async_test.ml index 3d1d23bf02..7215983c2f 100644 --- a/test_helpers/cohttp_async_test/src/cohttp_async_test.ml +++ b/test_helpers/cohttp_async_test/src/cohttp_async_test.ml @@ -18,7 +18,7 @@ type async_test = unit -> unit io let response rsp = `Response rsp -let expert ?(rsp = Http.Response.make ()) f _req _body = +let expert ?(rsp = Cohttp.Response.make ()) f _req _body = return (`Expert (rsp, f)) let const rsp _req _body = rsp >>| response From d1b57c74d22c01872293f41a3b1bed96c88cb46c Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 16 Jun 2022 10:03:18 +0200 Subject: [PATCH 8/8] cohttp-lwt-unix: revert spurious change in test_sanity_noisy --- cohttp-lwt-unix/test/test_sanity_noisy.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cohttp-lwt-unix/test/test_sanity_noisy.ml b/cohttp-lwt-unix/test/test_sanity_noisy.ml index e1ffe3dab0..4504a3cd05 100644 --- a/cohttp-lwt-unix/test/test_sanity_noisy.ml +++ b/cohttp-lwt-unix/test/test_sanity_noisy.ml @@ -7,7 +7,7 @@ module Body = Cohttp_lwt.Body module IO = Cohttp_lwt_unix.Private.IO let chunk_body = [ "one"; ""; " "; "bar"; "" ] -let () = Logs.set_level (Some Warning) +let () = Logs.set_level (Some Info) let () = Logs.set_reporter Logs.nop_reporter let check_logs test () =