Merge pull request #778 from mseri/parser

cohttp.headers: use faster comparison

.github/workflows/workflow.yml

@@ -25,7 +25,7 @@ jobs:
  uses: actions/checkout@v2
 
  - name: Use OCaml ${{ matrix.ocaml-version }}
- uses: actions-ml/setup-ocaml@master
+ uses: ocaml/setup-ocaml@v2
  with:
  ocaml-version: ${{ matrix.ocaml-version }}
  opam-depext: false

CHANGES.md

@@ -8,11 +8,14 @@
  stack overflow happens in the XHR completion handler (mefyl #762).
 - lwt_jsoo: Add test suite (mefyl #764).
 
-- Cohttp.Header: new implementation (@lyrm #747)
+- Cohttp.Header: new implementation (lyrm #747)
 
  + New implementation of Header modules using an associative list instead of a map, with one major semantic change (function ```get```, see below), and some new functions (```clean_dup```, ```get_multi_concat```)
  + More Alcotest tests as well as fuzzing tests for this particular module.
 
+- Cohttp.Header: performance improvement (mseri, anuragsoni #778)
+ **Breaking** the headers are no-longer lowercased when parsed, the headers key comparison is case insensitive instead.
+
  ### Purpose
 
  The new header implementation uses an associative list instead of a map to represent headers and is focused on predictability and intuitivity: except for some specific and documented functions, the headers are always kept in transmission order, which makes debugging easier and is also important for [RFC7230§3.2.2](https://tools.ietf.org/html/rfc7230#section-3.2.2) that states that multiple values of a header must be kept in order.
@@ -38,6 +41,7 @@
 
  + ```clean_dup``` enables the user to clean headers that follows the {{:https://tools.ietf.org/html/rfc7230#section-3.2.2} RFC7230§3.2.2} (no duplicate, except ```set-cookie```)
  + ```get_multi_concat``` has been added to get a result similar to the previous ```get``` function.
+- Cohttp.Header: optimize internal of cohttp.headers (mseri #778)
 
 ## v4.0.0 (2021-03-24)
 

cohttp-lwt-unix/test/test_parser.ml

@@ -246,7 +246,7 @@ let make_simple_req () =
  let open Cohttp in
  let open Cohttp_lwt_unix in
  let expected =
- "POST /foo/bar HTTP/1.1\r\nfoo: bar\r\nhost: localhost\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

cohttp/fuzz/fuzz_header.ml

@@ -189,10 +189,9 @@ let is_empty_test () =
 let init_with_test () =
  Crowbar.(
  (* FS *)
- (* forall k v. to_list (init_with k v) = [String.lowercase k, v] *)
+ (* forall k v. to_list (init_with k v) = [k, v] *)
  add_test ~name:"[init_list k v] is [k, v]" [ header_name_gen; word_gen ]
- (fun k v ->
- check_eq H.(to_list (init_with k v)) [ (String.lowercase_ascii k, v) ]))
+ (fun k v -> check_eq H.(to_list (init_with k v)) [ (k, v) ]))
 
 let mem_test () =
  Crowbar.(
@@ -201,12 +200,16 @@ let mem_test () =
  add_test ~name:"[mem h k] on an empty header is always false"
  [ header_name_gen ] (fun k -> check_eq false H.(mem (init ()) k));
  (* SI *)
- (* forall h, k. H.mem h k = List.(mem_assoc k (H.to_list h)) *)
+ (* forall h, k. H.mem h k = List.(mem_assoc (String.lowercase_ascii x) (List.map (fun (k, v) -> String.lowercase_ascii k, v) (H.to_list h))) *)
  add_test ~name:"Header.mem has the same behavior than List.mem_assoc"
  [ headers_gen; header_name_gen ] (fun h k ->
  check_eq
  H.(mem h k)
- List.(mem_assoc (String.lowercase_ascii k) (H.to_list h))))
+ List.(
+ mem_assoc (String.lowercase_ascii k)
+ (List.map
+ (fun (k, v) -> (String.lowercase_ascii k, v))
+ (H.to_list h)))))
 
 let add_test () =
  Crowbar.(
@@ -220,9 +223,7 @@ let add_test () =
  (* forall h, k, v. to_list (add h k v) = to_list h @ [lowercase k, v] *)
  ~name:"[add] adds a value at the header end"
  [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
- check_eq
- (H.to_list h @ [ (String.lowercase_ascii k, v) ])
- H.(to_list (add h k v))))
+ check_eq (H.to_list h @ [ (k, v) ]) H.(to_list (add h k v))))
 
 let to_list_of_list_test () =
  Crowbar.(

cohttp/src/header.ml

@@ -16,36 +16,37 @@
  *
  }}}*)
 
-module LString : sig
- type t
-
- val of_string : string -> t
- val to_string : t -> string
- val compare : t -> t -> int
-end = struct
- type t = string
-
- let of_string x = String.lowercase_ascii x
- let to_string x = x
- let compare a b = String.compare a b
-end
-
-type t = (LString.t * string) list
+let caseless_equal a b =
+ if a == b then true
+ else
+ let len = String.length a in
+ len = String.length b
+ &&
+ let stop = ref false in
+ let idx = ref 0 in
+ while (not !stop) && !idx < len do
+ let c1 = String.unsafe_get a !idx in
+ let c2 = String.unsafe_get b !idx in
+ if Char.lowercase_ascii c1 <> Char.lowercase_ascii c2 then stop := true;
+ incr idx
+ done;
+ not !stop
+
+type t = (string * string) list
 
 let compare = Stdlib.compare
 let init () = []
 let is_empty = function [] -> true | _ -> false
-let init_with k v = [ (LString.of_string k, v) ]
+let init_with k v = [ (k, v) ]
 
 let mem h k =
- let k = LString.of_string k in
  let rec loop = function
  | [] -> false
- | (k', _) :: h' -> if LString.compare k k' = 0 then true else loop h'
+ | (k', _) :: h' -> if caseless_equal k k' then true else loop h'
  in
  loop h
 
-let add h k v : t = (LString.of_string k, v) :: h
+let add h k v : t = (k, v) :: h
 let add_list h l = List.fold_left (fun h (k, v) -> add h k v) h l
 let add_multi h k l = List.fold_left (fun h v -> add h k v) h l
 
@@ -58,11 +59,10 @@ let add_opt_unless_exists h k v =
  match h with None -> init_with k v | Some h -> add_unless_exists h k v
 
 let get h k =
- let k = LString.of_string k in
  let rec loop h =
  match h with
  | [] -> None
- | (k', v) :: h' -> if LString.compare k k' = 0 then Some v else loop h'
+ | (k', v) :: h' -> if caseless_equal k k' then Some v else loop h'
  in
  loop h
 
@@ -71,36 +71,32 @@ let get_multi (h : t) (k : string) =
  match h with
  | [] -> acc
  | (k', v) :: h' ->
- if LString.compare (LString.of_string k) k' = 0 then loop h' (v :: acc)
- else loop h' acc
+ if caseless_equal k k' then loop h' (v :: acc) else loop h' acc
  in
  loop h []
 
 let remove h k =
- let k = LString.of_string k in
  let rec loop seen = function
  | [] -> if seen then [] else raise Not_found
- | (k', _) :: h when LString.compare k k' = 0 -> loop true h
+ | (k', _) :: h when caseless_equal k k' -> loop true h
  | x :: h -> x :: loop seen h
  in
  try loop false h with Not_found -> h
 
 let remove_last h k =
- let k = LString.of_string k in
  let rec loop seen = function
  | [] -> raise Not_found
- | (k', _) :: h when LString.compare k k' = 0 -> h
+ | (k', _) :: h when caseless_equal k k' -> h
  | x :: h -> x :: loop seen h
  in
  try loop false h with Not_found -> h
 
 let replace_ last h k v =
- let k' = LString.of_string k in
  let rec loop seen = function
  | [] -> if seen then [] else raise Not_found
- | (k'', _) :: h when LString.compare k' k'' = 0 ->
+ | (k'', _) :: h when caseless_equal k k'' ->
  if last then (k'', v) :: h
- else if not seen then (k', v) :: loop true h
+ else if not seen then (k, v) :: loop true h
  else loop seen h
  | x :: h -> x :: loop seen h
  in
@@ -129,33 +125,26 @@ let update_all h k f =
 let map (f : string -> string -> string) (h : t) : t =
  List.map
  (fun (k, v) ->
- let vs' = f (LString.to_string k) v in
+ let vs' = f k v in
  (k, vs'))
  h
 
 let iter (f : string -> string -> unit) (h : t) : unit =
- List.iter (fun (k, v) -> f (LString.to_string k) v) h
+ List.iter (fun (k, v) -> f k v) h
 
 let fold (f : string -> string -> 'a -> 'a) (h : t) (init : 'a) : 'a =
- List.fold_left (fun acc (k, v) -> f (LString.to_string k) v acc) init h
-
-let of_list h =
- List.fold_left (fun acc (k, v) -> (LString.of_string k, v) :: acc) [] h
+ List.fold_left (fun acc (k, v) -> f k v acc) init h
 
-let to_list h =
- List.fold_left (fun acc (k, v) -> (LString.to_string k, v) :: acc) [] h
+let of_list h = List.rev h
+let to_list h = List.rev h
 
 let to_lines (h : t) =
  let header_line k v = Printf.sprintf "%s: %s\r\n" k v in
- List.fold_left
- (fun acc (k, v) -> header_line (LString.to_string k) v :: acc)
- [] h
+ List.fold_left (fun acc (k, v) -> header_line k v :: acc) [] h
 
 let to_frames h =
  let to_frame k v = Printf.sprintf "%s: %s" k v in
- List.fold_left
- (fun acc (k, v) -> to_frame (LString.to_string k) v :: acc)
- [] h
+ List.fold_left (fun acc (k, v) -> to_frame k v :: acc) [] h
 
 let to_string h =
  let b = Buffer.create 128 in
@@ -169,56 +158,55 @@ let to_string h =
  Buffer.contents b
 
 let headers_with_list_values =
- Array.map LString.of_string
- [|
- "accept";
- "accept-charset";
- "accept-encoding";
- "accept-language";
- "accept-ranges";
- "allow";
- "cache-control";
- "connection";
- "content-encoding";
- "content-language";
- "expect";
- "if-match";
- "if-none-match";
- "link";
- "pragma";
- "proxy-authenticate";
- "te";
- "trailer";
- "transfer-encoding";
- "upgrade";
- "vary";
- "via";
- "warning";
- "www-authenticate";
- |]
+ [|
+ "accept";
+ "accept-charset";
+ "accept-encoding";
+ "accept-language";
+ "accept-ranges";
+ "allow";
+ "cache-control";
+ "connection";
+ "content-encoding";
+ "content-language";
+ "expect";
+ "if-match";
+ "if-none-match";
+ "link";
+ "pragma";
+ "proxy-authenticate";
+ "te";
+ "trailer";
+ "transfer-encoding";
+ "upgrade";
+ "vary";
+ "via";
+ "warning";
+ "www-authenticate";
+ |]
 
 let is_header_with_list_value =
  let tbl = Hashtbl.create (Array.length headers_with_list_values) in
  headers_with_list_values |> Array.iter (fun h -> Hashtbl.add tbl h ());
  fun h -> Hashtbl.mem tbl h
 
-let is_set_cookie k = LString.(compare k (of_string "set-cookie"))
+let is_set_cookie k = caseless_equal k "set-cookie"
 
 (* set-cookie is an exception according to
  {{:https://tools.ietf.org/html/rfc7230#section-3.2.2}
- RFC7230§3.2.2} and can appear multiple times in a response message.
+  RFC7230§3.2.2} and can appear multiple times in a response message.
 *)
 let clean_dup (h : t) : t =
  let add h k v =
- if is_set_cookie k = 0 then (k, v) :: h
+ if is_set_cookie k then (k, v) :: h
  else
  let to_add = ref false in
  let rec loop = function
  | [] ->
  to_add := true;
  []
  | (k', v') :: hs ->
- if LString.compare k k' = 0 then
+ if caseless_equal k k' then
  if is_header_with_list_value k then (k, v' ^ "," ^ v) :: hs
  else (
  to_add := true;
@@ -231,8 +219,7 @@ let clean_dup (h : t) : t =
  List.rev h |> List.fold_left (fun acc (k, v) -> add acc k v) []
 
 let get_multi_concat ?(list_value_only = false) h k : string option =
- if (not list_value_only) || is_header_with_list_value (LString.of_string k)
- then
+ if (not list_value_only) || is_header_with_list_value k then
  let vs = get_multi h k in
  match vs with [] -> None | _ -> Some (String.concat "," vs)
  else get h k

cohttp/src/header.mli

@@ -32,7 +32,8 @@ val of_list : (string * string) list -> t
  is true with case insensitive comparison. *)
 
 val to_list : t -> (string * string) list
-(** [to_list h] converts HTTP headers [h] to a list. Order is preserved.
+(** [to_list h] converts HTTP headers [h] to a list. Order and case is
+ preserved.
 
  {e Invariant (with case insensitive comparison):} [to_list (of_list l) = l] *)
 

cohttp/test/unitary_test_header.ml

@@ -58,7 +58,7 @@ let is_empty_tests () =
 
 let init_with_tests () =
  aessl "init_with k v"
- [ ("transfer-encoding", "chunked") ]
+ [ ("traNsfer-eNcoding", "chunked") ]
  H.(to_list (init_with "traNsfer-eNcoding" "chunked"))
 
 let mem_tests () =