X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fhttp_getter%2Fmain.ml;h=5f7e8cd93582e94a90dd9bf27619266031451ab8;hb=acf29bdbdcdc6ad8c2d9d27e8a47500981b605cd;hp=e6b9f6e02abbcc24caee56cbb83c564f5a522055;hpb=d3c72d6856cd185e5b3e9f2e8b928b78c7031ed1;p=helm.git diff --git a/helm/http_getter/main.ml b/helm/http_getter/main.ml index e6b9f6e02..5f7e8cd93 100644 --- a/helm/http_getter/main.ml +++ b/helm/http_getter/main.ml @@ -29,12 +29,14 @@ open Printf open Http_getter_common +open Http_getter_const open Http_getter_misc open Http_getter_types -open Http_getter_debugger (* constants *) +let configuration_file = BuildTimeOpts.conffile + let common_headers = [ "Cache-Control", "no-cache"; "Pragma", "no-cache"; @@ -43,14 +45,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) = @@ -62,31 +64,11 @@ let parse_patch (req: Http_types.request) = with Http_types.Param_not_found _ -> true (* parse output format ("format" parameter), no default value *) -let parse_output_format (req: Http_types.request) = +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 -> raise (Bad_request ("Invalid /ls 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 + | s when String.lowercase s = "txt" -> `Text + | s when String.lowercase s = "xml" -> `Xml + | s -> raise (Bad_request ("Invalid /" ^ meth ^ " format: " ^ s)) (* parse "position" argument, default is 0 *) let parse_position (req: Http_types.request) = @@ -108,8 +90,44 @@ let parse_rdf_class (req: Http_types.request) = | "backward" -> `Backward | c -> raise (Bad_request ("Invalid RDF class: " ^ c)) +let xml_escape = Netencoding.Html.encode ~in_enc:`Enc_utf8 () + +let html_tag ?exn () = + let xml_decl = "\n" in + match exn with + | Some (exn, arg) -> + let (exn, arg) = (xml_escape exn, xml_escape arg) in + sprintf + "%s\n" + xml_decl xhtml_ns helm_ns exn arg + | None -> + sprintf "%s\n" + xml_decl xhtml_ns helm_ns + +let mk_return_fun pp_fun contype msg outchan = + Http_daemon.respond + ~body:(pp_fun msg) ~headers:["Content-Type", contype] outchan +let pp_msg s = sprintf "%s
%s" (html_tag ()) s +let null_pp s = s +let return_html_error exn = + let pp_error s = + sprintf "%s\nHttp Getter error: %s" + (html_tag ~exn ()) s + in + mk_return_fun pp_error "text/xml" +let return_html_internal_error exn = + let pp_internal_error s = + sprintf "%s\nHttp Getter Internal error: %s