X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2Fhttp_getter%2Fmain.ml;h=640584e63a9729e2d03941162c5633039ac2c7a5;hb=3605d724ae0b95e17e668b6e140c35ab19568bb2;hp=f65e991b7c263fbd7a714e3efbd755684080a3c4;hpb=72e5ddf0f07b0e692f5e3544438f77f2e346b12a;p=helm.git diff --git a/helm/http_getter/main.ml b/helm/http_getter/main.ml index f65e991b7..640584e63 100644 --- a/helm/http_getter/main.ml +++ b/helm/http_getter/main.ml @@ -90,13 +90,16 @@ let parse_rdf_class (req: Http_types.request) = | "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 = "\n" in match exn with - | Some exn -> + | Some (exn, arg) -> + let (exn, arg) = (xml_escape exn, xml_escape arg) in sprintf - "%s\n" - xml_decl xhtml_ns helm_ns exn + "%s\n" + xml_decl xhtml_ns helm_ns exn arg | None -> sprintf "%s\n" xml_decl xhtml_ns helm_ns @@ -268,7 +271,7 @@ let callback (req: Http_types.request) outchan = | "/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" -> @@ -317,13 +320,13 @@ let callback (req: Http_types.request) outchan = | 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 @@ -331,23 +334,24 @@ let callback (req: Http_types.request) outchan = 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 "
\n" msgs) outchan | exc -> - let msg = "Uncaught exception: " ^ (Printexc.to_string exc) in - log_failure msg; - return_html_error "Uncaught_exception" msg outchan + 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", uri) msg outchan + | _ -> + log_failure msg; + 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 = @@ -360,7 +364,7 @@ let main () = 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