X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2Fhttp_getter%2Fmain.ml;h=8fa671ab9febd8ae04b44c687cca723f40505aee;hb=bb236c2ac110124de92fa2d0fb2882d273a7f7eb;hp=7722a2cdce135626a1d883a8e0c0d62deaf8e7d2;hpb=024e92b8b3bf29e41ce50004c37d884baa1db847;p=helm.git diff --git a/helm/http_getter/main.ml b/helm/http_getter/main.ml index 7722a2cdc..8fa671ab9 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 = "/projects/helm/etc/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) = @@ -64,11 +63,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)) + | 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 = @@ -110,8 +109,25 @@ let parse_rdf_class (req: Http_types.request) = | "backward" -> `Backward | c -> raise (Bad_request ("Invalid RDF class: " ^ c)) +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 +let pp_internal_error 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" +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:(`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; @@ -132,8 +148,19 @@ let return_all_foo_uris doctype uris outchan = uris; output_string outchan (sprintf "%s>\n" doctype) -let return_all_xml_uris outchan = - return_all_foo_uris "alluris" (Http_getter.getalluris ()) outchan +let return_all_xml_uris fmt outchan = + let uris = Http_getter.getalluris () in + match fmt with + | `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 + | `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 @@ -141,7 +168,7 @@ let return_ls xmluri fmt outchan = let ls_items = Http_getter.ls xmluri 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 @@ -152,7 +179,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); @@ -200,12 +227,34 @@ let return_list_servers outchan = (Http_getter.list_servers ())))) outchan +let log_failure msg = Http_getter_logger.log ("Request not fulfilled: " ^ msg) + + (** given an action (i.e. a function which expects a logger and do something + * using it as a logger), perform it sending its output incrementally to the + * given output channel. Response is sent embedded in an HTML document. + * Channel is closed afterwards. *) +let send_log_to ?prepend action outchan = + Http_daemon.send_basic_headers ~code:(`Code 200) outchan; + Http_daemon.send_header "Content-Type" "text/html" outchan; + Http_daemon.send_CRLF outchan; + output_string outchan "\n"; flush outchan; + (match prepend with + | None -> () + | Some text -> output_string outchan text; flush outchan); + let logger tag = + output_string outchan (HelmLogger.html_of_html_tag tag); + flush outchan + in + action logger; + output_string outchan "\n"; + close_out outchan + (* thread action *) let callback (req: Http_types.request) outchan = try - debug_print ("Connection from " ^ req#clientAddr); - debug_print ("Received request: " ^ req#path); + Http_getter_logger.log ("Connection from " ^ req#clientAddr); + Http_getter_logger.log ("Received request: " ^ req#path); (match req#path with | "/help" -> return_help outchan | "/getxml" -> @@ -230,70 +279,87 @@ let callback (req: Http_types.request) outchan = return_html_msg "Done." outchan | "/update" -> Http_getter_env.reload (); (* reload servers list from servers file *) - let log = Http_getter.update () in - return_html_msg (HelmLogger.html_of_html_msg log) outchan + send_log_to (fun logger -> Http_getter.update ~logger ()) outchan | "/list_servers" -> return_list_servers outchan | "/add_server" -> let name = req#param "url" in let position = parse_position req in - let log = Http_getter.add_server ~position name in - return_html_msg - (sprintf "Added server %s in position %d)