+module CharSet = Set.Make (Char)
+
+ (** create an "is in" predicate over a character set using an efficient,
+ set-based implementation *)
+let mk_char_predicate chars =
+ let charset =
+ List.fold_left (fun oldset c -> CharSet.add c oldset) CharSet.empty chars
+ in
+ fun c -> CharSet.mem c charset
+
+let is_http_separator =
+ mk_char_predicate
+ [ '('; ')'; '<'; '>'; '@'; ','; ';'; ':'; '\\'; '"'; '/'; '['; ']'; '?';
+ '='; '{'; '}'; ' '; '\t' ]
+
+let is_http_ctl c =
+ match Char.code c with
+ | c when (((c >= 0) && (c <= 31)) || (c = 127)) -> true
+ | _ -> false
+
+ (* internal: used to implement is_* functions *)
+exception Invalid_char;;
+
+let is_http_token s =
+ try
+ String.iter
+ (fun c ->
+ if (is_http_ctl c) || (is_http_separator) c then raise Invalid_char)
+ s;
+ true
+ with Invalid_char -> false
+
+let rec is_http_lws s =
+ (match s.[0] with
+ | ' ' | '\t' -> true
+ | '\r' ->
+ (try
+ (s.[1] = '\n') && ((s.[2] = ' ') || (s.[2] = '\t'))
+ with Invalid_argument "String.get" -> false)
+ | _ -> false)
+
+let is_http_field_name = is_http_token
+
+let is_http_field_value s =
+ let rec strip_quoted_string = function
+ | [] -> (false, [])
+ | '"' :: tl -> (true, tl)
+ | '\\' :: '"' :: tl -> strip_quoted_string tl
+ | hd :: tl -> strip_quoted_string tl
+ in
+ let rec is_http_field_value' = function
+ | '\r' :: '\n' :: sp :: rest when (sp = ' ' || sp = '\t') -> (* strip LWS *)
+ is_http_field_value' rest
+ | c :: rest when (is_http_ctl c && c <> '\t') -> (* \t is in CTL /\ SEP *)
+ false (* CTL aren't allowed *)
+ | '"' :: rest ->
+ let (valid, rest) = strip_quoted_string rest in
+ if not valid then false else is_http_field_value' rest
+ | c :: rest -> is_http_field_value' rest
+ | [] -> true
+ in is_http_field_value' (Http_misc.string_explode s)
+
+let heal_header (name, value) =
+ if not (is_http_field_name name && is_http_field_value value) then
+ raise (Invalid_header (name ^ ": " ^ value))
+ else
+ ()
+