- implemented heal_header that sanity checks an header

- moved exceptions in http_types

diff --git a/helm/DEVEL/ocaml-http/http_parser.ml b/helm/DEVEL/ocaml-http/http_parser.ml
index 8a16398e88c97c39807b9a6862f258afee99619c..3bf186fcbc2fae8c1da4fdb76a4a38adeab8fd49 100644 (file)
--- 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 6ccc675266bd4caa74befb2928cb4c0261004ec1..76f1021724c2405df9c3194259788713b2763ff0 100644 (file)
--- 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
+