From db0eab65e607d5f499a6f5455d7fcd4130d0b727 Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Tue, 3 Dec 2002 21:34:14 +0000 Subject: [PATCH] - implemented heal_header that sanity checks an header - moved exceptions in http_types --- helm/DEVEL/ocaml-http/http_parser.ml | 78 ++++++++++++++++++++++++--- helm/DEVEL/ocaml-http/http_parser.mli | 10 ++-- 2 files changed, 75 insertions(+), 13 deletions(-) diff --git a/helm/DEVEL/ocaml-http/http_parser.ml b/helm/DEVEL/ocaml-http/http_parser.ml index 8a16398e8..3bf186fcb 100644 --- a/helm/DEVEL/ocaml-http/http_parser.ml +++ b/helm/DEVEL/ocaml-http/http_parser.ml @@ -22,12 +22,8 @@ open Neturl;; open Printf;; -exception Malformed_query of string -exception Malformed_query_part of string * string -exception Unsupported_method of string -exception Unsupported_HTTP_version of string -exception Malformed_request_URI of string -exception Malformed_request of string +open Http_types;; +open Http_constants;; (* type url_syntax_option = @@ -53,6 +49,74 @@ let request_uri_syntax = { 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 @@ -120,7 +184,7 @@ let parse_request = let patch_empty_path s = (if s = "" then "/" else s) in let pieces_sep = Pcre.regexp " " in fun ic -> - let request_line = generic_input_line ~sep:Http_common.crlf ~ic in + let request_line = generic_input_line ~sep:crlf ~ic in match Pcre.split ~rex:pieces_sep request_line with | [meth; request_uri_raw; http_version] -> if meth <> "GET" then diff --git a/helm/DEVEL/ocaml-http/http_parser.mli b/helm/DEVEL/ocaml-http/http_parser.mli index 6ccc67526..76f102172 100644 --- a/helm/DEVEL/ocaml-http/http_parser.mli +++ b/helm/DEVEL/ocaml-http/http_parser.mli @@ -19,11 +19,9 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) -exception Malformed_query of string -exception Malformed_query_part of string * string -exception Unsupported_method of string -exception Unsupported_HTTP_version of string -exception Malformed_request_URI of string -exception Malformed_request of string +val is_http_field_name: string -> bool +val is_http_field_value: string -> bool +val heal_header: string * string -> unit val parse_request: in_channel -> string * (string * string) list + -- 2.39.2