From: Stefano Zacchiroli <zack@upsilon.cc>
Date: Wed, 25 Dec 2002 14:59:13 +0000 (+0000)
Subject: - new module which contains 'sanity' functions previously included in
X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=19fa8ea6193a687690f97cb92a4a7ee31b2937da;p=helm.git

- new module which contains 'sanity' functions previously included in
  Http_parser
---

diff --git a/helm/DEVEL/ocaml-http/http_parser_sanity.ml b/helm/DEVEL/ocaml-http/http_parser_sanity.ml
new file mode 100644
index 000000000..19204e870
--- /dev/null
+++ b/helm/DEVEL/ocaml-http/http_parser_sanity.ml
@@ -0,0 +1,89 @@
+
+open Neturl;;
+open Printf;;
+
+open Http_types;;
+open Http_constants;;
+
+(*
+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);
+}
+
+  (* convention:
+      foo_RE_raw  is the uncompiled regexp matching foo
+      foo_RE      is the compiled regexp matching foo
+      is_foo      is the predicate over string matching foo
+  *)
+
+let separators_RE_raw = "()<>@,;:\\\\\"/\\[\\]?={} \t"
+let ctls_RE_raw = "\\x00-\\x1F\\x7F"
+let token_RE_raw = "[^" ^ separators_RE_raw ^ ctls_RE_raw ^ "]+"
+let lws_RE_raw = "(\r\n)?[ \t]"
+let quoted_string_RE_raw = "\"(([^\"])|(\\\\\"))*\""
+let text_RE_raw = "(([^" ^ ctls_RE_raw ^ "])|(" ^ lws_RE_raw ^ "))+"
+let field_content_RE_raw =
+  sprintf
+    "^(((%s)|(%s)|(%s))|(%s))*$"
+    token_RE_raw
+    separators_RE_raw
+    quoted_string_RE_raw
+    text_RE_raw
+(*
+  (* following RFC 2616 specifications *)
+let field_value_RE_raw = "((" ^ field_content_RE_raw ^ ")|(" ^ lws_RE_raw^ "))*"
+*)
+  (* smarter implementation: TEXT production is included in the regexp below *)
+let field_value_RE_raw =
+  sprintf
+    "^((%s)|(%s)|(%s)|(%s))*$"
+    token_RE_raw
+    separators_RE_raw
+    quoted_string_RE_raw
+    lws_RE_raw
+
+let token_RE = Pcre.regexp ("^" ^ token_RE_raw ^ "$")
+let field_value_RE = Pcre.regexp ("^" ^ field_value_RE_raw ^ "$")
+let heading_lws_RE = Pcre.regexp (sprintf "^%s*" lws_RE_raw)
+let trailing_lws_RE = Pcre.regexp (sprintf "%s*$" lws_RE_raw)
+
+let is_token s = Pcre.pmatch ~rex:token_RE s
+let is_field_name = is_token
+let is_field_value s = Pcre.pmatch ~rex:field_value_RE s
+
+let heal_header_name s =
+  if not (is_field_name s) then raise (Invalid_header_name s) else ()
+
+let heal_header_value s =
+  if not (is_field_value s) then raise (Invalid_header_value s) else ()
+
+let normalize_header_value s =
+  Pcre.replace ~rex:trailing_lws_RE
+    (Pcre.replace ~rex:heading_lws_RE s)
+
+let heal_header (name, value) =
+  heal_header_name name;
+  heal_header_value name
+ 
+let url_of_string = url_of_string request_uri_syntax
+let string_of_url = Neturl.string_of_url
+
diff --git a/helm/DEVEL/ocaml-http/http_parser_sanity.mli b/helm/DEVEL/ocaml-http/http_parser_sanity.mli
new file mode 100644
index 000000000..3076a42a6
--- /dev/null
+++ b/helm/DEVEL/ocaml-http/http_parser_sanity.mli
@@ -0,0 +1,31 @@
+
+(*
+  OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+  Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+  This program is free software; you can redistribute it and/or modify
+  it under the terms of the GNU General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or
+  (at your option) any later version.
+
+  This program is distributed in the hope that it will be useful,
+  but WITHOUT ANY WARRANTY; without even the implied warranty of
+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+  GNU General Public License for more details.
+
+  You should have received a copy of the GNU General Public License
+  along with this program; if not, write to the Free Software
+  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+*)
+
+val heal_header_name: string -> unit
+val heal_header_value: string -> unit
+val heal_header: string * string -> unit
+
+  (** remove heading and/or trailing LWS sequences as per RFC2616 *)
+val normalize_header_value: string -> string
+
+val url_of_string: string -> Neturl.url
+val string_of_url: Neturl.url -> string
+