| "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 ->
+ | Some (exn, arg) ->
+ let (exn, arg) = (xml_escape exn, xml_escape arg) in
sprintf
- "%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\"\nhelm:exception=\"%s\">\n"
- xml_decl xhtml_ns helm_ns exn
+ "%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\"\nhelm:exception=\"%s\"\nhelm:exception_arg=\"%s\">\n"
+ xml_decl xhtml_ns helm_ns exn arg
| None ->
sprintf "%s<html xmlns=\"%s\"\nxmlns:helm=\"%s\">\n"
xml_decl xhtml_ns helm_ns
| "/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" ->
| Http_types.Param_not_found attr_name ->
let msg = sprintf "Parameter '%s' is missing" attr_name in
log_failure msg;
- return_400 "Bad_request" msg outchan
+ return_400 ("bad_request", msg) msg outchan
| Bad_request msg ->
log_failure msg;
- return_html_error "Bad_request" msg outchan
+ return_html_error ("bad_request", msg) msg outchan
| Internal_error msg ->
log_failure msg;
- return_html_internal_error "Internal_error" msg outchan
+ return_html_internal_error ("internal_error", msg) msg outchan
| Shell.Subprocess_error l ->
let msgs =
List.map
sprintf "Command '%s' returned %s" cmd (string_of_proc_status code))
l
in
- log_failure (String.concat ", " msgs);
- return_html_internal_error "Subprocess_error"
+ let msg = String.concat ", " msgs in
+ log_failure msg;
+ return_html_internal_error ("subprocess_error", msg)
(String.concat "<br />\n" msgs) outchan
| exc ->
- let msg = "Uncaught exception: " ^ (Printexc.to_string exc) in
+ let msg = "uncaught exception: " ^ (Printexc.to_string exc) in
(match exc with
| Http_getter_types.Key_not_found uri ->
- return_html_error "Key_not_found" msg outchan
+ return_html_error ("key_not_found", uri) msg outchan
| _ ->
log_failure msg;
- return_html_error "Uncaught_exception" msg outchan)
+ return_html_error ("uncaught_exception", msg) msg outchan)
(* Main *)
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 ();
+ Http_getter.init ();
print_string (Http_getter_env.env_to_string ());
flush stdout;
let batch_update =
Sys.catch_break true;
try
Http_daemon.start' ~mode:`Thread
- ~timeout:(Some 600) ~port:(Helm_registry.get_int "getter.port")
+ ~timeout:(Some 600) ~port:(Lazy.force Http_getter_env.port)
callback
with Sys.Break -> () (* 'close_maps' already registered with 'at_exit' *)
end