-(*
-type url_syntax_option =
- Url_part_not_recognized
- | Url_part_allowed
- | Url_part_required
-
-* (1) scheme://user:password@host:port/path;params?query#fragment
-*)
-
-let request_uri_syntax = {
- url_enable_scheme = Url_part_not_recognized;
- url_enable_user = Url_part_not_recognized;
- url_enable_password = Url_part_not_recognized;
- url_enable_host = Url_part_not_recognized;
- url_enable_port = Url_part_not_recognized;
- url_enable_path = Url_part_required;
- url_enable_param = Url_part_not_recognized;
- url_enable_query = Url_part_allowed;
- url_enable_fragment = Url_part_not_recognized;
- url_enable_other = Url_part_not_recognized;
- url_accepts_8bits = false;
- url_is_valid = (fun _ -> true);
-}
-
-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
- ()
-
- (** given an HTTP like query string (e.g. "name1=value1&name2=value2&...")
- @return a list of pairs [("name1", "value1"); ("name2", "value2")]
- @raise Malformed_query if the string isn't a valid query string
- @raise Malformed_query_part if some piece of the query isn't valid
- *)
-let split_query_params =
- let (bindings_sep, binding_sep) = (Pcre.regexp "&", Pcre.regexp "=") in
- let http_decode url = Netencoding.Url.decode ~plus:false url in
- fun ~query ->
- let bindings = Pcre.split ~rex:bindings_sep query in
- if List.length bindings < 1 then
- raise (Malformed_query query);
- List.map
- (fun binding ->
- match Pcre.split ~rex:binding_sep binding with
- | [""; b] -> (* '=b' *) raise (Malformed_query_part (binding, query))
- | [a; b] -> (* 'a=b' *) (http_decode a, http_decode b)
- | [a] -> (* 'a=' || 'a' *) (http_decode a, "")
- | _ -> raise (Malformed_query_part (binding, query)))
- bindings
+let (bindings_sep, binding_sep, pieces_sep, header_sep) =
+ (Pcre.regexp "&", Pcre.regexp "=", Pcre.regexp " ", Pcre.regexp ":")
+let header_RE = Pcre.regexp "([^:]*):(.*)"
+
+let url_decode url = Netencoding.Url.decode ~plus:true url
+
+let split_query_params query =
+ let bindings = Pcre.split ~rex:bindings_sep query in
+ match bindings with
+ | [] -> raise (Malformed_query query)
+ | bindings ->
+ List.map
+ (fun binding ->
+ match Pcre.split ~rex:binding_sep binding with
+ | [ ""; b ] -> (* '=b' *)
+ raise (Malformed_query_part (binding, query))
+ | [ a; b ] -> (* 'a=b' *) (url_decode a, url_decode b)
+ | [ a ] -> (* 'a=' || 'a' *) (url_decode a, "")
+ | _ -> raise (Malformed_query_part (binding, query)))
+ bindings
+
+ (** internal, used by generic_input_line *)
+exception Line_completed;;