diff --git a/CHANGES.md b/CHANGES.md index 9f24bdf6b..755043c83 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -3,6 +3,7 @@ - cohttp-lwt: Do not leak exceptions to `Lwt.async_exception_hook`. (mefyl #992, #995) ## v6.0.0~alpha2 (2023-07-1) +- http.header, cohttp, cohttp-eio: remove "first" and "move_to_first" and the special treatment of the "host" header (mseri #988) - http.header: introduce "iter_ord" to guarantee iteration following the order of the entries in the headers (mseri #986) - http.header: fix "move_to_fist" and "first" ro follow Header's semantics (mseri #986) - cohttp: ensure "host" is the first header (mseri #986) diff --git a/cohttp-eio/src/client.ml b/cohttp-eio/src/client.ml index a9942f1ef..85daa7560 100644 --- a/cohttp-eio/src/client.ml +++ b/cohttp-eio/src/client.ml @@ -41,7 +41,6 @@ let write_request pipeline_requests request writer body = body in let headers = Http.Header.clean_dup headers in - let headers = Http.Header.Private.move_to_front headers "Host" in let meth = Http.Method.to_string @@ Http.Request.meth request in let version = Http.Version.to_string @@ Http.Request.version request in Buf_write.string writer meth; diff --git a/cohttp-eio/tests/client.md b/cohttp-eio/tests/client.md index 952078530..55d2c6218 100644 --- a/cohttp-eio/tests/client.md +++ b/cohttp-eio/tests/client.md @@ -44,8 +44,8 @@ GET method request: |> Client.read_fixed |> print_string);; +socket: wrote "GET / HTTP/1.1\r\n" -+ "Host: localhost\r\n" + "Accept: application/json\r\n" ++ "Host: localhost\r\n" + "User-Agent: cohttp-eio\r\n" + "TE: trailers\r\n" + "Connection: TE\r\n" @@ -82,9 +82,9 @@ POST request: |> Client.read_fixed |> print_string);; +socket: wrote "POST /post HTTP/1.1\r\n" -+ "Host: localhost\r\n" + "Accept: application/json\r\n" + "Content-Length: 12\r\n" ++ "Host: localhost\r\n" + "User-Agent: cohttp-eio\r\n" + "TE: trailers\r\n" + "Connection: TE\r\n" @@ -158,10 +158,10 @@ Chunk request: |> Client.read_fixed |> print_string);; +socket: wrote "POST /handle_chunk HTTP/1.1\r\n" -+ "Host: localhost\r\n" + "Transfer-Encoding: chunked\r\n" + "Content-Type: text/plain\r\n" + "Trailer: Expires, Header1\r\n" ++ "Host: localhost\r\n" + "User-Agent: cohttp-eio\r\n" + "TE: trailers\r\n" + "Connection: TE\r\n" diff --git a/cohttp-lwt-unix/test/test_parser.ml b/cohttp-lwt-unix/test/test_parser.ml index ecd7ec6f6..05af2d559 100644 --- a/cohttp-lwt-unix/test/test_parser.ml +++ b/cohttp-lwt-unix/test/test_parser.ml @@ -270,7 +270,7 @@ let make_simple_req () = let open Cohttp in let open Cohttp_lwt_unix in let expected = - "POST /foo/bar HTTP/1.1\r\nhost: localhost\r\nFoo: bar\r\nuser-agent: " + "POST /foo/bar HTTP/1.1\r\nFoo: bar\r\nhost: localhost\r\nuser-agent: " ^ user_agent ^ "\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n" in @@ -285,7 +285,7 @@ let mutate_simple_req () = let open Cohttp in let open Cohttp_lwt_unix in let expected = - "POST /foo/bar HTTP/1.1\r\nhost: localhost\r\nfoo: bar\r\nuser-agent: " + "POST /foo/bar HTTP/1.1\r\nfoo: bar\r\nhost: localhost\r\nuser-agent: " ^ user_agent ^ "\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n" in diff --git a/cohttp/src/request.ml b/cohttp/src/request.ml index 96a251932..f60fd00fb 100644 --- a/cohttp/src/request.ml +++ b/cohttp/src/request.ml @@ -61,7 +61,6 @@ let make ?(meth = `GET) ?(version = `HTTP_1_1) ?(encoding = Transfer.Unknown) ^ match Uri.port uri with Some p -> ":" ^ string_of_int p | None -> "")) in - let headers = Header.Private.move_to_front headers "host" in let headers = Header.add_unless_exists headers "user-agent" Header.user_agent in @@ -204,7 +203,6 @@ module Make (IO : S.IO) = struct Header.add_transfer_encoding headers req.encoding else headers in - let headers = Header.Private.move_to_front headers "host" in IO.write oc fst_line >>= fun _ -> Header_IO.write headers oc let make_body_writer ?flush req oc = diff --git a/cohttp/test/test_request.ml b/cohttp/test/test_request.ml index bc999c22c..0b02feff0 100644 --- a/cohttp/test/test_request.ml +++ b/cohttp/test/test_request.ml @@ -321,8 +321,8 @@ let null_content_length_header () = 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\ + host: someuri.com\r\n\ content-length: 0\r\n\ \r\n" (Buffer.to_string output) diff --git a/http/src/http.ml b/http/src/http.ml index 6968ed192..f2139d4c0 100644 --- a/http/src/http.ml +++ b/http/src/http.ml @@ -14,51 +14,56 @@ module Transfer = struct end module Header = struct - external string_unsafe_get64 : string -> int -> int64 = "%caml_string_get64u" + module Private = struct + external string_unsafe_get64 : string -> int -> int64 + = "%caml_string_get64u" - (* [caseless_equal a b] must be equivalent to - [String.equal (String.lowercase_ascii a) (String.lowercase_ascii b)]. *) - let caseless_equal a b = - if a == b then true - else - let len = String.length a in - len = String.length b - (* Note: at this point we konw that [a] and [b] have the same length. *) - && - (* [word_loop a b i len] compares strings [a] and [b] from - offsets [i] (included) to [len] (excluded), one word at a time. - [i] is a world-aligned index into the strings. - *) - let rec word_loop a b i len = - if i = len then true - else - let i' = i + 8 in - (* If [i' > len], what remains to be compared is strictly - less than a word long, use byte-per-byte comparison. *) - if i' > len then byte_loop a b i len - else if string_unsafe_get64 a i = string_unsafe_get64 b i then - word_loop a b i' len - else - (* If the words at [i] differ, it may due to a case - difference; we check the individual bytes of this - work, and then we continue checking the other - words. *) - byte_loop a b i i' && word_loop a b i' len - (* [byte_loop a b i len] compares the strings [a] and [b] from - offsets [i] (included) to [len] (excluded), one byte at - a time. - - This function assumes that [i < len] holds -- its only called - by [word_loop] when this is known to hold. *) - and byte_loop a b i len = - let c1 = String.unsafe_get a i in - let c2 = String.unsafe_get b i in - Char.lowercase_ascii c1 = Char.lowercase_ascii c2 + (* [caseless_equal a b] must be equivalent to + [String.equal (String.lowercase_ascii a) (String.lowercase_ascii b)]. *) + let caseless_equal a b = + if a == b then true + else + let len = String.length a in + len = String.length b + (* Note: at this point we konw that [a] and [b] have the same length. *) && - let i' = i + 1 in - i' = len || byte_loop a b i' len - in - word_loop a b 0 len + (* [word_loop a b i len] compares strings [a] and [b] from + offsets [i] (included) to [len] (excluded), one word at a time. + [i] is a world-aligned index into the strings. + *) + let rec word_loop a b i len = + if i = len then true + else + let i' = i + 8 in + (* If [i' > len], what remains to be compared is strictly + less than a word long, use byte-per-byte comparison. *) + if i' > len then byte_loop a b i len + else if string_unsafe_get64 a i = string_unsafe_get64 b i then + word_loop a b i' len + else + (* If the words at [i] differ, it may due to a case + difference; we check the individual bytes of this + work, and then we continue checking the other + words. *) + byte_loop a b i i' && word_loop a b i' len + (* [byte_loop a b i len] compares the strings [a] and [b] from + offsets [i] (included) to [len] (excluded), one byte at + a time. + + This function assumes that [i < len] holds -- its only called + by [word_loop] when this is known to hold. *) + and byte_loop a b i len = + let c1 = String.unsafe_get a i in + let c2 = String.unsafe_get b i in + Char.lowercase_ascii c1 = Char.lowercase_ascii c2 + && + let i' = i + 1 in + i' = len || byte_loop a b i' len + in + word_loop a b 0 len + end + + let caseless_equal = Private.caseless_equal type t = (string * string) list @@ -103,8 +108,6 @@ module Header = struct in loop h - let first t = match t with [] -> None | (k, v) :: _ -> Some (k, v) - let get_multi (h : t) (k : string) = let rec loop h acc = match h with @@ -161,22 +164,6 @@ module Header = struct let h = remove h k in add_multi h k xs - let move_to_front t hdr_name = - (* Headers are manipulated in reverse order for convenience, so we - need to reverse them, prepend what we need, and reverse again *) - let t = List.rev t in - let t = - match t with - | (k, _) :: _ when caseless_equal k hdr_name -> t - | _ -> ( - match get t hdr_name with - | Some v -> - let headers = remove t hdr_name in - add headers hdr_name v - | None -> t) - in - List.rev t - let map (f : string -> string -> string) (h : t) : t = List.map (fun (k, v) -> @@ -186,7 +173,7 @@ module Header = struct let iter_ord (f : string -> string -> unit) (h : t) : unit = List.iter (fun (k, v) -> f k v) (List.rev h) - + let iter (f : string -> string -> unit) (h : t) : unit = List.iter (fun (k, v) -> f k v) h @@ -355,12 +342,6 @@ module Header = struct | Some v when v = "close" -> Some `Close | Some x -> Some (`Unknown x) | _ -> None - - module Private = struct - let caseless_equal = caseless_equal - let first l = first (List.rev l) - let move_to_front = move_to_front - end end module Status = struct diff --git a/http/src/http.mli b/http/src/http.mli index 45eb019fd..82f5d1ef9 100644 --- a/http/src/http.mli +++ b/http/src/http.mli @@ -309,11 +309,12 @@ module Header : sig [h] is returned unchanged. *) val iter_ord : (string -> string -> unit) -> t -> unit - (** [iter_ord f h] applies [f] to all the headers of [h] following the header order. *) - + (** [iter_ord f h] applies [f] to all the headers of [h] following the header + order. *) + val iter : (string -> string -> unit) -> t -> unit - (** [iter f h] applies [f] to all the headers of [h] following an unspecified order. - This function is faster than iter_ord. *) + (** [iter f h] applies [f] to all the headers of [h] following an unspecified + order. This function is faster than iter_ord. *) val map : (string -> string -> string) -> t -> t val fold : (string -> string -> 'a -> 'a) -> t -> 'a -> 'a @@ -377,15 +378,6 @@ module Header : sig val caseless_equal : string -> string -> bool (** [caseless_equal a b] must be equivalent to [String.equal (String.lowercase_ascii a) (String.lowercase_ascii b)]. *) - - val first : t -> (string * string) option - (** [first t] is [Some (hdr_name, hdr_value)], which represents the first - header in headers list [t]. It is [None] if [t] is empty. *) - - val move_to_front : t -> string -> t - (** [move_to_front t hdr_name] is [t] with header name [hdr_name] moved to - the front of the headers list [t]. If the header doesn't exist in [t] or - the header is already at the front, then [t] is unchanged. *) end end diff --git a/http/test/test_header.ml b/http/test/test_header.ml index 9f358ba85..7b164df9f 100644 --- a/http/test/test_header.ml +++ b/http/test/test_header.ml @@ -167,24 +167,6 @@ let replace_tests () = ] H.(to_list (replace prebuilt "accept" "text/*")) -let move_to_front_tests () = - let headers1 = [ ("accept", "text/*"); ("Host", "www.example.com") ] in - let headers2 = - [ - ("content-length", "23"); ("Host", "www.example.com"); ("accept", "text/*"); - ] - in - aeso {|move_to_front h "Host"|} (Some "Host") - (H.(Private.move_to_front (H.of_list headers1) "Host" |> Private.first) - |> function - | Some (k, _) -> Some k - | None -> Some ""); - aeso {|move_to_front h "Host"|} (Some "Host") - (H.(Private.move_to_front (H.of_list headers2) "Host" |> Private.first) - |> function - | Some (k, _) -> Some k - | None -> Some "") - let h = H.init () |> fun h -> H.add h "first" "1" |> fun h -> @@ -398,7 +380,6 @@ let tests = ("Header.iter", `Quick, iter_tests); ("Header.update", `Quick, update_tests); ("Header.update_all", `Quick, update_all_tests); - ("Header.move_to_front", `Quick, move_to_front_tests); ("many headers", `Slow, many_headers); ("transfer encoding is in correct order", `Quick, transfer_encoding_tests); ]