X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2Fhttp_getter%2Fmain.ml;h=47784d137ba4ba51d84b43bf747b14fd124177b8;hb=e8680015a9f4da6e50d9e1baa5affb9075445894;hp=301d74eef4b7d1125a2abf2777d611b9612d4ffa;hpb=3af56c5a48f7cad33fd701e0061fe143e0e2a7c5;p=helm.git diff --git a/helm/http_getter/main.ml b/helm/http_getter/main.ml index 301d74eef..47784d137 100644 --- a/helm/http_getter/main.ml +++ b/helm/http_getter/main.ml @@ -31,11 +31,10 @@ open Printf open Http_getter_common open Http_getter_misc open Http_getter_types -open Http_getter_debugger (* constants *) -let configuration_file = "http_getter.conf.xml" +let configuration_file = BuildTimeOpts.conffile let common_headers = [ "Cache-Control", "no-cache"; @@ -45,14 +44,14 @@ let common_headers = [ (* HTTP queries argument parsing *) - (* parse encoding ("format" parameter), default is Enc_normal *) + (* parse encoding ("format" parameter), default is `Normal *) let parse_enc (req: Http_types.request) = try (match req#param "format" with - | "normal" -> Enc_normal - | "gz" -> Enc_gzipped + | "normal" -> `Normal + | "gz" -> `Gzipped | s -> raise (Bad_request ("Invalid format: " ^ s))) - with Http_types.Param_not_found _ -> Enc_normal + with Http_types.Param_not_found _ -> `Normal (* parse "patch_dtd" parameter, default is true *) let parse_patch (req: Http_types.request) = @@ -66,30 +65,10 @@ let parse_patch (req: Http_types.request) = (* parse output format ("format" parameter), no default value *) let parse_output_format meth (req: Http_types.request) = match req#param "format" with - | s when String.lowercase s = "txt" -> Fmt_text - | s when String.lowercase s = "xml" -> Fmt_xml + | s when String.lowercase s = "txt" -> `Text + | s when String.lowercase s = "xml" -> `Xml | s -> raise (Bad_request ("Invalid /" ^ meth ^ " format: " ^ s)) - (* parse "baseuri" format for /ls method, no default value *) -let parse_ls_uri = - let parse_ls_RE = Pcre.regexp "^(\\w+):(.*)$" in - let trailing_slash_RE = Pcre.regexp "/+$" in - let wrong_uri uri = - raise (Bad_request ("Invalid /ls baseuri: " ^ uri)) - in - fun (req: Http_types.request) -> - let baseuri = req#param "baseuri" in - try - let subs = - Pcre.extract ~rex:parse_ls_RE - (Pcre.replace ~rex:trailing_slash_RE baseuri) - in - (match (subs.(1), subs.(2)) with - | "cic", uri -> Cic uri - | "theory", uri -> Theory uri - | _ -> wrong_uri baseuri) - with Not_found -> wrong_uri baseuri - (* parse "position" argument, default is 0 *) let parse_position (req: Http_types.request) = try @@ -114,9 +93,9 @@ let mk_return_fun pp_fun contype msg outchan = Http_daemon.respond ~body:(pp_fun msg) ~headers:["Content-Type", contype] outchan let pp_error s = - sprintf "
Http Getter error: %s" s + sprintf "Http Getter error: %s" s let pp_internal_error s = - sprintf "Http Getter Internal error: %s" s + sprintf "Http Getter Internal error: %s" s let pp_msg s = sprintf "%s" s let null_pp s = s let return_html_error = mk_return_fun pp_error "text/html" @@ -124,10 +103,11 @@ let return_html_internal_error = mk_return_fun pp_internal_error "text/html" let return_html_msg = mk_return_fun pp_msg "text/html" let return_html_raw = mk_return_fun null_pp "text/html" let return_xml_raw = mk_return_fun null_pp "text/xml" -let return_400 body outchan = Http_daemon.respond_error ~code:400 ~body outchan +let return_400 body outchan = + Http_daemon.respond_error ~code:(`Code 400) ~body outchan let return_all_foo_uris doctype uris outchan = - Http_daemon.send_basic_headers ~code:200 outchan; + Http_daemon.send_basic_headers ~code:(`Code 200) outchan; Http_daemon.send_header "Content-Type" "text/xml" outchan; Http_daemon.send_headers common_headers outchan; Http_daemon.send_CRLF outchan; @@ -151,24 +131,24 @@ let return_all_foo_uris doctype uris outchan = let return_all_xml_uris fmt outchan = let uris = Http_getter.getalluris () in match fmt with - | Fmt_text -> + | `Text -> let buf = Buffer.create 10240 in List.iter (bprintf buf "%s\n") uris ; let body = Buffer.contents buf in Http_daemon.respond ~headers:(("Content-Type", "text/plain") :: common_headers) ~body outchan - | Fmt_xml -> + | `Xml -> return_all_foo_uris "alluris" uris outchan let return_all_rdf_uris classs outchan = return_all_foo_uris "allrdfuris" (Http_getter.getallrdfuris classs) outchan -let return_ls xmluri fmt outchan = - let ls_items = Http_getter.ls xmluri in +let return_ls regexp fmt outchan = + let ls_items = Http_getter.ls regexp in let buf = Buffer.create 10240 in (match fmt with - | Fmt_text -> + | `Text -> List.iter (function | Ls_section dir -> bprintf buf "dir, %s\n" dir @@ -179,7 +159,7 @@ let return_ls xmluri fmt outchan = (string_of_ls_flag obj.body) (string_of_ls_flag obj.proof_tree)) ls_items - | Fmt_xml -> + | `Xml -> Buffer.add_string buf "\n"; bprintf buf "\n" (Lazy.force Http_getter_env.my_own_url); @@ -214,8 +194,9 @@ let return_resolve uri outchan = return_xml_raw (sprintf "