X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fhttp_getter%2Fmain.ml;h=44c69610e1d4e0ffffcef79d3c332988e127ed8f;hb=3bb4ce11fb9d4c6375483a80344beb94c4517dd7;hp=699c685bb6c56cc840306cc2d84bbe96a02950b6;hpb=750e15351055085126b3719e140f96f5f9d41d95;p=helm.git diff --git a/helm/http_getter/main.ml b/helm/http_getter/main.ml index 699c685bb..44c69610e 100644 --- a/helm/http_getter/main.ml +++ b/helm/http_getter/main.ml @@ -31,12 +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 = "http_getter.conf.xml" +let configuration_file = BuildTimeOpts.conffile let common_headers = [ "Cache-Control", "no-cache"; @@ -71,26 +69,6 @@ let parse_output_format meth (req: Http_types.request) = | 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 @@ -125,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; @@ -165,8 +144,8 @@ let return_all_xml_uris fmt 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 | `Text -> @@ -228,14 +207,14 @@ let return_list_servers outchan = (Http_getter.list_servers ())))) outchan -let log_failure msg = debug_print ("Request not fulfilled: " ^ msg) +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:200 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; @@ -254,8 +233,8 @@ let send_log_to ?prepend action outchan = 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" -> @@ -304,12 +283,13 @@ let callback (req: Http_types.request) outchan = return_all_xml_uris (parse_output_format "getalluris" req) outchan | "/getallrdfuris" -> return_all_rdf_uris (parse_rdf_class req) outchan | "/ls" -> - return_ls (parse_ls_uri req) (parse_output_format "ls" req) outchan + return_ls (req#param "baseuri") (parse_output_format "ls" req) outchan | "/getempty" -> Http_daemon.respond ~body:Http_getter_const.empty_xml outchan | invalid_request -> - Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan); - debug_print "Done!\n" + Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) + outchan); + Http_getter_logger.log "Done!\n" with | Http_types.Param_not_found attr_name -> let msg = sprintf "Parameter '%s' is missing" attr_name in @@ -339,6 +319,10 @@ let callback (req: Http_types.request) outchan = let main () = Helm_registry.load_from configuration_file; + Http_getter_logger.set_log_level + (Helm_registry.get_opt_default Helm_registry.get_int 1 "getter.log_level"); + Http_getter_logger.set_log_file + (Helm_registry.get_opt Helm_registry.get_string "getter.log_file"); Http_getter_env.reload (); print_string (Http_getter_env.env_to_string ()); flush stdout;