From 493a9463ecf63536d6c8b0b358b07d26060cf191 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Tue, 2 Feb 2021 17:15:03 +0100
Subject: [PATCH 01/14] New implementation of the headers using an associative
 list instead of a map.

---
 cohttp-async/bin/cohttp_curl_async.ml  |   5 +-
 cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml |  13 +-
 cohttp/src/header.ml                   | 233 +++++++++++++++----------
 cohttp/src/header.mli                  |  94 ++++++----
 cohttp/src/header_io.ml                |   8 +-
 5 files changed, 206 insertions(+), 147 deletions(-)

diff --git a/cohttp-async/bin/cohttp_curl_async.ml b/cohttp-async/bin/cohttp_curl_async.ml
index 044e38d316..cb9ef577c6 100644
--- a/cohttp-async/bin/cohttp_curl_async.ml
+++ b/cohttp-async/bin/cohttp_curl_async.ml
@@ -19,10 +19,7 @@ open Async_kernel
 open Cohttp_async
 
 let show_headers h =
-  Cohttp.Header.iter
-    (fun k v ->
-      List.iter v ~f:(fun v_i -> Logs.info (fun m -> m "%s: %s%!" k v_i)))
-    h
+  Cohttp.Header.iter (fun k v -> Logs.info (fun m -> m "%s: %s%!" k v)) h
 
 let make_net_req uri meth' body () =
   let meth = Cohttp.Code.method_of_string meth' in
diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml
index 7566f39f9b..56d2921c8b 100644
--- a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml
+++ b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml
@@ -182,9 +182,7 @@ module Make_client_async (P : Params) = Make_api (struct
             (fun k v ->
               (* some headers lead to errors in the javascript console, should
                  we filter then out here? *)
-              List.iter
-                (fun v -> xml ## (setRequestHeader (Js.string k) (Js.string v)))
-                v)
+              xml ## (setRequestHeader (Js.string k) (Js.string v)))
             headers
     in
 
@@ -278,12 +276,9 @@ module Make_client_sync (P : Params) = Make_api (struct
       | Some headers ->
           C.Header.iter
             (fun k v ->
-              List.iter
-                (* some headers lead to errors in the javascript console, should
-                   we filter then out here? *)
-                  (fun v ->
-                  xml ## (setRequestHeader (Js.string k) (Js.string v)))
-                v)
+              (* some headers lead to errors in the javascript console, should
+                 we filter then out here? *)
+              xml ## (setRequestHeader (Js.string k) (Js.string v)))
             headers
     in
     (* perform call *)
diff --git a/cohttp/src/header.ml b/cohttp/src/header.ml
index 26823b154d..cb802ec4d2 100644
--- a/cohttp/src/header.ml
+++ b/cohttp/src/header.ml
@@ -30,12 +30,126 @@ end = struct
   let compare a b = String.compare a b
 end
 
-module StringMap = Map.Make (LString)
+type t = (LString.t * string) list
 
-type t = string list StringMap.t
+let compare = Stdlib.compare
+let init () = []
+let is_empty = function [] -> true | _ -> false
+let init_with k v = [ (LString.of_string k, v) ]
 
-let user_agent = Printf.sprintf "ocaml-cohttp/%s" Conf.version
-let compare = StringMap.compare Stdlib.compare
+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'
+  in
+  loop h
+
+let add h k v : t = (LString.of_string 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
+
+let add_opt h_opt k v =
+  match h_opt with None -> init_with k v | Some h -> add h k v
+
+let add_unless_exists h k v = if mem h k then h else add h k v
+
+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'
+  in
+  loop h
+
+let get_multi (h : t) (k : string) =
+  let rec loop h acc =
+    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
+  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
+    | x :: h -> x :: loop seen h
+  in
+  try loop false h with Not_found -> h
+
+(* Same effect than the previous [replace] function *)
+let replace 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 ->
+        if not seen then
+          (k', v) :: loop true h (* First occurrence found is replaced *)
+        else loop seen h (* Others are removed *)
+    | x :: h -> x :: loop seen h
+  in
+  try loop false h with Not_found -> add h k v
+
+(* Different effect than previous [update] function : replace the value is *)
+(* Does not make a lot of sens with the possibilities of duplicate header *)
+(* Maybe use "get_multi" instead ? *)
+let update h k f =
+  let vorig = get h k in
+  match (f vorig, vorig) with
+  | None, None -> h
+  | None, _ -> remove h k
+  | Some s, Some s' when s == s' -> h
+  | Some s, _ -> replace h k s
+
+let map (f : string -> string -> string) (h : t) : t =
+  List.map
+    (fun (k, v) ->
+      let vs' = f (LString.to_string 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
+
+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
+
+let to_list h =
+  List.fold_left (fun acc (k, v) -> (LString.to_string k, v) :: acc) [] 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
+
+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
+
+let to_string h =
+  let b = Buffer.create 128 in
+  to_list h
+  |> List.iter (fun (k, v) ->
+         Buffer.add_string b k;
+         Buffer.add_string b ": ";
+         Buffer.add_string b v;
+         Buffer.add_string b "\r\n");
+  Buffer.add_string b "\r\n";
+  Buffer.contents b
 
 let headers_with_list_values =
   Array.map LString.of_string
@@ -66,101 +180,32 @@ let headers_with_list_values =
       "www-authenticate";
     |]
 
-let is_transfer_encoding =
-  let k = LString.of_string "transfer-encoding" in
-  fun k' -> LString.compare k k' = 0
-
 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 init () = StringMap.empty
-let is_empty x = StringMap.is_empty x
-let init_with k v = StringMap.singleton (LString.of_string k) [ v ]
-
-let add h k v =
-  let k = LString.of_string k in
-  try
-    if is_transfer_encoding k then
-      StringMap.add k (StringMap.find k h @ [ v ]) h
-    else StringMap.add k (v :: StringMap.find k h) h
-  with Not_found -> StringMap.add 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
-let add_opt h k v = match h with None -> init_with k v | Some h -> add h k v
-
-let remove h k =
-  let k = LString.of_string k in
-  StringMap.remove k h
-
-let replace h k v =
-  let k = LString.of_string k in
-  StringMap.add k [ v ] h
-
-let get h k =
-  let k = LString.of_string k in
-  try
-    let v = StringMap.find k h in
-    if is_header_with_list_value k then Some (String.concat "," v)
-    else Some (List.hd v)
-  with Not_found | Failure _ -> None
-
-let update h k f =
-  let vorig = get h k in
-  let k = LString.of_string k in
-  match (f vorig, vorig) with
-  | None, _ -> StringMap.remove k h
-  | Some s, Some s' when s == s' -> h
-  | Some s, _ ->
-      let v' =
-        if is_header_with_list_value k then String.split_on_char ',' s
-        else [ s ]
-      in
-      StringMap.add k v' h
-
-let mem h k = StringMap.mem (LString.of_string k) h
-let add_unless_exists h k v = if mem h k then h else add h k v
-
-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_multi h k =
-  let k = LString.of_string k in
-  try StringMap.find k h with Not_found -> []
-
-let map fn h = StringMap.mapi (fun k v -> fn (LString.to_string k) v) h
-let iter fn h = ignore (map fn h)
-
-let fold fn h acc =
-  StringMap.fold
-    (fun k v acc ->
-      List.fold_left (fun acc v -> fn (LString.to_string k) v acc) acc v)
-    h acc
-
-let of_list l = List.fold_left (fun h (k, v) -> add h k v) (init ()) l
-let to_list h = List.rev (fold (fun k v acc -> (k, v) :: acc) h [])
-let header_line k v = Printf.sprintf "%s: %s\r\n" k v
-let to_lines h = List.rev (fold (fun k v acc -> header_line k v :: acc) h [])
-
-let to_frames =
-  let to_frame k v acc = Printf.sprintf "%s: %s" k v :: acc in
-  fun h -> List.rev (fold to_frame h [])
-
-let to_string h =
-  let b = Buffer.create 128 in
-  h
-  |> iter (fun k v ->
-         v
-         |> List.iter (fun v ->
-                Buffer.add_string b k;
-                Buffer.add_string b ": ";
-                Buffer.add_string b v;
-                Buffer.add_string b "\r\n"));
-  Buffer.add_string b "\r\n";
-  Buffer.contents b
+let clean_dup (h : t) : t =
+  let add h k v =
+    let to_add = ref false in
+    let rec loop = function
+      | [] ->
+          to_add := true;
+          []
+      | (k', v') :: hs ->
+          if LString.compare k k' = 0 then
+            if is_header_with_list_value k then (k, v' ^ ", " ^ v) :: hs
+            else (
+              to_add := true;
+              hs)
+          else (k', v') :: loop hs
+    in
+    let h = loop h in
+    if !to_add then (k, v) :: h else h
+  in
+  List.rev h |> List.fold_left (fun acc (k, v) -> add acc k v) []
 
+(** original content *)
 let parse_content_range s =
   try
     let start, fini, total =
@@ -270,6 +315,8 @@ let get_links headers =
 let add_links headers links =
   add_multi headers "link" (List.map Link.to_string links)
 
+let user_agent = Printf.sprintf "ocaml-cohttp/%s" Conf.version
+
 let prepend_user_agent headers user_agent =
   let k = "user-agent" in
   match get headers k with
diff --git a/cohttp/src/header.mli b/cohttp/src/header.mli
index 6914b6964e..17aefd9144 100644
--- a/cohttp/src/header.mli
+++ b/cohttp/src/header.mli
@@ -14,52 +14,71 @@
  *
   }}}*)
 
-(** Map of HTTP header key and value(s) associated with them. Since HTTP headers
-    can contain duplicate keys, this structure can return a list of values
-    associated with a single key. *)
-
+(** Associative list of HTTP headers pair of key and value. Order is preserved,
+    meaning duplicated keys are neither removed or concataned by default (see
+    [clean_dup] to do it). *)
 type t [@@deriving sexp]
 (** The type for HTTP headers. *)
 
 val init : unit -> t
-(** Construct a fresh, empty map of HTTP headers. *)
+(** [init ()] constructs a fresh, empty map of HTTP headers. *)
 
 val is_empty : t -> bool
-(** Test whether HTTP headers are empty or not. *)
+(** [is_empty h] tests whether HTTP headers are empty or not. *)
+
+val of_list : (string * string) list -> t
+(** [of_list l] creates an header structure with same content and order than l,
+    meaning the invariant [to_list (of_list l) = l] is true. *)
+
+val to_list : t -> (string * string) list
+(** [to_list h] convert HTTP headers h to a list. Order is preserved. *)
 
 val init_with : string -> string -> t
-(** Construct a fresh map of HTTP headers with a single key and value entry. *)
+(** [init_with k v] construct a fresh map of HTTP headers with a single pair of
+    key and value [(k, v)]. *)
 
 val add : t -> string -> string -> t
-(** Add a key and value to an existing header map. *)
+(** [add h k v] adds a key and value to an existing header list. *)
 
 val add_list : t -> (string * string) list -> t
-(** Add multiple key and value pairs to an existing header map. *)
+(** [add_list h l] adds each key and value pairs in [l] to the header list [h]
+    in order, meaning [to_list (add_list h l) = to_list h @ l] *)
 
 val add_multi : t -> string -> string list -> t
-(** Add multiple values to a key in an existing header map. *)
+(** [add_multi h k vs] add multiple values to a key in an existing header map by
+    calling [add h k v] (without concatenate the values).
+
+    Invariant : [get_multi (add_multi h k vs) k = existing @ vs] if
+    [get_multi h k = existing] *)
 
 val add_opt : t option -> string -> string -> t
-(** Given an optional header, either update the existing one with a key and
-    value, or construct a fresh header with those values if the header is
-    [None]. *)
+(** [add_opt hopt k v] adds the pair [(k, v)] to [h] if [hopt] is [Some h], or
+    constructs a fresh header list with this pair if [hopt] is [None]. *)
 
 val add_unless_exists : t -> string -> string -> t
-(** Given a header, update it with the key and value unless the key is already
-    present in the header. *)
+(** [add_unless_exists h k v] adds [(k, v)] to [h] unless the key is already
+    present in the header.
+
+    Invariant : [add_unless_exists h k _ = h if mem h k = true] *)
 
 val add_opt_unless_exists : t option -> string -> string -> t
-(** [add_opt_unless_exists h k v] updates [h] with the key [k] and value [v]
+(** [add_opt_unless_exists h k v] adds [(k, v)] to [h] if [hopt] is [Some h]
     unless the key is already present in the header. If [h] is [None] then a
-    fresh header is allocated containing the key [k] and the value [v]. *)
+    fresh header is allocated containing the pair [(k,
+   v)]. *)
 
 val remove : t -> string -> t
-(** Remove a key from the header map and return a fresh header set. The original
-    header parameter is not modified. *)
+(** [remove h k] removes every pair with [k] as key from [h] and return a fresh
+    header set. *)
 
 val replace : t -> string -> string -> t
-(** Replace the value of a key from the header map if it exists, otherwise it
-    adds it to the header map. The original header parameter is not modified. *)
+(** [replace h k v] replaces the last added value of [k] from [h] and removed
+    all other occurences of [k] if it exists. Otherwise it adds [(k, v)] to [h].
+
+    Example :
+    [replace (of_list \["a", "a1"; "b", "b1"; "a", "a2"\]) "a" "a3" = of_list \["b", "b1"; "a", "a3"\]] *)
+
+(* TODO *)
 
 val update : t -> string -> (string option -> string option) -> t
 (** [update h k f] returns a map containing the same headers as [h], except for
@@ -76,34 +95,39 @@ val update : t -> string -> (string option -> string option) -> t
     for the return value. The original header parameters are not modified. *)
 
 val mem : t -> string -> bool
-(** Check if a key exists in the header. *)
+(** [mem h k] returns [true] if the header name [k] appears in [h] and [false]
+    otherwise. *)
 
 val compare : t -> t -> int
-(** Structural comparison of two [Header] values. *)
+(** [compare h h'] is the structural comparison of two [Header] values. *)
 
 val get : t -> string -> string option
-(** Retrieve a key from a header. If the header is one of the set of headers
-    defined to have list values, then all of the values are concatenated into a
-    single string separated by commas and returned. If it is a singleton header,
-    then the first value is selected and no concatenation is performed. *)
+(** [get h k] returns [Some v] where [v] is the last added value associated with
+    [k] in [h] if it exists and [None] otherwise *)
 
 val get_multi : t -> string -> string list
-(** Retrieve all of the values associated with a key *)
+(** [get_multi h k] returns a list of all values associated with [k] in the
+    header list [h]. *)
 
-val iter : (string -> string list -> unit) -> t -> unit
-val map : (string -> string list -> string list) -> t -> t
+val iter : (string -> string -> unit) -> t -> unit
+val map : (string -> string -> string) -> t -> t
 val fold : (string -> string -> 'a -> 'a) -> t -> 'a -> 'a
-val of_list : (string * string) list -> t
-val to_list : t -> (string * string) list
 
 val to_lines : t -> string list
-(** Return header fieds as a list of lines. Beware that each line ends with
-    "\r\n" characters. *)
+(** [to_lines h] returns header fieds as a list of lines. Beware that each line
+    ends with "\r\n" characters. *)
 
 val to_frames : t -> string list
-(** Same as {!to_lines} but lines do not end with "\r\n" characters. *)
+(** [to_frames h] returns the same as {!to_lines} but lines do not end with
+    "\r\n" characters. *)
 
 val to_string : t -> string
+
+val clean_dup : t -> t
+(** [clean_dup h] cleans duplicates in h : if the duplicated header can not have
+    multiple values, only the last value is kept. Otherwise, the value are
+    concatenated and place at the first position this header is encountered. *)
+
 val get_content_range : t -> Int64.t option
 val get_media_type : t -> string option
 val get_connection_close : t -> bool
diff --git a/cohttp/src/header_io.ml b/cohttp/src/header_io.ml
index a4fc17619c..eb12ae962c 100644
--- a/cohttp/src/header_io.ml
+++ b/cohttp/src/header_io.ml
@@ -25,18 +25,14 @@ module Make (IO : S.IO) = struct
   open IO
   module Transfer_IO = Transfer_io.Make (IO)
 
-  let rev _k v = List.rev v
-
   let parse ic =
     (* consume also trailing "^\r\n$" line *)
     let rec parse_headers' headers =
       read_line ic >>= function
-      | Some "" | None -> return (Header.map rev headers)
+      | Some "" | None -> return headers
       | Some line -> (
           match split_header line with
-          | [ hd; tl ] ->
-              let header = String.lowercase_ascii hd in
-              parse_headers' (Header.add headers header tl)
+          | [ hd; tl ] -> parse_headers' (Header.add headers hd tl)
           | _ -> return headers)
     in
     parse_headers' (Header.init ())

From 8611214edeacb90c8e64bd116887dd60303cb919 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Mon, 8 Feb 2021 15:01:16 +0100
Subject: [PATCH 02/14] Correct Header.update and add docs.  Add
 [Header.get_multi_concat] function to get the same effect than previous [get]
 function (on maps) and correct all get_[some header] functions accordingly.

---
 cohttp/src/header.ml  | 64 +++++++++++++++++++++++++++++++------------
 cohttp/src/header.mli | 56 +++++++++++++++++++++++--------------
 2 files changed, 82 insertions(+), 38 deletions(-)

diff --git a/cohttp/src/header.ml b/cohttp/src/header.ml
index cb802ec4d2..09e37285d6 100644
--- a/cohttp/src/header.ml
+++ b/cohttp/src/header.ml
@@ -85,29 +85,46 @@ let remove h k =
   in
   try loop false h with Not_found -> h
 
-(* Same effect than the previous [replace] function *)
-let replace h k v =
+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
+    | 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 ->
-        if not seen then
-          (k', v) :: loop true h (* First occurrence found is replaced *)
-        else loop seen h (* Others are removed *)
+       if last then (k'', v) :: h
+       else if not seen then (k', v) :: loop true h
+       else loop seen h
     | x :: h -> x :: loop seen h
   in
   try loop false h with Not_found -> add h k v
 
-(* Different effect than previous [update] function : replace the value is *)
-(* Does not make a lot of sens with the possibilities of duplicate header *)
-(* Maybe use "get_multi" instead ? *)
-let update h k f =
-  let vorig = get h k in
+let replace = replace_ false
+
+let update_ ~all:all h k f =
+  let vorig =
+    if not all then get h k
+    else
+      match get_multi h k with [] -> None | vs -> Some (String.concat "," vs)
+  in
   match (f vorig, vorig) with
   | None, None -> h
-  | None, _ -> remove h k
+  | None, _ -> if all then remove h k else remove_last h k
   | Some s, Some s' when s == s' -> h
-  | Some s, _ -> replace h k s
+  | Some s, _ -> replace_ (not all) h k s
+                 (* if (not all) then only the last value paired
+                     with k is changed *)
+
+let update = update_ ~all:true
+
+let update_last = update_ ~all:false
 
 let map (f : string -> string -> string) (h : t) : t =
   List.map
@@ -205,7 +222,17 @@ let clean_dup (h : t) : t =
   in
   List.rev h |> List.fold_left (fun acc (k, v) -> add acc k v) []
 
-(** original content *)
+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
+    (
+      let vs = get_multi h k in
+      match vs with
+      | [] -> None
+      | _ ->  Some (String.concat "," vs))
+  else
+    get h k
+
 let parse_content_range s =
   try
     let start, fini, total =
@@ -255,21 +282,22 @@ let get_media_type headers =
   | None -> None
 
 let get_acceptable_media_ranges headers =
-  Accept.media_ranges (get headers "accept")
+  Accept.media_ranges (get_multi_concat ~list_value_only:true headers "accept")
 
 let get_acceptable_charsets headers =
-  Accept.charsets (get headers "accept-charset")
+  Accept.charsets (get_multi_concat ~list_value_only:true headers "accept-charset")
 
 let get_acceptable_encodings headers =
-  Accept.encodings (get headers "accept-encoding")
+  Accept.encodings (get_multi_concat ~list_value_only:true headers "accept-encoding")
 
 let get_acceptable_languages headers =
-  Accept.languages (get headers "accept-language")
+  Accept.languages (get_multi_concat ~list_value_only:true headers "accept-language")
 
 (* Parse the transfer-encoding and content-length headers to
  * determine how to decode a body *)
 let get_transfer_encoding headers =
-  match get headers "transfer-encoding" with
+  (* It should actually be [get] as the interresting value is actually the last.*)
+  match get_multi_concat ~list_value_only:true headers "transfer-encoding" with
   | Some "chunked" -> Transfer.Chunked
   | Some _ | None -> (
       match get_content_range headers with
diff --git a/cohttp/src/header.mli b/cohttp/src/header.mli
index 17aefd9144..ee898f159d 100644
--- a/cohttp/src/header.mli
+++ b/cohttp/src/header.mli
@@ -73,26 +73,32 @@ val remove : t -> string -> t
 
 val replace : t -> string -> string -> t
 (** [replace h k v] replaces the last added value of [k] from [h] and removed
-    all other occurences of [k] if it exists. Otherwise it adds [(k, v)] to [h].
+    all other occurences of [k] if it exists. Otherwise it adds [(k, v)] to [h]. *)
 
-    Example :
-    [replace (of_list \["a", "a1"; "b", "b1"; "a", "a2"\]) "a" "a3" = of_list \["b", "b1"; "a", "a3"\]] *)
+val update : t -> string -> (string option -> string option) -> t
+(** [update h k f] returns a associative list containing the same headers as
+    [h], except for the header [k]. Depending on the value of [v] where [v] is
+    [f (get_multi_concat h k)], the header [k] is added, removed or updated.
 
-(* TODO *)
+    - If [v] is [None], every occurences of the header in [h] and all its value
+      is removed;
 
-val update : t -> string -> (string option -> string option) -> t
-(** [update h k f] returns a map containing the same headers as [h], except for
-    the header [k]. Depending on the value of [v] where [v] is [f (get h k)],
-    the header [k] is added, removed or updated. If [v] is [None], the header is
-    removed if it exists; otherwise, if [v] is [Some z] then [k] is associated
-    to [z] in the resulting headers. If [k] was already associated in [h] to a
-    value that is physically equal to [z], [h] is returned unchanged. Similarly
-    as for [get], if the header is one of the set of headers defined to have
-    list values, then all of the values are concatenated into a single string
-    separated by commas and passed to [f], while the return value of [f] is
-    split on commas and associated to [k]. If it is a singleton header, then the
-    first value is passed to [f] and no concatenation is performed, similarly
-    for the return value. The original header parameters are not modified. *)
+    - If [v] is [Some z] then [k] is associated to [z] (and only [z]) in the
+      resulting headers;
+
+    - If [k] was already associated in [h] to a value that is physically equal
+      to [z], [h] is returned unchanged.
+
+    In case [k] should not have multiple values, but has multiple occurences in
+    [h], the use of [clean_dup] may be needed before calling this function to
+    prevent the values of this header to get concatenated. *)
+
+val update_last : t -> string -> (string option -> string option) -> t
+(** [update h k f] does the same work than [update h k f] except only the last
+    value [v] associated to [k] is used and affected, meaning [f] is called with
+    [get h k] and only the pair [(k, v)] is potentially removed or updated
+    depending of the result of [f (get h
+   k)]. *)
 
 val mem : t -> string -> bool
 (** [mem h k] returns [true] if the header name [k] appears in [h] and [false]
@@ -123,10 +129,20 @@ val to_frames : t -> string list
 
 val to_string : t -> string
 
+(* Header management functions *)
+
 val clean_dup : t -> t
-(** [clean_dup h] cleans duplicates in h : if the duplicated header can not have
-    multiple values, only the last value is kept. Otherwise, the value are
-    concatenated and place at the first position this header is encountered. *)
+(** [clean_dup h] cleans duplicates in h : if the duplicated headers can not
+    have multiple values, only the last value is kept. Otherwise, the values are
+    concatenated and place at the first position this header is encountered in
+    [h]. *)
+
+val get_multi_concat : ?list_value_only:bool -> t -> string -> string option
+(** [get_multi_concat h k] returns all the values paired with [k] in [h],
+    concatenated and separated by a comma. The optional argument
+    [?list_value_only] is [false] by default. If it is [true], then the returned
+    string can contain multiple values only if the searched header can have
+    multiple values (like transfer-encoding or accept). *)
 
 val get_content_range : t -> Int64.t option
 val get_media_type : t -> string option

From ef6e9539059c88a05cb1f555c42893010d99fde8 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Mon, 8 Feb 2021 15:03:29 +0100
Subject: [PATCH 03/14] Add unitary tests for [Cohttp.Header] module and change
 existing tests to match the new implementation.

---
 cohttp-lwt-unix/test/test_parser.ml |   8 +-
 cohttp/test/dune                    |   2 +-
 cohttp/test/test_header.ml          | 136 +----------
 cohttp/test/unitary_test_header.ml  | 351 ++++++++++++++++++++++++++++
 4 files changed, 358 insertions(+), 139 deletions(-)
 create mode 100644 cohttp/test/unitary_test_header.ml

diff --git a/cohttp-lwt-unix/test/test_parser.ml b/cohttp-lwt-unix/test/test_parser.ml
index 000d1ea56b..b072b5fb51 100644
--- a/cohttp-lwt-unix/test/test_parser.ml
+++ b/cohttp-lwt-unix/test/test_parser.ml
@@ -247,10 +247,10 @@ let make_simple_req () =
     "POST /foo/bar HTTP/1.1\r\n\
      foo: bar\r\n\
      host: localhost\r\n\
-     transfer-encoding: chunked\r\n\
      user-agent: "
     ^ user_agent
-    ^ "\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n"
+    ^ "\r\ntransfer-encoding: chunked\
+       \r\n\r\n6\r\nfoobar\r\n0\r\n\r\n"
   in
   let req =
     Request.make ~encoding:Transfer.Chunked ~meth:`POST
@@ -266,10 +266,10 @@ let mutate_simple_req () =
     "POST /foo/bar HTTP/1.1\r\n\
      foo: bar\r\n\
      host: localhost\r\n\
-     transfer-encoding: chunked\r\n\
      user-agent: "
     ^ user_agent
-    ^ "\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n"
+    ^ "\r\ntransfer-encoding: chunked\
+       \r\n\r\n6\r\nfoobar\r\n0\r\n\r\n"
   in
   let req =
     Request.make ~encoding:Transfer.Chunked
diff --git a/cohttp/test/dune b/cohttp/test/dune
index b1e3309b8e..dde8072f7b 100644
--- a/cohttp/test/dune
+++ b/cohttp/test/dune
@@ -12,7 +12,7 @@
 
 (executable
  (name test_header)
- (modules test_header)
+ (modules unitary_test_header test_header)
  (forbidden_libraries base)
  (libraries cohttp alcotest fmt))
 
diff --git a/cohttp/test/test_header.ml b/cohttp/test/test_header.ml
index 7c83edc776..3ffee01589 100644
--- a/cohttp/test/test_header.ml
+++ b/cohttp/test/test_header.ml
@@ -13,10 +13,8 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *}}}*)
 
-open Printf
 module String_io = Cohttp__String_io
 module StringResponse = Cohttp.Response.Make (String_io.M)
-module HIO = Cohttp__Header_io.Make (String_io.M)
 module H = Cohttp.Header
 
 let aes = Alcotest.check Alcotest.string
@@ -102,106 +100,6 @@ let get_media_type () =
     "media type" (Some "foo/bar")
     (Cohttp.Header.get_media_type header)
 
-let list_valued_header () =
-  let h = H.init () in
-  let h = H.add h "accept" "foo" in
-  let h = H.add h "accept" "bar" in
-  aeso "list valued header" (H.get h "accept") (Some "bar,foo")
-
-let t_header =
-  Alcotest.testable
-    (fun fmt h ->
-      let sexp = Cohttp.Header.sexp_of_t h in
-      Sexplib0.Sexp.pp_hum fmt sexp)
-    (fun x y -> Cohttp.Header.compare x y = 0)
-
-let large_header () =
-  let sz = 1024 * 1024 * 100 in
-  let h = H.init () in
-  let v1 = String.make sz 'a' in
-  let h = H.add h "x-large" v1 in
-  let h = H.add h v1 "foo" in
-  aeso "x-large" (H.get h "x-large") (Some v1);
-  let obuf = Buffer.create (sz + 1024) in
-  HIO.write h obuf;
-  let ibuf = Buffer.contents obuf in
-  let sbuf = String_io.open_in ibuf in
-  Alcotest.check t_header "large_header" (HIO.parse sbuf) h
-
-let many_headers () =
-  let size = 1000000 in
-  let rec add_header num h =
-    match num with
-    | 0 -> h
-    | n ->
-        let k = sprintf "h%d" n in
-        let v = sprintf "v%d" n in
-        let h = H.add h k v in
-        add_header (num - 1) h
-  in
-  let h = add_header size (H.init ()) in
-  Alcotest.(check int) "many_headers" (List.length (H.to_list h)) size
-
-module Updates = struct
-  let h =
-    H.init () |> fun h ->
-    H.add h "first" "1" |> fun h ->
-    H.add h "second" "2" |> fun h ->
-    H.add h "accept" "foo" |> fun h -> H.add h "accept" "bar"
-
-  let replace_headers_if_exists () =
-    let h = H.replace h "second" "2a" in
-    Alcotest.(check (option string))
-      "replace_existing_header" (Some "2a") (H.get h "second")
-
-  let replace_headers_if_absent () =
-    let h = H.replace h "third" "3" in
-    Alcotest.(check (option string))
-      "replace_new_header" (Some "3") (H.get h "third")
-
-  let update_headers_if_exists () =
-    let h1 =
-      H.update h "second" (function Some _ -> Some "2a" | None -> None)
-    in
-    let h2 = H.replace h "second" "2a" in
-    Alcotest.(check t_header) "update_existing_header" h1 h2
-
-  let update_headers_if_exists_rm () =
-    let h1 =
-      H.update h "second" (function Some _ -> None | None -> Some "3")
-    in
-    let h2 = H.remove h "second" in
-    Alcotest.(check t_header) "update_remove_header" h1 h2
-
-  let update_headers_if_absent_add () =
-    let h = H.update h "third" (function Some _ -> None | None -> Some "3") in
-    Alcotest.(check (option string))
-      "update_add_new_header" (Some "3") (H.get h "third")
-
-  let update_headers_if_absent_rm () =
-    let h1 = H.update h "third" (function _ -> None) in
-    Alcotest.(check t_header) "update_remove_absent_header" h h1
-
-  let update_headers_if_exists_multi () =
-    let h1 =
-      H.update h "accept" (function
-        | Some v -> Some ("baz," ^ v)
-        | None -> None)
-    in
-    let h2 = H.add h "accept" "baz" in
-    Alcotest.(check (option string))
-      "update_existing_header_multivalued" (H.get h1 "accept")
-      (H.get h2 "accept")
-
-  let update_headers_if_absent () =
-    let h1 =
-      H.update h "third" (function Some _ -> Some "3" | None -> None)
-    in
-    Alcotest.(check t_header) "update_new_header: unchanged" h h1;
-    Alcotest.(check (option string))
-      "update_new_header: map unchanged" None (H.get h "third")
-end
-
 module Content_range = struct
   let h1 = H.of_list [ ("Content-Length", "123") ]
   let h2 = H.of_list [ ("Content-Range", "bytes 200-300/1000") ]
@@ -551,18 +449,7 @@ let test_cachecontrol_concat () =
   in
   let h = headers_of_response "concat Cache-Control" resp in
   aeso "test_cachecontrol_concat" (Some "public,max-age:86400")
-    (H.get h "Cache-Control")
-
-let transfer_encoding () =
-  let h =
-    H.of_list
-      [ ("transfer-encoding", "gzip"); ("transfer-encoding", "chunked") ]
-  in
-  let sh = H.to_string h in
-  aes "transfer_encoding_string_is_ordered" sh
-    "transfer-encoding: gzip\r\ntransfer-encoding: chunked\r\n\r\n";
-  let sh = H.get h "transfer-encoding" in
-  aeso "transfer_encoding_get_is_ordered" (Some "gzip,chunked") sh
+    (H.get_multi_concat h "Cache-Control")
 
 let () = Printexc.record_backtrace true
 
@@ -603,24 +490,5 @@ let () =
           ("content-range", `Quick, Content_range.content_range);
         ] );
       ("Cache Control", [ ("concat", `Quick, test_cachecontrol_concat) ]);
-      ( "Header",
-        [
-          ("get list valued", `Quick, list_valued_header);
-          ("trim whitespace", `Quick, trim_ws);
-          ("replace existing", `Quick, Updates.replace_headers_if_exists);
-          ("replace absent", `Quick, Updates.replace_headers_if_absent);
-          ("update existing", `Quick, Updates.update_headers_if_exists);
-          ( "update existing list",
-            `Quick,
-            Updates.update_headers_if_exists_multi );
-          ("update add absent", `Quick, Updates.update_headers_if_absent_add);
-          ("update rm existing", `Quick, Updates.update_headers_if_exists_rm);
-          ("update rm absent", `Quick, Updates.update_headers_if_absent_rm);
-          ("update absent", `Quick, Updates.update_headers_if_absent);
-          ("many headers", `Slow, many_headers);
-          ("transfer encoding is in correct order", `Quick, transfer_encoding);
-        ]
-        @
-        if Sys.word_size = 64 then [ ("large header", `Slow, large_header) ]
-        else [] );
+      Unitary_test_header.tests;
     ]
diff --git a/cohttp/test/unitary_test_header.ml b/cohttp/test/unitary_test_header.ml
new file mode 100644
index 0000000000..85b48673eb
--- /dev/null
+++ b/cohttp/test/unitary_test_header.ml
@@ -0,0 +1,351 @@
+(*{{{ Copyright (c) 2020 Carine Morel <carine@tarides.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *}}}*)
+
+module H = Cohttp.Header
+(** These tests try as much as possible to tests each header functions
+    independently. *)
+
+let aes = Alcotest.check Alcotest.string
+let aeso = Alcotest.check Alcotest.(option string)
+let aesl = Alcotest.check Alcotest.(list string)
+let aessl = Alcotest.check Alcotest.(list (pair string string))
+let aeb = Alcotest.check Alcotest.bool
+
+let t_header =
+  Alcotest.testable
+    (fun fmt h ->
+      let sexp = Cohttp.Header.sexp_of_t h in
+      Sexplib0.Sexp.pp_hum fmt sexp)
+    (fun x y -> Cohttp.Header.compare x y = 0)
+
+let aeh = Alcotest.check t_header
+
+let hstr =
+  [
+    ("accept", "application/xml");
+    ("transfer-encoding", "chunked");
+    ("accept", "text/html");
+    ("content-length", "100");
+  ]
+
+let prebuilt = H.of_list hstr
+let to_list_rev h = List.rev (H.to_list h)
+
+let to_list_tests () =
+  aessl "to_list (init ())" [] H.(to_list (init ()));
+  aessl "to_list (add (init ()) k v" [ ("a", "a1") ]
+    H.(to_list (add (init ()) "a" "a1"));
+  aessl "to_list (of_list h) = h" hstr H.(to_list prebuilt)
+
+let is_empty_tests () =
+  aeb "is_empty (init ())" true H.(is_empty (init ()));
+  aeb "is_empty (add (init ()) k v" false H.(is_empty (add (init ()) "a" "a1"));
+  aeb "is_empty (remove (add (init ()) k v) k)" true
+    H.(is_empty (remove (add (init ()) "a" "a1") "a"))
+
+(* [init_with l] *)
+let init_with_tests () =
+  aessl "init_with k v"
+    [ ("transfer-encoding", "chunked") ]
+    H.(to_list (init_with "traNsfer-eNcoding" "chunked"))
+
+let mem_tests () =
+  aeb "mem (init ()) k = false" false H.(mem (init ()) "a");
+  aeb "mem h k" true H.(mem prebuilt "accept");
+  aeb "mem h k" true H.(mem prebuilt "content-length");
+  aeb "mem h k" false H.(mem prebuilt "a")
+
+let add_tests () =
+  aessl "add h k v" (hstr @ [ ("a", "a1") ]) H.(to_list (add prebuilt "a" "a1"));
+  aessl "add (add h k v) k v"
+    (hstr @ [ ("a", "a1"); ("a", "a1") ])
+    H.(to_list (add (add prebuilt "a" "a1") "a" "a1"));
+  aessl "add (add h k' v') k v"
+    (hstr @ [ ("a", "a1"); ("b", "b1") ])
+    H.(to_list (add (add prebuilt "a" "a1") "b" "b1"))
+
+let get_tests () =
+  aeso "get (add (init () k v) k" (Some "a1")
+    H.(get (add (init ()) "a" "a1") "a");
+  aeso "get (add h k v) k when mem h k = false" (Some "a1")
+    H.(get (add prebuilt "a" "a1") "a");
+  aeso "get (add h k v) k when mem h k = true" (Some "text/html")
+    H.(get (add prebuilt "a" "a1") "accept");
+  aeso "get (add (add h k v') k v) k = v" (Some "a2")
+    H.(get (add (add prebuilt "a" "a1") "a" "a2") "a")
+
+(* [add_list h l] is h with l at the end. It is the same than
+   adding each element in l one by one in order. *)
+let add_list_tests () =
+  let l = [ ("a", "a1"); ("b", "b1") ] in
+  aessl "add_list (init ()) []" [] H.(to_list (add_list (init ()) []));
+  aessl "add_list (init ()) l" l H.(to_list (add_list (init ()) l));
+  aessl "add_list h []" hstr H.(to_list (add_list prebuilt []));
+  aessl "add_list h [k, v]"
+    (hstr @ [ ("a", "a1") ])
+    H.(to_list (add_list prebuilt [ ("a", "a1") ]));
+  aessl "add_list h l" (hstr @ l) H.(to_list (add_list prebuilt l))
+
+let add_multi_tests () =
+  let k, vals = ("a", [ "a1"; "a2"; "a3" ]) in
+  let l = List.map (fun v -> ("a", v)) vals in
+  aessl "add_multi (init ()) k []" [] H.(to_list (add_multi (init ()) k []));
+  aessl "add_multi (init ()) k vals" l H.(to_list (add_multi (init ()) k vals));
+  aessl "add_multi h k []" hstr H.(to_list (add_multi prebuilt k []));
+  aessl "add_multi h k vals" (hstr @ l) H.(to_list (add_multi prebuilt k vals))
+
+let add_unless_exists_tests () =
+  let k, v = ("a", "a1") in
+  let k', v' = ("transfer-encoding", "chunked") in
+  let k'', v'' = ("accept", "text/*") in
+  aessl "add_unless_exists (init ()) k v" [ (k, v) ]
+    H.(to_list (add_unless_exists (init ()) k v));
+  aessl "add_unless_exists h k v when mem h k = false"
+    (hstr @ [ (k, v) ])
+    H.(to_list (add_unless_exists prebuilt k v));
+  aessl "add_unless_exists h k v when mem h k = true)" hstr
+    H.(to_list (add_unless_exists prebuilt k' v'));
+  aessl "add_unless_exists h k v when mem h k = true)" hstr
+    H.(to_list (add_unless_exists prebuilt k'' v''))
+
+let remove_tests () =
+  aessl "remove (init ()) k" [] H.(to_list (remove (init ()) "accept"));
+  aessl "remove (add (add (init ()) k v) k v) k" []
+    H.(to_list (remove (add (add (init ()) "k" "v") "k" "v") "k"));
+  aessl "remove h k when mem h k = false" hstr H.(to_list (remove prebuilt "a"));
+  aessl "remove h k when mem h k = true"
+    [
+      ("accept", "application/xml");
+      ("accept", "text/html");
+      ("content-length", "100");
+    ]
+    H.(to_list (remove prebuilt "transfer-encoding"));
+  aessl "remove h k when mem h k = true"
+    [ ("transfer-encoding", "chunked"); ("content-length", "100") ]
+    H.(to_list (remove prebuilt "accept"))
+
+let replace_tests () =
+  let k, v, v' = ("a", "a1", "a2") in
+  aessl "replace (init ()) k v" [ (k, v) ] H.(to_list (replace (init ()) k v));
+  aessl "replace (add (init ()) k v) k v" [ (k, v) ]
+    H.(to_list (replace (add (init ()) k v) k v));
+  aessl "replace (add (init ()) k v) k v'" [ (k, v') ]
+    H.(to_list (replace (add (init ()) k v) k v'));
+  aessl "replace h k v when mem h k = false"
+    (hstr @ [ (k, v) ])
+    H.(to_list (replace prebuilt k v));
+  aessl "replace h k v when mem h k = true"
+    [
+      ("accept", "application/xml");
+      ("transfer-encoding", "gzip");
+      ("accept", "text/html");
+      ("content-length", "100");
+    ]
+    H.(to_list (replace prebuilt "transfer-encoding" "gzip"));
+  aessl "replace h k v when mem h = true"
+    [
+      ("transfer-encoding", "chunked");
+      ("accept", "text/*");
+      ("content-length", "100");
+    ]
+    H.(to_list (replace prebuilt "accept" "text/*"))
+
+let h =
+  H.init () |> fun h ->
+  H.add h "first" "1" |> fun h ->
+  H.add h "second" "2" |> fun h ->
+  H.add h "accept" "foo" |> fun h -> H.add h "accept" "bar"
+
+let update_tests () =
+  let h1 =
+    H.update h "second" (function Some _ -> Some "2a" | None -> None)
+  in
+  let h2 = H.replace h "second" "2a" in
+  aeh "update existing header" h1 h2;
+  let h1 = H.update h "second" (function Some _ -> None | None -> Some "3") in
+  let h2 = H.remove h "second" in
+  aeh "update remove header" h1 h2;
+  let h' = H.update h "third" (function Some _ -> None | None -> Some "3") in
+  aeso "update add new header" (Some "3") (H.get_multi_concat h' "third");
+  let h1 = H.update h "third" (function _ -> None) in
+  aeh "update_remove_absent_header" h h1;
+  let h1 =
+    H.update h "accept" (function Some v -> Some (v ^ ",baz") | None -> None)
+  in
+  let h2 = H.add h "accept" "baz" in
+  aeso "update_all_existing_header_multivalued" (H.get h1 "accept")
+    (H.get_multi_concat h2 "accept");
+  let h1 = H.update h "third" (function Some _ -> Some "3" | None -> None) in
+  aeh "update_new_header: unchanged" h h1;
+  aeso "update_new_header: headers unchanged" None (H.get h "third");
+  let h1 = H.update h "accept" (function Some _ -> None | None -> None) in
+  aeh "update_all_existing_header_multivalue : remove all" (H.remove h "accept")
+    h1;
+  let h1 =
+    H.update_last h "accept" (function Some _ -> None | None -> None)
+  in
+  aeso "update_existing_header_remove_multivalue: remove last" (Some "foo")
+    (H.get h1 "accept")
+
+let get_multi_tests () =
+  aesl "get_multi (init ()) k" [] H.(get_multi (init ()) "a");
+  aesl "get_multi h k when mem h k = false" [] H.(get_multi prebuilt "a");
+  aesl "get_multi h k when mem h k = true" [ "chunked" ]
+    H.(get_multi prebuilt "transfer-encoding");
+  aesl "get_multi h k when mem h k = true"
+    [ "application/xml"; "text/html" ]
+    H.(get_multi prebuilt "accept")
+
+let hstr =
+  [
+    ("accept", "application/xml");
+    ("transfer-encoding", "chunked");
+    ("accept", "text/html");
+    ("content-length", "100");
+  ]
+
+let get_multi_concat_tests () =
+  let h1 = H.(add (add prebuilt "a" "a1") "a" "a2") in
+  aeso "get_multi_concat (init ()) k" None H.(get_multi_concat (init ()) "a");
+  aeso "get_multi_concat h k when mem h k = false" None
+    H.(get_multi_concat prebuilt "a");
+  aeso "get_multi_concat h k when mem h k = true"
+    (Some "application/xml,text/html")
+    H.(get_multi_concat prebuilt "accept");
+  aeso "get_multi_concat ~list_value_only:false h k when mem h k = true"
+    (Some "a1,a2")
+    H.(get_multi_concat h1 "a");
+  aeso "get_multi_concat ~list_value_only:true h k when mem h k = true"
+    (Some "a2")
+    H.(get_multi_concat ~list_value_only:true h1 "a")
+
+let map_tests () =
+  let a = ", a" in
+  aessl "map (fun _ v -> v) (init ())" []
+    H.(to_list (map (fun _k v -> v) (init ())));
+  aessl "map (fun _ v -> v) (init ())" (H.to_list prebuilt)
+    H.(to_list (map (fun _k v -> v) prebuilt));
+  aessl "map (fun _ v -> v ^ a ) (init ())"
+    [
+      ("accept", "application/xml, a");
+      ("transfer-encoding", "chunked, a");
+      ("accept", "text/html, a");
+      ("content-length", "100, a");
+    ]
+    H.(to_list (map (fun _k v -> v ^ a) prebuilt))
+
+let fold_tests () = ()
+let iter_tests () = ()
+
+let to_lines_tests () =
+  aesl "to_lines h"
+    [
+      "accept: application/xml\r\n";
+      "transfer-encoding: chunked\r\n";
+      "accept: text/html\r\n";
+      "content-length: 100\r\n";
+    ]
+    H.(to_lines prebuilt)
+
+let to_frames_tests () =
+  aesl "to_frames h"
+    [
+      "accept: application/xml";
+      "transfer-encoding: chunked";
+      "accept: text/html";
+      "content-length: 100";
+    ]
+    H.(to_frames prebuilt)
+
+let to_string_tests () =
+  aes "to_string h"
+    "accept: application/xml\r\n\
+     transfer-encoding: chunked\r\n\
+     accept: text/html\r\n\
+     content-length: 100\r\n\
+     \r\n"
+    H.(to_string prebuilt)
+
+let many_headers () =
+  let size = 1000000 in
+  let rec add_header num h =
+    match num with
+    | 0 -> h
+    | n ->
+        let k = Printf.sprintf "h%d" n in
+        let v = Printf.sprintf "v%d" n in
+        let h = H.add h k v in
+        add_header (num - 1) h
+  in
+  let h = add_header size (H.init ()) in
+  Alcotest.(check int) "many_headers" (List.length (H.to_list h)) size
+
+let transfer_encoding_tests () =
+  let h =
+    H.of_list
+      [ ("transfer-encoding", "gzip"); ("transfer-encoding", "chunked") ]
+  in
+  let sh = H.to_string h in
+  aes "transfer_encoding_string_is_ordered" sh
+    "transfer-encoding: gzip\r\ntransfer-encoding: chunked\r\n\r\n";
+  let sh = H.get_multi_concat h "transfer-encoding" in
+  aeso "transfer_encoding_get_is_ordered" (Some "gzip,chunked") sh
+
+module String_io = Cohttp__String_io
+module HIO = Cohttp__Header_io.Make (String_io.M)
+
+let large_header () =
+  let sz = 1024 * 1024 * 100 in
+  let h = H.init () in
+  let v1 = String.make sz 'a' in
+  let h = H.add h "x-large" v1 in
+  let h = H.add h v1 "foo" in
+  aeso "x-large" (H.get h "x-large") (Some v1);
+  let obuf = Buffer.create (sz + 1024) in
+  HIO.write h obuf;
+  let ibuf = Buffer.contents obuf in
+  let sbuf = String_io.open_in ibuf in
+  Alcotest.check t_header "large_header" (HIO.parse sbuf) h
+
+let tests =
+  ( "Unitary Header tests",
+    [
+      ("Header.to_list", `Quick, to_list_tests);
+      ("Header.is_empty", `Quick, is_empty_tests);
+      ("Header.init_with", `Quick, init_with_tests);
+      ("Header.mem", `Quick, mem_tests);
+      ("Header.add", `Quick, add_tests);
+      ("Header.get", `Quick, get_tests);
+      ("Header.add_list", `Quick, add_list_tests);
+      ("Header.add_multi", `Quick, add_multi_tests);
+      ("Header.add_unless_exists", `Quick, add_unless_exists_tests);
+      ("Header.remove", `Quick, remove_tests);
+      ("Header.replace", `Quick, replace_tests);
+      ("Header.get_multi", `Quick, get_multi_tests);
+      ("Header.get_multi_concat", `Quick, get_multi_concat_tests);
+      ("Header.to_lines", `Quick, to_lines_tests);
+      ("Header.to_frames", `Quick, to_frames_tests);
+      ("Header.to_string", `Quick, to_string_tests);
+      ("Header.map", `Quick, map_tests);
+      ("Header.update", `Quick, update_tests);
+      ("many headers", `Slow, many_headers);
+      ("transfer encoding is in correct order", `Quick, transfer_encoding_tests);
+      (*todo*)
+      ("Header.fold", `Quick, fold_tests);
+      ("Header.iter", `Quick, iter_tests);
+    ]
+    @
+    if Sys.word_size = 64 then [ ("large header", `Slow, large_header) ] else []
+  )

From a2bfe30b23b802d86a9f7455af6d1f27eff43659 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Tue, 30 Mar 2021 19:27:14 +0200
Subject: [PATCH 04/14] Add tests for upgrade_all and upgrade to alcotest test
 suite.

---
 cohttp/test/unitary_test_header.ml | 53 +++++++++++++++++++++---------
 1 file changed, 37 insertions(+), 16 deletions(-)

diff --git a/cohttp/test/unitary_test_header.ml b/cohttp/test/unitary_test_header.ml
index 85b48673eb..4ed22c1057 100644
--- a/cohttp/test/unitary_test_header.ml
+++ b/cohttp/test/unitary_test_header.ml
@@ -1,4 +1,4 @@
-(*{{{ Copyright (c) 2020 Carine Morel <carine@tarides.com>
+(*{{{ Copyright (c) 2021 Carine Morel <carine@tarides.com>
  *
  * Permission to use, copy, modify, and distribute this software for any
  * purpose with or without fee is hereby granted, provided that the above
@@ -55,7 +55,6 @@ let is_empty_tests () =
   aeb "is_empty (remove (add (init ()) k v) k)" true
     H.(is_empty (remove (add (init ()) "a" "a1") "a"))
 
-(* [init_with l] *)
 let init_with_tests () =
   aessl "init_with k v"
     [ ("transfer-encoding", "chunked") ]
@@ -86,8 +85,6 @@ let get_tests () =
   aeso "get (add (add h k v') k v) k = v" (Some "a2")
     H.(get (add (add prebuilt "a" "a1") "a" "a2") "a")
 
-(* [add_list h l] is h with l at the end. It is the same than
-   adding each element in l one by one in order. *)
 let add_list_tests () =
   let l = [ ("a", "a1"); ("b", "b1") ] in
   aessl "add_list (init ()) []" [] H.(to_list (add_list (init ()) []));
@@ -177,27 +174,50 @@ let update_tests () =
   let h1 = H.update h "second" (function Some _ -> None | None -> Some "3") in
   let h2 = H.remove h "second" in
   aeh "update remove header" h1 h2;
+  let h1 =
+    H.update h "accept" (function Some _ -> Some "baz" | None -> None)
+  in
+  aesl "update existing header with multiple values"
+    H.(get_multi h1 "accept")
+    [ "foo"; "baz" ];
   let h' = H.update h "third" (function Some _ -> None | None -> Some "3") in
-  aeso "update add new header" (Some "3") (H.get_multi_concat h' "third");
+  aesl "update add new header" (H.get_multi h' "third") [ "3" ];
   let h1 = H.update h "third" (function _ -> None) in
   aeh "update_remove_absent_header" h h1;
+  let h1 = H.update h "third" (function Some _ -> Some "3" | None -> None) in
+  aeh "update_new_header: unchanged" h h1;
+  let h1 = H.update h "accept" (function Some _ -> None | None -> None) in
+  aeso "update_existing_header_remove_multivalue: remove last" (Some "foo")
+    (H.get h1 "accept")
+
+let update_all_tests () =
+  let h1 = H.update_all h "second" (function [] -> [] | _ -> [ "2a" ]) in
+  let h2 = H.(add (remove h "second") "second" "2a") in
+  aeh "update_all existing header" h1 h2;
+  let h1 = H.update_all h "second" (function [] -> [ "3" ] | _ -> []) in
+  let h2 = H.remove h "second" in
+  aeh "update_all remove header" h1 h2;
+  let h1 = H.update_all h "accept" (function [] -> [] | _ -> [ "baz" ]) in
+  aesl "update_all existing header with multiple values"
+    H.(get_multi h1 "accept")
+    [ "baz" ];
   let h1 =
-    H.update h "accept" (function Some v -> Some (v ^ ",baz") | None -> None)
+    H.update_all h "accept" (function [] -> [] | xs -> xs @ [ "baz" ])
   in
   let h2 = H.add h "accept" "baz" in
-  aeso "update_all_existing_header_multivalued" (H.get h1 "accept")
+  aeso "update_all_existing_header_multivalued"
+    (H.get_multi_concat h1 "accept")
     (H.get_multi_concat h2 "accept");
-  let h1 = H.update h "third" (function Some _ -> Some "3" | None -> None) in
-  aeh "update_new_header: unchanged" h h1;
-  aeso "update_new_header: headers unchanged" None (H.get h "third");
-  let h1 = H.update h "accept" (function Some _ -> None | None -> None) in
+  let h1 = H.update_all h "accept" (function _ -> []) in
   aeh "update_all_existing_header_multivalue : remove all" (H.remove h "accept")
     h1;
-  let h1 =
-    H.update_last h "accept" (function Some _ -> None | None -> None)
-  in
-  aeso "update_existing_header_remove_multivalue: remove last" (Some "foo")
-    (H.get h1 "accept")
+  let h1 = H.update_all h "third" (function [] -> [ "3"; "33" ] | _ -> []) in
+  let h2 = H.add_multi h "third" [ "3"; "33" ] in
+  aeh "update add new header" h1 h2;
+  let h1 = H.update_all h "third" (function _ -> []) in
+  aeh "update_remove_absent_header" h h1;
+  let h1 = H.update_all h "third" (function [] -> [] | _ -> [ "3" ]) in
+  aeh "update_new_header: unchanged" h h1
 
 let get_multi_tests () =
   aesl "get_multi (init ()) k" [] H.(get_multi (init ()) "a");
@@ -340,6 +360,7 @@ let tests =
       ("Header.to_string", `Quick, to_string_tests);
       ("Header.map", `Quick, map_tests);
       ("Header.update", `Quick, update_tests);
+      ("Header.update_all", `Quick, update_all_tests);
       ("many headers", `Slow, many_headers);
       ("transfer encoding is in correct order", `Quick, transfer_encoding_tests);
       (*todo*)

From 0dba674d98effc01156e1d49d9399e291dfcaf5d Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Tue, 30 Mar 2021 19:32:39 +0200
Subject: [PATCH 05/14] ocamlformat

---
 cohttp-lwt-unix/test/test_parser.ml | 18 ++++++------------
 1 file changed, 6 insertions(+), 12 deletions(-)

diff --git a/cohttp-lwt-unix/test/test_parser.ml b/cohttp-lwt-unix/test/test_parser.ml
index b072b5fb51..025627f0d6 100644
--- a/cohttp-lwt-unix/test/test_parser.ml
+++ b/cohttp-lwt-unix/test/test_parser.ml
@@ -24,6 +24,8 @@ let basic_res =
    Server: Apache/1.3.3.7 (Unix) (Red-Hat/Linux)\r\n\
    Last-Modified: Wed, 08 Jan 2003 23:11:55 GMT\r\n\
    Etag: \"3f80f-1b6-3e1cb03b\"\r\n\
+   Accept: text/*\r\n\
+   Accept: application/xml\r\n\
    Accept-Ranges:  none\r\n\
    Content-Length: 0\r\n\
    Connection: close\r\n\
@@ -244,13 +246,9 @@ let make_simple_req () =
   let open Cohttp in
   let open Cohttp_lwt_unix in
   let expected =
-    "POST /foo/bar HTTP/1.1\r\n\
-     foo: bar\r\n\
-     host: localhost\r\n\
-     user-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"
+    ^ "\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n"
   in
   let req =
     Request.make ~encoding:Transfer.Chunked ~meth:`POST
@@ -263,13 +261,9 @@ let mutate_simple_req () =
   let open Cohttp in
   let open Cohttp_lwt_unix in
   let expected =
-    "POST /foo/bar HTTP/1.1\r\n\
-     foo: bar\r\n\
-     host: localhost\r\n\
-     user-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"
+    ^ "\r\ntransfer-encoding: chunked\r\n\r\n6\r\nfoobar\r\n0\r\n\r\n"
   in
   let req =
     Request.make ~encoding:Transfer.Chunked

From 1f3a23b0d4daa324a5ad23362d4cafea9aa77906 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Tue, 30 Mar 2021 19:45:03 +0200
Subject: [PATCH 06/14] Correction, improvement and changes of
 upgrade/upgrade_last, replaced by upgrade/upgrade_all functions.

---
 cohttp/src/header.ml | 93 ++++++++++++++++++++++++--------------------
 1 file changed, 50 insertions(+), 43 deletions(-)

diff --git a/cohttp/src/header.ml b/cohttp/src/header.ml
index 09e37285d6..2f3166e4fe 100644
--- a/cohttp/src/header.ml
+++ b/cohttp/src/header.ml
@@ -99,32 +99,32 @@ let replace_ last h k v =
   let rec loop seen = function
     | [] -> if seen then [] else raise Not_found
     | (k'', _) :: h when LString.compare k' k'' = 0 ->
-       if last then (k'', v) :: h
-       else if not seen then (k', v) :: loop true h
-       else loop seen h
+        if last then (k'', v) :: h
+        else if not seen then (k', v) :: loop true h
+        else loop seen h
     | x :: h -> x :: loop seen h
   in
   try loop false h with Not_found -> add h k v
 
 let replace = replace_ false
 
-let update_ ~all:all h k f =
-  let vorig =
-    if not all then get h k
-    else
-      match get_multi h k with [] -> None | vs -> Some (String.concat "," vs)
-  in
+let update h k f =
+  let vorig = get h k in
   match (f vorig, vorig) with
   | None, None -> h
-  | None, _ -> if all then remove h k else remove_last h k
+  | None, _ -> remove_last h k
   | Some s, Some s' when s == s' -> h
-  | Some s, _ -> replace_ (not all) h k s
-                 (* if (not all) then only the last value paired
-                     with k is changed *)
+  | Some s, _ -> replace_ true h k s
 
-let update = update_ ~all:true
-
-let update_last = update_ ~all:false
+let update_all h k f =
+  let vorig = get_multi h k in
+  match (f vorig, vorig) with
+  | [], [] -> h
+  | [], _ -> remove h k
+  | xs, xs' when xs = xs' -> h
+  | xs, _ ->
+      let h = remove h k in
+      add_multi h k xs
 
 let map (f : string -> string -> string) (h : t) : t =
   List.map
@@ -202,36 +202,40 @@ let is_header_with_list_value =
   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"))
+
+(* 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.
+*)
 let clean_dup (h : t) : t =
   let add h k v =
-    let to_add = ref false in
-    let rec loop = function
-      | [] ->
-          to_add := true;
-          []
-      | (k', v') :: hs ->
-          if LString.compare k k' = 0 then
-            if is_header_with_list_value k then (k, v' ^ ", " ^ v) :: hs
-            else (
-              to_add := true;
-              hs)
-          else (k', v') :: loop hs
-    in
-    let h = loop h in
-    if !to_add then (k, v) :: h else h
+    if is_set_cookie k = 0 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 is_header_with_list_value k then (k, v' ^ "," ^ v) :: hs
+              else (
+                to_add := true;
+                hs)
+            else (k', v') :: loop hs
+      in
+      let h = loop h in
+      if !to_add then (k, v) :: h else h
   in
   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)
+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
-    (
-      let vs = get_multi h k in
-      match vs with
-      | [] -> None
-      | _ ->  Some (String.concat "," vs))
-  else
-    get h k
+    let vs = get_multi h k in
+    match vs with [] -> None | _ -> Some (String.concat "," vs)
+  else get h k
 
 let parse_content_range s =
   try
@@ -285,13 +289,16 @@ let get_acceptable_media_ranges headers =
   Accept.media_ranges (get_multi_concat ~list_value_only:true headers "accept")
 
 let get_acceptable_charsets headers =
-  Accept.charsets (get_multi_concat ~list_value_only:true headers "accept-charset")
+  Accept.charsets
+    (get_multi_concat ~list_value_only:true headers "accept-charset")
 
 let get_acceptable_encodings headers =
-  Accept.encodings (get_multi_concat ~list_value_only:true headers "accept-encoding")
+  Accept.encodings
+    (get_multi_concat ~list_value_only:true headers "accept-encoding")
 
 let get_acceptable_languages headers =
-  Accept.languages (get_multi_concat ~list_value_only:true headers "accept-language")
+  Accept.languages
+    (get_multi_concat ~list_value_only:true headers "accept-language")
 
 (* Parse the transfer-encoding and content-length headers to
  * determine how to decode a body *)

From a142725e8a53eff6e01997cbad1783a9991eef60 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Tue, 30 Mar 2021 19:45:44 +0200
Subject: [PATCH 07/14] Documentation: correction and completion

---
 cohttp/src/header.mli | 177 ++++++++++++++++++++++++++----------------
 1 file changed, 109 insertions(+), 68 deletions(-)

diff --git a/cohttp/src/header.mli b/cohttp/src/header.mli
index ee898f159d..7c477b3bd9 100644
--- a/cohttp/src/header.mli
+++ b/cohttp/src/header.mli
@@ -14,91 +14,74 @@
  *
   }}}*)
 
-(** Associative list of HTTP headers pair of key and value. Order is preserved,
-    meaning duplicated keys are neither removed or concataned by default (see
-    [clean_dup] to do it). *)
+(** Associative list representing HTTP headers. Order of transmission is
+    preserved, which implies that headers with same name are neither removed or
+    concataned by default (see [clean_dup] to do that). *)
 type t [@@deriving sexp]
 (** The type for HTTP headers. *)
 
 val init : unit -> t
-(** [init ()] constructs a fresh, empty map of HTTP headers. *)
+(** [init ()] constructs a fresh, empty list of HTTP headers. *)
 
 val is_empty : t -> bool
-(** [is_empty h] tests whether HTTP headers are empty or not. *)
+(** [is_empty h] tests whether HTTP headers [h] are empty or not. *)
 
 val of_list : (string * string) list -> t
-(** [of_list l] creates an header structure with same content and order than l,
-    meaning the invariant [to_list (of_list l) = l] is true. *)
+(** [of_list l] construct a fresh headers from the content of [l] and in same
+    order. [to_list] and [of_list] are defined such as [to_list (of_list l) = l]
+    is true with case insensitive comparison. *)
 
 val to_list : t -> (string * string) list
-(** [to_list h] convert HTTP headers h to a list. Order is preserved. *)
+(** [to_list h] converts HTTP headers [h] to a list. Order is preserved.
+
+    {e Invariant (with case insensitive comparison):} [to_list (of_list l) = l] *)
 
 val init_with : string -> string -> t
-(** [init_with k v] construct a fresh map of HTTP headers with a single pair of
-    key and value [(k, v)]. *)
+(** [init_with k v] construct a fresh HTTP headers with a single header with
+    name [k] and value [v]. *)
 
 val add : t -> string -> string -> t
-(** [add h k v] adds a key and value to an existing header list. *)
+(** [add h k v] adds the header name [k] and it associated value [v] at the end
+    of header list [h]. *)
 
 val add_list : t -> (string * string) list -> t
-(** [add_list h l] adds each key and value pairs in [l] to the header list [h]
-    in order, meaning [to_list (add_list h l) = to_list h @ l] *)
+(** [add_list h l] adds in order all header pairs contained in [l] to the header
+    list [h].
+
+    {e Invariant (with case insensitive comparison):}
+    [to_list (add_list h l) = to_list h @ l] *)
 
 val add_multi : t -> string -> string list -> t
-(** [add_multi h k vs] add multiple values to a key in an existing header map by
-    calling [add h k v] (without concatenate the values).
+(** [add_multi h k vs] add multiple header pairs with same name [h] and values
+    contained in [vs] in [h]. The new headers are in the same order that in
+    [vs].
 
-    Invariant : [get_multi (add_multi h k vs) k = existing @ vs] if
-    [get_multi h k = existing] *)
+    {e Invariant:} [get_multi (add_multi h k vs) k = (get_multi h k) @ vs] *)
 
 val add_opt : t option -> string -> string -> t
-(** [add_opt hopt k v] adds the pair [(k, v)] to [h] if [hopt] is [Some h], or
-    constructs a fresh header list with this pair if [hopt] is [None]. *)
+(** [add_opt hopt k v] adds the header [(k, v)] to [h] if [hopt] is [Some h], or
+    constructs a fresh header list containing this single header if [hopt] is
+    [None]. *)
 
 val add_unless_exists : t -> string -> string -> t
-(** [add_unless_exists h k v] adds [(k, v)] to [h] unless the key is already
-    present in the header.
-
-    Invariant : [add_unless_exists h k _ = h if mem h k = true] *)
+(** [add_unless_exists h k v] adds [(k, v)] to [h] unless the header name [k] is
+    already present in the header. *)
 
 val add_opt_unless_exists : t option -> string -> string -> t
 (** [add_opt_unless_exists h k v] adds [(k, v)] to [h] if [hopt] is [Some h]
-    unless the key is already present in the header. If [h] is [None] then a
-    fresh header is allocated containing the pair [(k,
-   v)]. *)
+    unless the header name [k] is already present in the headers. If [h] is
+    [None] then a fresh header list is constructed containing the header
+    [(k, v)]. *)
 
 val remove : t -> string -> t
-(** [remove h k] removes every pair with [k] as key from [h] and return a fresh
-    header set. *)
+(** [remove h k] removes every values associated to the header name [k] from
+    [h]. *)
 
 val replace : t -> string -> string -> t
 (** [replace h k v] replaces the last added value of [k] from [h] and removed
-    all other occurences of [k] if it exists. Otherwise it adds [(k, v)] to [h]. *)
-
-val update : t -> string -> (string option -> string option) -> t
-(** [update h k f] returns a associative list containing the same headers as
-    [h], except for the header [k]. Depending on the value of [v] where [v] is
-    [f (get_multi_concat h k)], the header [k] is added, removed or updated.
-
-    - If [v] is [None], every occurences of the header in [h] and all its value
-      is removed;
+    all other occurences of [k] if it exists. Otherwise it adds [(k, v)] to [h].
 
-    - If [v] is [Some z] then [k] is associated to [z] (and only [z]) in the
-      resulting headers;
-
-    - If [k] was already associated in [h] to a value that is physically equal
-      to [z], [h] is returned unchanged.
-
-    In case [k] should not have multiple values, but has multiple occurences in
-    [h], the use of [clean_dup] may be needed before calling this function to
-    prevent the values of this header to get concatenated. *)
-
-val update_last : t -> string -> (string option -> string option) -> t
-(** [update h k f] does the same work than [update h k f] except only the last
-    value [v] associated to [k] is used and affected, meaning [f] is called with
-    [get h k] and only the pair [(k, v)] is potentially removed or updated
-    depending of the result of [f (get h
-   k)]. *)
+    {e Invariant:} [forall h, k, v. get_multi (replace h k v) = \[ v \]] *)
 
 val mem : t -> string -> bool
 (** [mem h k] returns [true] if the header name [k] appears in [h] and [false]
@@ -112,8 +95,51 @@ val get : t -> string -> string option
     [k] in [h] if it exists and [None] otherwise *)
 
 val get_multi : t -> string -> string list
-(** [get_multi h k] returns a list of all values associated with [k] in the
-    header list [h]. *)
+(** [get_multi h k] returns a list of all values associated with [k] in [h] in
+    order they appear in it. *)
+
+val get_multi_concat : ?list_value_only:bool -> t -> string -> string option
+(** [get_multi_concat h k] returns [Some v] if there is at least one value
+    associated with [k] in [h] and [None] otherwise. [v] is the concatenation of
+    all values paired with [k] in [h], separated by a comma and in order they
+    appear in [h].
+
+    The optional argument [?list_value_only] is [false] by default. If it is
+    [true] and there is at least one value associated to [k], the returned value
+    is the concatenated values only if [k] is a header that can have multiple
+    values (like transfer-encoding or accept). Otherwise, the returned value is
+    the last value paired with [k] in [h].
+
+    {e Invariant:}
+    [forall h, k not a list-value header. get_multi_concat ~list-value-only:true h k = get h k] *)
+
+val update : t -> string -> (string option -> string option) -> t
+(** [update h k f] returns an header list containing the same headers as [h],
+    except for the header name [k]. Depending on the value of [v] where [v] is
+    [f (get h k)], the header pair [(k, v)] is added, removed or updated.
+
+    - If [v] is [None], the last occurence of [k] in [h] is removed;
+
+    - If [v] is [Some w] then the last value paired with [k] in [h] is replaced
+      by [w] if it exists. Otherwise, the pair [(k, w)] is added;
+
+    - If [k] was already associated last in [h] to a value that is physically
+      equal to [w], [h] is returned unchanged. *)
+
+val update_all : t -> string -> (string list -> string list) -> t
+(** [update_all h k f] returns an header list containing the same headers as
+    [h], except for the header [k]. Depending on the list of values [vs] where
+    [vs] is [f (get_multi h k)], the values associated to the header [k] are
+    added, removed or updated.
+
+    - If [vs] is an empty list, every occurences of the header [k] in [h] are
+      removed;
+
+    - If [vs] is a non-empty list, all values previously associated to [k] are
+      removed and all values in [vs] are added with [add_multi];
+
+    - If [k] was already associated in [h] to a list that is equal to [vs], [h]
+      is returned unchanged. *)
 
 val iter : (string -> string -> unit) -> t -> unit
 val map : (string -> string -> string) -> t -> t
@@ -129,20 +155,35 @@ val to_frames : t -> string list
 
 val to_string : t -> string
 
-(* Header management functions *)
-
 val clean_dup : t -> t
-(** [clean_dup h] cleans duplicates in h : if the duplicated headers can not
-    have multiple values, only the last value is kept. Otherwise, the values are
-    concatenated and place at the first position this header is encountered in
-    [h]. *)
-
-val get_multi_concat : ?list_value_only:bool -> t -> string -> string option
-(** [get_multi_concat h k] returns all the values paired with [k] in [h],
-    concatenated and separated by a comma. The optional argument
-    [?list_value_only] is [false] by default. If it is [true], then the returned
-    string can contain multiple values only if the searched header can have
-    multiple values (like transfer-encoding or accept). *)
+(** [clean_dup h] cleans duplicates in h following
+    {{:https://tools.ietf.org/html/rfc7230#section-3.2.2} RFC7230§3.2.2}; if a
+    duplicated header can not have multiple values, only the last value is kept
+    in place. Otherwise, the values are concatenated and place at the first
+    position the header is encountered in [h].
+
+    Already concatenated values (like [anhost.com, anotherhost.com] in the
+    example below) are not affected by [clean_dup]. For example,
+
+    {v
+    transfer-encoding: gzip
+    host: afirsthost.com
+    connection: keep-alive
+    host: anhost.com, anotherhost.com
+    transfer-encoding: chunked
+    v}
+
+    becomes
+
+    {v
+    transfer-encoding: gzip, chunked
+    connection: keep-alive
+    host: anhost.com, anotherhost.com
+    v}
+
+    Finally, following {{:https://tools.ietf.org/html/rfc7230#section-3.2.2}
+    RFC7230§3.2.2}, the header [Set-cookie] is treated as an exception and
+    ignored by [clean_dup]. *)
 
 val get_content_range : t -> Int64.t option
 val get_media_type : t -> string option

From 3698432c84b0b51a58886bd7425d470245a18306 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Tue, 30 Mar 2021 19:47:06 +0200
Subject: [PATCH 08/14] Fuzzing tests for header module

---
 cohttp.opam                |   1 +
 cohttp/fuzz/dune           |  26 ++
 cohttp/fuzz/fuzz_header.ml | 562 +++++++++++++++++++++++++++++++++++++
 cohttp/fuzz/inputs/input   |   1 +
 4 files changed, 590 insertions(+)
 create mode 100644 cohttp/fuzz/dune
 create mode 100644 cohttp/fuzz/fuzz_header.ml
 create mode 100644 cohttp/fuzz/inputs/input

diff --git a/cohttp.opam b/cohttp.opam
index 06d1e89b75..d89e7f9767 100644
--- a/cohttp.opam
+++ b/cohttp.opam
@@ -44,6 +44,7 @@ depends: [
   "fmt" {with-test}
   "jsonm" {build}
   "alcotest" {with-test}
+  "crowbar" {with-test}
 ]
 build: [
   ["dune" "subst"] {dev}
diff --git a/cohttp/fuzz/dune b/cohttp/fuzz/dune
new file mode 100644
index 0000000000..a967e4790c
--- /dev/null
+++ b/cohttp/fuzz/dune
@@ -0,0 +1,26 @@
+(executable
+  (name fuzz_header)
+  (libraries crowbar cohttp))
+
+(rule
+ (alias runtest)
+  (package cohttp)
+  (action
+    (run ./fuzz_header.exe)))
+
+(rule
+ (alias fuzz)
+ (deps
+  (:exe fuzz_header.exe)
+  (source_tree inputs))
+ (action
+  (run afl-fuzz -i inputs -o findings -- ./%{exe} @@)))
+
+(rule
+ (alias bun-fuzz)
+ (locks %{project_root}/bun)
+ (deps
+  (:exe fuzz_me.exe)
+  (source_tree input))
+ (action
+  (run bun --input inputs --output findings -- ./%{exe})))
diff --git a/cohttp/fuzz/fuzz_header.ml b/cohttp/fuzz/fuzz_header.ml
new file mode 100644
index 0000000000..577a096676
--- /dev/null
+++ b/cohttp/fuzz/fuzz_header.ml
@@ -0,0 +1,562 @@
+(*{{{ Copyright (c) 2021 Carine Morel <carine@tarides.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *}}}*)
+
+module H = Cohttp.Header
+
+(** Here, we test the Header module with fuzzing. Some of these tests may be
+    redundant with Alcotest tests.
+
+    The tests are launched with [dune runtest] but can also be run with [afl]
+    with the command line : [dune build @cohttp/fuzz/fuzz --no-buffer].
+
+    The tests below reflects the semantics we want for each function, however in
+    some cases, it may actually be specific to the current implementation and
+    does not necessary need to be enforced in future implementations. To make it
+    clear, tests are annoted by their categories:
+
+    - FS (Functions semantics): tests the semantics described in the
+      documentation.
+
+    - SI (Specific to current Implementation): these tests are here to check the
+      implementation is doing what we thing it is doing but may change
+      accordingly to implementation changes. *)
+
+(* Generators *)
+let list_value_headers =
+  [|
+    "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";
+  |]
+
+(** Pick a random list-value header name from a predefined array of values. *)
+let list_value_header_gen =
+  let open Crowbar in
+  let gen =
+    map
+      [ range (Array.length list_value_headers) ]
+      (fun i -> list_value_headers.(i))
+  in
+  let printer fmt str = pp fmt "%s" str in
+  with_printer printer gen
+
+(** Generate a tchar following {{https://tools.ietf.org/html/rfc7230#appendix-B}RFC 7230}.
+
+    tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" /
+    "_" / "`" / "|" / "~" / DIGIT / ALPHA *)
+let tchar_gen =
+  let tchar_code_gen =
+    let uppercased_letter = Crowbar.range ~min:65 26 in
+    let lowercased_letter = Crowbar.range ~min:97 26 in
+    let others =
+      List.map
+        (fun i -> Crowbar.const i)
+        [
+          33 (* ! *);
+          35 (* # *);
+          36 (* $ *);
+          37 (* % *);
+          38 (* & *);
+          42 (* * *);
+          43 (* + *);
+          45 (* - *);
+          46 (* . *);
+          94 (* ^ *);
+          95 (* _ *);
+          96 (* ` *);
+          124 (* | *);
+          126 (* ~ *);
+        ]
+      |> Crowbar.choose
+    in
+    let digit_and_others = Crowbar.(choose [ others; range ~min:48 10 ]) in
+    Crowbar.(choose [ lowercased_letter; uppercased_letter; digit_and_others ])
+  in
+  Crowbar.(map [ tchar_code_gen ] (fun i -> Char.escaped (Char.chr i)))
+
+(** Generate a non-emoty word of arbitrary length (composed of letters only). *)
+let word_gen =
+  let open Crowbar in
+  let gen =
+    fix (fun word_gen ->
+        choose
+          [
+            (* one letter word *)
+            tchar_gen;
+            (* two letters word *)
+            map [ tchar_gen; tchar_gen ] (fun l1 l2 -> l1 ^ l2);
+            (* add one letter *)
+            map [ tchar_gen; word_gen ] (fun l w -> l ^ w);
+          ])
+  in
+  let printer = pp_string in
+  with_printer printer gen
+
+(** Generate an header name: either a predefined list-value header or a random
+    word *)
+let header_name_gen =
+  let open Crowbar in
+  let gen = choose [ list_value_header_gen; word_gen ] in
+  let printer = pp_string in
+  with_printer printer gen
+
+let header_printer fmt (k, v) = Crowbar.pp fmt "%s, %s" k v
+
+(** Generate a header key/value pair *)
+let header_gen : (string * string) Crowbar.gen =
+  let open Crowbar in
+  let gen_setcookie = pair (const "Set-cookie") word_gen in
+  let gen_otherheader = pair header_name_gen word_gen in
+  let gen =
+    (* one in ten generate header is a "set-cookie" header *)
+    choose (gen_setcookie :: List.init 9 (fun _ -> gen_otherheader))
+  in
+  with_printer header_printer gen
+
+(** Generate a list of headers *)
+let header_list_gen : (string * string) list Crowbar.gen =
+  let open Crowbar in
+  let gen = list header_gen in
+  let printer = pp_list header_printer in
+  with_printer printer gen
+
+(** Generate a [Cohttp.Header.t] headers. *)
+let headers_gen : H.t Crowbar.gen =
+  let open Crowbar in
+  let gen =
+    fix (fun headers_gen ->
+        choose
+          [
+            (* empty header *)
+            const (H.init ());
+            (* add one pair (k, v) *)
+            map [ header_gen; headers_gen ] (fun (k, v) h -> H.add h k v);
+            (* add a list of headers *)
+            map [ headers_gen; header_list_gen ] (fun h l -> H.add_list h l);
+          ])
+  in
+  let printer fmt h = Crowbar.pp fmt "\n%s@." (H.to_string h) in
+  with_printer printer gen
+
+(* Tests *)
+(* Important note : keys must be lowercased before comparison *)
+let eqssl l1 l2 =
+  List.map (fun (k, v) -> (String.lowercase_ascii k, v)) l1
+  = List.map (fun (k, v) -> (String.lowercase_ascii k, v)) l2
+
+let is_empty_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall h, k, v. is_empty (add h k v) = false) *)
+    add_test ~name:"[is_empty] returns false on a non empty header"
+      [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+        check_eq false H.(is_empty (add h k v))))
+
+let init_with_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall k v. to_list (init_with k v) = [String.lowercase 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) ]))
+
+let mem_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall k. mem (init ()) k = false *)
+    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)) *)
+    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))))
+
+let add_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall k, v, h. mem (add h k v) k = true *)
+    add_test ~name:"mem (add h k v) k  = true"
+      [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+        check_eq true H.(mem (add h k v) k));
+    add_test
+    (* FS *)
+    (* 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))))
+
+let to_list_of_list_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall h. to_list (of_list h) = h (with lowercase key comparison) *)
+    add_test ~name:"to_list (of_list h) = h" [ header_list_gen ] (fun h ->
+        check_eq ~eq:eqssl H.(to_list (of_list h)) h);
+
+    (* FS and RFC *)
+    (* forall h, k1, v1, k2, v2. to_list (add (add h k1 v1) k2 v2) = to_list \
+       h @ [k1, v1; k2, v2] *)
+    add_test ~name:"checking [to_list] order after multiple [add] calls"
+      [ headers_gen; header_name_gen; word_gen; header_name_gen; word_gen ]
+      (fun h k1 v1 k2 v2 ->
+        check_eq ~eq:eqssl
+          H.(to_list (add (add h k1 v1) k2 v2))
+          H.(to_list h @ [ (k1, v1); (k2, v2) ])))
+
+let add_opt_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall hopt, k, v.
+              add_opt hopt k v = | add h k v     if hopt = Some h
+                                 | init_with k v if hopt = None *)
+    add_test ~name:"add_opt (Some h) = add and add_opt None = init_with"
+      [ option headers_gen; header_name_gen; word_gen ] (fun hopt k v ->
+        check_eq
+          H.(match hopt with None -> init_with k v | Some h -> add h k v)
+          H.(add_opt hopt k v)))
+
+let add_unless_exists_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall h, k, v. if mem h k = true then add_unless_exists h k v = h *)
+    add_test ~name:"[add_unless_exists h k v] does nothing if k exists"
+      [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
+      (fun h l k v1 v2 ->
+        (* A random header such as mem h k = true *)
+        let h = H.(add_list (add h k v1) l) in
+        check_eq H.(add_unless_exists h k v2) h);
+    (* FS *)
+    (* forall h, k, v. if mem h k = false then add_unless_exists h k v = add \
+         h k v *)
+    add_test ~name:"add_unless_exists = add if key does not exist"
+      [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+        (* Making sure as mem h k = false *)
+        guard (not (H.mem h k));
+        check_eq H.(add_unless_exists h k v) H.(add h k v)))
+
+let add_list () =
+  Crowbar.(
+    (* FS *)
+    (* forall h, l. to_list (add_list h l) = to_list h @ l *)
+    add_test
+      ~name:"[add_list h l] adds all headers in [l] in order at the end of [h]"
+      [ headers_gen; header_list_gen ] (fun h l ->
+        check_eq ~eq:eqssl H.(to_list (add_list h l)) H.(to_list h @ l)))
+
+let add_multi () =
+  Crowbar.(
+    (* FS *)
+    (* forall h, k, vs. add_multi h k vs = add_list h (List.map (fun v -> k, v) vs) *)
+    add_test ~name:"[add_list] and [add_multi] have compatible semantics"
+      [ headers_gen; header_name_gen; list word_gen ] (fun h k vs ->
+        check_eq
+          H.(add_multi h k vs)
+          H.(add_list h (List.map (fun v -> (k, v)) vs)));
+    (* FS *)
+    (* forall h, k, l. get_multi (add_multi h k l) k = get_multi h k @ l *)
+    add_test ~name:"get_multi (add_multi h k l) k = get_multi h k @ l"
+      [ headers_gen; header_name_gen; Crowbar.list word_gen ] (fun h k l ->
+        check_eq H.(get_multi (add_multi h k l) k) H.(get_multi h k @ l)))
+
+let get_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall h k, if mem h k = false then get h k = None *)
+    add_test ~name:"[get h k] returns None if k does not exists in h"
+      [ headers_gen; header_name_gen ] (fun h k ->
+        guard H.(not (mem h k));
+        check_eq H.(get h k) None);
+    (* FS *)
+    (* forall h k, get (add h k v) = Some v *)
+    add_test ~name:"get (add h k v) = Some v"
+      [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+        check_eq H.(get (add h k v) k) (Some v)))
+
+let get_multi_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall h k, if mem h k = false then get_multi h k = [] *)
+    add_test ~name:"[get_multi h k] returns [] if k does not exists in h"
+      [ headers_gen; header_name_gen ] (fun h k ->
+        guard H.(not (mem h k));
+        check_eq H.(get_multi h k) []);
+    (* FS *)
+    (* forall l1, l2, k, v.
+          get_multi (of_list (l1 @ [ (k, v) ] @ l2)) k =
+          get_multi (of_list l1) k @ [ v ] @ get_multi (of_list l2) k *)
+    add_test ~name:"[get_multi] returns values in transmission order"
+      [ header_list_gen; header_list_gen; header_name_gen; word_gen ]
+      (fun l1 l2 k v ->
+        check_eq
+          H.(get_multi (of_list (l1 @ [ (k, v) ] @ l2)) k)
+          H.(get_multi (of_list l1) k @ [ v ] @ get_multi (of_list l2) k));
+    (* FS and RFC7230§3.2.2 *)
+    (* forall h, v1, v2, forall k in list values headers.
+            get_multi (add (add h k v1) k v2)) k = get_multi h k @ [v1; v2] *)
+    add_test ~name:"headers order is preserved"
+      [ headers_gen; list_value_header_gen; word_gen; word_gen ]
+      (fun h k v1 v2 ->
+        check_eq
+          H.(get_multi (add (add h k v1) k v2) k)
+          (H.(get_multi h k) @ [ v1; v2 ])))
+
+let remove_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall h, k. mem (remove h k) k = false *)
+    add_test ~name:"[remove] removes all values associated to a key"
+      [ headers_gen; header_name_gen ] (fun h k ->
+        check_eq false H.(mem (remove h k) k));
+    (* FS *)
+    (* forall h, k. remove (remove h k) k = remove h k*)
+    add_test ~name:"(fun x -> remove x k) is idempotent"
+      [ headers_gen; header_name_gen ] (fun h k ->
+        check_eq H.(remove (remove h k) k) H.(remove h k)))
+
+let replace_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall h, k, v. get_multi (replace h k v) = [ v ] *)
+    add_test ~name:"[replace] replaces the last value and remove the others"
+      [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
+      (fun h l k v1 v2 ->
+        check_eq H.(get_multi (replace h k v1) k) [ v1 ];
+        (* This second check is to make sure the case where mem h k = true is tested *)
+        let h =
+          H.(add_list (add h k v1) l)
+          (* h is built such as mem h k = true *)
+        in
+        check_eq H.(get_multi (replace h k v2) k) [ v2 ]);
+    (* FS *)
+    (* forall h, k, v. if mem h k = false then replace h k v = add h k v) *)
+    add_test ~name:"replace h k v = add h k v if k does not exists in h"
+      [ headers_gen; header_name_gen; word_gen ] (fun h k v ->
+        guard H.(mem h k = false);
+        check_eq H.(replace h k v) H.(add h k v));
+    (* SI *)
+    (* forall h, l, k, v1, v2.
+           if mem (of_list l) k = false then
+              replace (add_list h ([ k, v1 ] @ l)) k v2 =
+             add_list (add (remove h k) k v2) l k) *)
+    add_test ~name:"[replace] does not change headers order"
+      [ headers_gen; header_list_gen; header_name_gen; word_gen; word_gen ]
+      (fun h l k v1 v2 ->
+        guard H.(not (mem (of_list l) k));
+        (* A random headers such as mem h k = true *)
+        let h1 = H.(add_list h ([ (k, v1) ] @ l)) in
+        let h2 = H.(add_list (remove h k) ([ (k, v2) ] @ l)) in
+        check_eq ~eq:eqssl H.(to_list (replace h1 k v2)) H.(to_list h2)))
+
+let update_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall h k, update h k id = h  *)
+    add_test ~name:"[update h k id] does nothing"
+      [ headers_gen; header_name_gen ] (fun h k ->
+        check_eq H.(update h k (fun x -> x)) h);
+    (*FS*)
+    (* forall h k f, remove (update h k f) k = remove h k *)
+    add_test ~name:"[update h k _] only changes k "
+      [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+        check_eq H.(remove (update h k (fun _ -> None)) k) H.(remove h k);
+        check_eq H.(remove (update h k (fun _ -> Some w)) k) H.(remove h k));
+    (*FS*)
+    add_test ~name:"[update h k (fun _ -> None)] removes last occurence of k."
+      [ headers_gen; header_name_gen ] (fun h k ->
+        let h1 = H.update h k (fun _ -> None) in
+        let r1 = H.get_multi h1 k in
+        let r2 =
+          match List.rev (H.get_multi h k) with
+          | [] -> []
+          | _ :: xs -> List.rev xs
+        in
+        check_eq r1 r2);
+    (*FS*)
+    add_test
+      ~name:
+        "[update h k (function Some _ -> Some w)] replaces last occurence of k."
+      [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+        let h1 = H.update h k (fun _ -> Some w) in
+        let r1 = H.get_multi h1 k in
+        let r2 =
+          match List.rev (H.get_multi h k) with
+          | [] -> [ w ]
+          | _ :: xs -> List.rev (w :: xs)
+        in
+        check_eq r1 r2))
+
+let update_all_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall h k, update_all h k id = h  *)
+    add_test ~name:"[update_all h k id] does nothing"
+      [ headers_gen; header_name_gen ] (fun h k ->
+        check_eq H.(update_all h k (fun x -> x)) h);
+    (*FS*)
+    (* forall h k f, remove (update_all h k f) k = remove h k *)
+    add_test ~name:"[update_all h k _] only changes k "
+      [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+        check_eq H.(remove (update_all h k (fun _ -> [])) k) H.(remove h k);
+        check_eq H.(remove (update_all h k (fun _ -> [ w ])) k) H.(remove h k));
+    (*FS*)
+    add_test ~name:"[update_all h k (fun _ -> [])] removes all occurences of k."
+      [ headers_gen; header_name_gen ] (fun h k ->
+        let h1 = H.update_all h k (fun _ -> []) in
+        check_eq H.(get_multi h1 k) []);
+    (*FS*)
+    add_test
+      ~name:
+        "[update_all h k (function _ -> [w])] removes all occurences of k and \
+         add one." [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+        let h1 = H.update_all h k (fun _ -> [ w ]) in
+        let r1 = H.get_multi h1 k in
+        let r2 = [ w ] in
+        check_eq r1 r2))
+
+let get_multi_concat_test () =
+  Crowbar.(
+    (* FS *)
+    (* forall h, k. if mem h k = false then get_multi_concat h k = None *)
+    add_test
+      ~name:"[get_multi_concat h k] returns \"\" if k does not exists in h"
+      [ headers_gen; header_name_gen ] (fun h k ->
+        guard H.(not (mem h k));
+        check_eq H.(get_multi_concat h k) None);
+    (* FS *)
+    (* forall h, k. get_multi_concat ~list_value_only:true h k = get h k
+       if k is not a list value header *)
+    add_test ~name:"[get_multi_concat] optional argument works properly"
+      [ headers_gen; word_gen ] (fun h k ->
+        guard (not (Array.mem (String.lowercase_ascii k) list_value_headers));
+        check_eq H.(get_multi_concat ~list_value_only:true h k) H.(get h k));
+    (* FS - Very important for RFC 7230.3.2.2 *)
+    add_test ~name:"[get_multi_concat] returns values in transmission order"
+      [ header_list_gen; header_list_gen; header_name_gen; word_gen ]
+      (fun l1 l2 k v ->
+        let str_opt ?(bfr = false) ?(aft = false) s =
+          match s with
+          | None -> ""
+          | Some v -> if bfr then "," ^ v else if aft then v ^ "," else v
+        in
+        check_eq
+          H.(str_opt (get_multi_concat (of_list (l1 @ [ (k, v) ] @ l2)) k))
+          H.(
+            str_opt ~aft:true (get_multi_concat (of_list l1) k)
+            ^ v
+            ^ str_opt ~bfr:true (get_multi_concat (of_list l2) k))))
+
+(* Note : clean_dup does nothing to already concatenated headers. For
+   example, ["a", "v1,v2"] will be not be cleaned. *)
+let clean_dup_test () =
+  Crowbar.(
+    (* FS *)
+    (* Check that there is no more duplicates (except set-cookie). *)
+    add_test
+      ~name:
+        "All headers name in [h] appears strictly once in [clean_dup h] except \
+         for [set-cookie]" [ headers_gen ] (fun h ->
+        let h = H.remove h "set-cookie" in
+        let h = H.(to_list (clean_dup h)) in
+        let compare_key (k, _) (k', _) = compare k k' in
+        check_eq (List.sort_uniq compare_key h) (List.sort compare_key h));
+    (* FS *)
+    (* forall h, k in list_value_headers.
+       String.concat "," (get_multi_concat h k) = get (clean_dup h) k *)
+    add_test ~name:"[clean_dup] concatenates properly list-value headers"
+      [ headers_gen; list_value_header_gen ] (fun h k ->
+        check_eq H.(get_multi_concat h k) H.(get (clean_dup h) k));
+    (* FS *)
+    (* forall h. clean_dup (clean_dup h) = clean_dup h *)
+    add_test ~name:"[clean_dup] is idempotent" [ headers_gen ] (fun h ->
+        check_eq H.(clean_dup (clean_dup h)) H.(clean_dup h));
+    (* FS *)
+    (* forall h. get_multi (clean_dup h) "set-cookie" = get_multi h "set-cookie"*)
+    add_test ~name:"[clean_dup] does nothing to [set-cookie] headers"
+      [ headers_gen ] (fun h ->
+        check_eq
+          H.(get_multi h "set-cookie")
+          H.(get_multi (clean_dup h) "set-cookie"));
+    (* FS *)
+    (* As the generated header values are only composed of letters (it
+       does not generate concatenated values like "gzip,chunked"), the
+       only cases where there are commas in a value is if [clean_dup]
+       concatenated multiple values.
+
+       This test checks that only one value is kept for non-list-value
+       headers and that this value is the last one. *)
+    add_test
+      ~name:"Only list-value headers can have multiple concatenated values "
+      [ headers_gen ] (fun h ->
+        (* As it is an exception, [set-cookie] is removed. *)
+        let h = H.remove h "set-cookie" in
+        let h' = H.(clean_dup h) in
+        let has_multiple_values v =
+          match String.split_on_char ',' v with
+          | [] | [ _ ] -> false
+          | _ -> true
+        in
+        check_eq true
+          H.(
+            fold
+              (fun k v b ->
+                if Array.mem k list_value_headers then b
+                else if has_multiple_values v then false
+                else b && get h k = Some v)
+              h' true)))
+
+let () =
+  init_with_test ();
+  is_empty_test ();
+  mem_test ();
+  add_test ();
+  to_list_of_list_test ();
+  add_opt_test ();
+  add_unless_exists_test ();
+  add_list ();
+  add_multi ();
+  get_test ();
+  get_multi_test ();
+  get_multi_concat_test ();
+  remove_test ();
+  replace_test ();
+  update_test ();
+  update_all_test ();
+  clean_dup_test ();
+  ()
diff --git a/cohttp/fuzz/inputs/input b/cohttp/fuzz/inputs/input
new file mode 100644
index 0000000000..a459bc245b
--- /dev/null
+++ b/cohttp/fuzz/inputs/input
@@ -0,0 +1 @@
+something
\ No newline at end of file

From 6022be30bb039a0f1826cf04ad37508f40cd5c58 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Wed, 31 Mar 2021 23:40:17 +0200
Subject: [PATCH 09/14] Changes log for PR#747

---
 CHANGES.md | 32 ++++++++++++++++++++++++++++++++
 1 file changed, 32 insertions(+)

diff --git a/CHANGES.md b/CHANGES.md
index 6227a2bece..a599d6554b 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,3 +1,35 @@
+## ? (2021-03-30)
+(@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 Alcootest tests as well as fuzzing tests for this particular module.
+
+### Purpose
+
+The new header implementation uses an associative list instead of a map to represent headers and is focused on predictibility 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.
+
+Also, to get an intuitive function behaviour, no extra work to enforce RFCs is done by the basic functions. For example, RFC7230§3.2.2 requires that a sender does not send multiple values for a non list-value header. This particular rule could require the ```Header.add``` function to remove previous values of non-list-value headers, which means some changes of the headers would be out of control of the user. With the current implementation, an user has to actively call dedicated functions to enforce such RFCs (here ```Header.clean_dup```).
+
+### Semantic changes
+Two functions have a semantic change : ```get``` and ```update```.
+
+#### get
+```get``` was previously doing more than just returns the value associated to a key; it was also checking if the searched header could have multiple values: if not, the last value associated to the header was returned; otherwise, all the associated values were concatenated and returned. This semantics does not match the global idea behind the new header implementation, and would also be very unefficient.
+
++ The new ```get``` function only returns the last value associated to the searched header.
++ ```get_multi_concat``` function has been added to get a result similar to the previous ```get``` function.
+
+#### update
+```update``` is a pretty new function (#703) and changes are minor and related to ```get``` semantic changes.
+
++ ```update h k f``` is now modifying only the last occurences of the header ```k``` instead of all its occurrences.
++ a new function ```update_all``` function has been added and work on all the occurrences of the updated header.
+
+### New functions :
+
++ ```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.
+
 ## v4.0.0 (2021-03-24)
 
 - cohttp.response: fix malformed status header for custom status codes (@mseri @aalekseyev #752)

From f866ef03d84c75b5deb6f337e47099949e62e454 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Wed, 31 Mar 2021 23:40:39 +0200
Subject: [PATCH 10/14] Typos in doc

---
 cohttp/src/header.mli | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/cohttp/src/header.mli b/cohttp/src/header.mli
index 7c477b3bd9..a3edb4ec9e 100644
--- a/cohttp/src/header.mli
+++ b/cohttp/src/header.mli
@@ -156,7 +156,7 @@ val to_frames : t -> string list
 val to_string : t -> string
 
 val clean_dup : t -> t
-(** [clean_dup h] cleans duplicates in h following
+(** [clean_dup h] cleans duplicates in [h] following
     {{:https://tools.ietf.org/html/rfc7230#section-3.2.2} RFC7230§3.2.2}; if a
     duplicated header can not have multiple values, only the last value is kept
     in place. Otherwise, the values are concatenated and place at the first

From e815ac89fcadc60cb284376773fb5550f2e48c20 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Thu, 1 Apr 2021 15:36:20 +0200
Subject: [PATCH 11/14] Reformat

---
 cohttp/fuzz/dune           | 10 +++++-----
 cohttp/fuzz/fuzz_header.ml |  3 ++-
 2 files changed, 7 insertions(+), 6 deletions(-)

diff --git a/cohttp/fuzz/dune b/cohttp/fuzz/dune
index a967e4790c..88906b3c73 100644
--- a/cohttp/fuzz/dune
+++ b/cohttp/fuzz/dune
@@ -1,12 +1,12 @@
 (executable
-  (name fuzz_header)
-  (libraries crowbar cohttp))
+ (name fuzz_header)
+ (libraries crowbar cohttp))
 
 (rule
  (alias runtest)
-  (package cohttp)
-  (action
-    (run ./fuzz_header.exe)))
+ (package cohttp)
+ (action
+  (run ./fuzz_header.exe)))
 
 (rule
  (alias fuzz)
diff --git a/cohttp/fuzz/fuzz_header.ml b/cohttp/fuzz/fuzz_header.ml
index 577a096676..1b44eb13ab 100644
--- a/cohttp/fuzz/fuzz_header.ml
+++ b/cohttp/fuzz/fuzz_header.ml
@@ -73,7 +73,8 @@ let list_value_header_gen =
   let printer fmt str = pp fmt "%s" str in
   with_printer printer gen
 
-(** Generate a tchar following {{https://tools.ietf.org/html/rfc7230#appendix-B}RFC 7230}.
+(** Generate a tchar following
+    {{:https://tools.ietf.org/html/rfc7230#appendix-B} RFC 7230}.
 
     tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" /
     "_" / "`" / "|" / "~" / DIGIT / ALPHA *)

From 0518e97bf7be4422bbc844f0ba86e3d33f08a583 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Thu, 1 Apr 2021 18:55:43 +0200
Subject: [PATCH 12/14] Update cohttp/fuzz/fuzz_header.ml

Co-authored-by: Marcello Seri <mseri@users.noreply.github.com>
---
 cohttp/fuzz/fuzz_header.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/cohttp/fuzz/fuzz_header.ml b/cohttp/fuzz/fuzz_header.ml
index 1b44eb13ab..7976fe5c36 100644
--- a/cohttp/fuzz/fuzz_header.ml
+++ b/cohttp/fuzz/fuzz_header.ml
@@ -445,7 +445,7 @@ let update_all_test () =
     add_test
       ~name:
         "[update_all h k (function _ -> [w])] removes all occurences of k and \
-         add one." [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
+         adds w." [ headers_gen; header_name_gen; word_gen ] (fun h k w ->
         let h1 = H.update_all h k (fun _ -> [ w ]) in
         let r1 = H.get_multi h1 k in
         let r2 = [ w ] in

From d63ac0569c1d8f44f96da0044e424ba18613c4a5 Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Fri, 2 Apr 2021 10:36:27 +0200
Subject: [PATCH 13/14] Typos in comments

---
 cohttp/fuzz/fuzz_header.ml | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/cohttp/fuzz/fuzz_header.ml b/cohttp/fuzz/fuzz_header.ml
index 7976fe5c36..d53b743c04 100644
--- a/cohttp/fuzz/fuzz_header.ml
+++ b/cohttp/fuzz/fuzz_header.ml
@@ -30,7 +30,7 @@ module H = Cohttp.Header
       documentation.
 
     - SI (Specific to current Implementation): these tests are here to check the
-      implementation is doing what we thing it is doing but may change
+      implementation is doing what we think it is doing but may change
       accordingly to implementation changes. *)
 
 (* Generators *)
@@ -108,7 +108,7 @@ let tchar_gen =
   in
   Crowbar.(map [ tchar_code_gen ] (fun i -> Char.escaped (Char.chr i)))
 
-(** Generate a non-emoty word of arbitrary length (composed of letters only). *)
+(** Generate a non-empty word of arbitrary length (composed of tchar only). *)
 let word_gen =
   let open Crowbar in
   let gen =
@@ -142,7 +142,7 @@ let header_gen : (string * string) Crowbar.gen =
   let gen_setcookie = pair (const "Set-cookie") word_gen in
   let gen_otherheader = pair header_name_gen word_gen in
   let gen =
-    (* one in ten generate header is a "set-cookie" header *)
+    (* one in ten generated header is a "set-cookie" header *)
     choose (gen_setcookie :: List.init 9 (fun _ -> gen_otherheader))
   in
   with_printer header_printer gen
@@ -515,7 +515,7 @@ let clean_dup_test () =
           H.(get_multi h "set-cookie")
           H.(get_multi (clean_dup h) "set-cookie"));
     (* FS *)
-    (* As the generated header values are only composed of letters (it
+    (* As the generated header values are only composed of tchar (it
        does not generate concatenated values like "gzip,chunked"), the
        only cases where there are commas in a value is if [clean_dup]
        concatenated multiple values.

From 85bab3ffb11f79335885ac1793a72d139d5db3ab Mon Sep 17 00:00:00 2001
From: Carine Morel <carine@tarides.com>
Date: Fri, 2 Apr 2021 12:09:32 +0200
Subject: [PATCH 14/14] Add Header.fold and Header.iter unitary tests.

---
 cohttp/test/unitary_test_header.ml | 35 +++++++++++++++++++++++++-----
 1 file changed, 30 insertions(+), 5 deletions(-)

diff --git a/cohttp/test/unitary_test_header.ml b/cohttp/test/unitary_test_header.ml
index 4ed22c1057..d3421e8764 100644
--- a/cohttp/test/unitary_test_header.ml
+++ b/cohttp/test/unitary_test_header.ml
@@ -17,6 +17,7 @@ module H = Cohttp.Header
 (** These tests try as much as possible to tests each header functions
     independently. *)
 
+let aei = Alcotest.check Alcotest.int
 let aes = Alcotest.check Alcotest.string
 let aeso = Alcotest.check Alcotest.(option string)
 let aesl = Alcotest.check Alcotest.(list string)
@@ -266,8 +267,33 @@ let map_tests () =
     ]
     H.(to_list (map (fun _k v -> v ^ a) prebuilt))
 
-let fold_tests () = ()
-let iter_tests () = ()
+let fold_tests () =
+  let rev k v acc = H.(add acc k v) in
+  let h1 = H.(fold rev prebuilt (init ())) in
+  aessl
+    "[fold (fun k v acc -> H.(add acc k v)) h (init ())] reverses the header"
+    (List.rev H.(to_list h1))
+    H.(to_list prebuilt);
+  let h1 = H.(fold rev (fold rev prebuilt (init ())) (init ())) in
+  aeh "[fold rev (fold rev h (init ())) (init ()) = h] " h1 prebuilt;
+  let count _ _ acc = acc + 1 in
+  aei "[fold (fun _ _ acc -> acc+1) h 0] returns the length of h"
+    (List.length H.(to_list prebuilt))
+    H.(fold count prebuilt 0)
+
+let iter_tests () =
+  let h = ref H.(init ()) in
+  let rev k v = h := H.(add !h k v) in
+  H.(iter rev prebuilt);
+  aessl "[iter (fun k v -> href := H.(add !href k v)) h] reverses the header"
+    (List.rev H.(to_list !h))
+    H.(to_list prebuilt);
+  let c = ref 0 in
+  let count _ _ = c := !c + 1 in
+  aei "[iter (fun _ _ -> count := !count+1) h] works fine"
+    (List.length H.(to_list prebuilt))
+    (H.(iter count prebuilt);
+     !c)
 
 let to_lines_tests () =
   aesl "to_lines h"
@@ -359,13 +385,12 @@ let tests =
       ("Header.to_frames", `Quick, to_frames_tests);
       ("Header.to_string", `Quick, to_string_tests);
       ("Header.map", `Quick, map_tests);
+      ("Header.fold", `Quick, fold_tests);
+      ("Header.iter", `Quick, iter_tests);
       ("Header.update", `Quick, update_tests);
       ("Header.update_all", `Quick, update_all_tests);
       ("many headers", `Slow, many_headers);
       ("transfer encoding is in correct order", `Quick, transfer_encoding_tests);
-      (*todo*)
-      ("Header.fold", `Quick, fold_tests);
-      ("Header.iter", `Quick, iter_tests);
     ]
     @
     if Sys.word_size = 64 then [ ("large header", `Slow, large_header) ] else []