| "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 = "<?xml version=\"1.0\"?>\n" in
match exn with
- | Some (exn, value) ->
+ | Some (exn, arg) ->
+ let (exn, arg) = (xml_escape exn, xml_escape arg) in
sprintf
"%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\"\nhelm:exception=\"%s\"\nhelm:exception_arg=\"%s\">\n"
- xml_decl xhtml_ns helm_ns exn value
+ xml_decl xhtml_ns helm_ns exn arg
| None ->
sprintf "%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\">\n"
xml_decl xhtml_ns helm_ns
let callback (req: Http_types.request) outchan =
try
Http_getter_logger.log ("Connection from " ^ req#clientAddr);
- Http_getter_logger.log ("Received request: " ^ req#path);
+ Http_getter_logger.log ("Received request: " ^ req#uri);
(match req#path with
| "/help" -> return_help outchan
| "/getxml" ->
| "/getdtd" ->
Http_getter_cache.respond_dtd ~patch:(parse_patch req)
~url:(sprintf "%s/%s"
- (Helm_registry.get "getter.dtd_dir") (req#param "uri"))
+ (Lazy.force Http_getter_env.dtd_dir) (req#param "uri"))
outchan
| "/resolve" -> return_resolve (req#param "uri") outchan
| "/register" ->
log_failure msg;
return_html_error ("uncaught_exception", msg) msg outchan)
- (* Main *)
+let batch_update = ref false
+let args = [
+ ("-update",
+ Arg.Unit (fun () -> batch_update := true),
+ "\tupdate maps and exit");
+]
+
+ (* Main *)
let main () =
+ Arg.parse args (fun _->()) "http_getter honors the following options:\n";
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 ();
+ Http_getter.init ();
print_string (Http_getter_env.env_to_string ());
flush stdout;
- let batch_update =
- try Sys.argv.(1) = "-update" with Invalid_argument _ -> false
- in
- if batch_update then (* batch mode: performs update and exit *)
+ 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;
+ let d_spec = Http_daemon.daemon_spec
+ ~mode:`Thread ~timeout:(Some 600)
+ ~port:(Lazy.force Http_getter_env.port)
+ ~callback:callback ()
+ in
try
- Http_daemon.start' ~mode:`Thread
- ~timeout:(Some 600) ~port:(Helm_registry.get_int "getter.port")
- callback
+ Http_daemon.main d_spec
with Sys.Break -> () (* 'close_maps' already registered with 'at_exit' *)
end