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 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) =
(* 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 *)
Http_daemon.respond
~body:(pp_fun msg) ~headers:["Content-Type", contype] outchan
let pp_error s =
- sprintf "<html><body>Http Getter error: %s</body></html>" s
+ sprintf "<html><body>Http Getter error: <span style=\"color:red\">%s</span></body></html>" s
let pp_internal_error s =
- sprintf "<html><body>Http Getter Internal error: %s</body></html>" s
+ sprintf "<html><body>Http Getter Internal error: <span style=\"color:red\">%s</span></body></html>" s
let pp_msg s = sprintf "<html><body>%s</body></html>" s
let null_pp s = s
let return_html_error = mk_return_fun pp_error "text/html"
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 =
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
(string_of_ls_flag obj.body)
(string_of_ls_flag obj.proof_tree))
ls_items
- | Fmt_xml ->
+ | `Xml ->
Buffer.add_string buf "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n";
bprintf buf "<!DOCTYPE ls SYSTEM \"%s/getdtd?uri=ls.dtd\">\n"
(Lazy.force Http_getter_env.my_own_url);
(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
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" ->
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_getter_logger.log "Done!\n"
with
| Http_types.Param_not_found attr_name ->
let msg = sprintf "Parameter '%s' is missing" attr_name in
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;
- at_exit Http_getter.close_maps;
- Sys.catch_break true;
- try
- Http_daemon.start' ~mode:`Thread
- ~timeout:(Some 600) ~port:(Helm_registry.get_int "getter.port")
- callback
- with Sys.Break -> () (* 'close_maps' already registered with 'at_exit' *)
+ let batch_update =
+ try Sys.argv.(1) = "-update" with Invalid_argument _ -> false
+ in
+ if batch_update then (* batch mode: performs update and exit *)
+ Http_getter.update ~logger:Http_getter.stdout_logger ()
+ else begin (* daemon mode: start http daemon *)
+ at_exit Http_getter.close_maps;
+ Sys.catch_break true;
+ try
+ Http_daemon.start' ~mode:`Thread
+ ~timeout:(Some 600) ~port:(Helm_registry.get_int "getter.port")
+ callback
+ with Sys.Break -> () (* 'close_maps' already registered with 'at_exit' *)
+ end
let _ = main ()
projects / helm.git / blobdiff