Correct Header.update and add docs. Add [Header.get_multi_concat] fun…

…ction to get the same effect than previous [get] function (on maps) and correct all get_[some header] functions accordingly.

cohttp/src/header.ml

@@ -97,29 +97,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
@@ -163,6 +180,8 @@ let to_string h =
   Buffer.add_string b "\r\n";
   Buffer.contents b
 
+
+(** Header management functions *)
 let headers_with_list_values = Array.map LString.of_string [|
   "accept";"accept-charset";"accept-encoding";"accept-language";
   "accept-ranges";"allow";"cache-control";"connection";"content-encoding";
@@ -195,8 +214,17 @@ let clean_dup (h : t) : t =
   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)
+  then
+    (
+      let vs = get_multi h k in
+      match vs with
+      | [] -> None
+      | _ ->  Some (String.concat "," vs))
+  else
+    get h k
 
-(** original content *)
 let parse_content_range s =
   try
     let start, fini, total =
@@ -226,11 +254,11 @@ let get_content_range headers =
   end
 
 let get_connection_close headers =
+  (* Should it be get_multi_concat ?list_value_only=true ? *)
   match get headers "connection" with
   | Some "close" -> true
   | _ -> false
 
-
 let media_type_re =
   let re = Re.Emacs.re ~case:true "[ \t]*\\([^ \t;]+\\)" in
   Re.(compile (seq ([start; re])))
@@ -249,21 +277,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 -> begin
     match get_content_range headers with

cohttp/src/header.mli

@@ -84,23 +84,33 @@ val remove : t -> string -> t
 *)
 val replace : t -> string -> string -> 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 *)
-(** [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 [None], every occurences of the header in [h] and all
+   its value is removed;
+
+   - 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: 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 update_last: t -> string -> (string option -> string option) -> t
+
 (** [mem h k] returns [true] if the header name [k] appears in [h] and
    [false] otherwise. *)
 val mem : t -> string -> bool
@@ -130,13 +140,20 @@ val to_frames : t -> string list
 
 val to_string : t -> string
 
-(* (TODO : comments) Header management functions *)
-(** [clean_dup h] cleans duplicates in h : if the duplicated header
+(* Header management functions *)
+(** [clean_dup h] cleans duplicates in h : if the duplicated headers
    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. *)
+   kept. Otherwise, the values are concatenated and place at the first
+   position this header is encountered in [h]. *)
 val clean_dup : t -> t
 
+(** [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_multi_concat : ?list_value_only:bool -> t -> string -> string option
+
 val get_content_range : t -> Int64.t option
 val get_media_type : t -> string option
 val get_connection_close : t -> bool