X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2Fhttp_getter%2Fmain.ml;h=5f7e8cd93582e94a90dd9bf27619266031451ab8;hb=acf29bdbdcdc6ad8c2d9d27e8a47500981b605cd;hp=b2a75488a3c8586a73d9ebbd040b7c8e950ec34a;hpb=829bcae5f3b90741d2e747520842a54e55e8c779;p=helm.git diff --git a/helm/http_getter/main.ml b/helm/http_getter/main.ml index b2a75488a..5f7e8cd93 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,41 +334,46 @@ 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 + 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 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