X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fhttp_getter%2Fmain.ml;fp=helm%2Fhttp_getter%2Fmain.ml;h=301d74eef4b7d1125a2abf2777d611b9612d4ffa;hb=3af56c5a48f7cad33fd701e0061fe143e0e2a7c5;hp=eafbc06e6e571c44c75650668dc7d58c9c0fcd04;hpb=17812d2224e765d4ff43bc5f35a7bb09b5ccb0d3;p=helm.git diff --git a/helm/http_getter/main.ml b/helm/http_getter/main.ml index eafbc06e6..301d74eef 100644 --- a/helm/http_getter/main.ml +++ b/helm/http_getter/main.ml @@ -35,7 +35,7 @@ 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 = [ "Cache-Control", "no-cache"; @@ -110,6 +110,22 @@ let parse_rdf_class (req: Http_types.request) = | "backward" -> `Backward | c -> raise (Bad_request ("Invalid RDF class: " ^ c)) +let mk_return_fun pp_fun contype msg outchan = + Http_daemon.respond + ~body:(pp_fun msg) ~headers:["Content-Type", contype] outchan +let pp_error s = + sprintf "Http Getter error: %s" s +let pp_internal_error s = + sprintf "Http Getter Internal error: %s" s +let pp_msg s = sprintf "%s" s +let null_pp s = s +let return_html_error = mk_return_fun pp_error "text/html" +let return_html_internal_error = mk_return_fun pp_internal_error "text/html" +let return_html_msg = mk_return_fun pp_msg "text/html" +let return_html_raw = mk_return_fun null_pp "text/html" +let return_xml_raw = mk_return_fun null_pp "text/xml" +let return_400 body outchan = Http_daemon.respond_error ~code:400 ~body outchan + let return_all_foo_uris doctype uris outchan = Http_daemon.send_basic_headers ~code:200 outchan; Http_daemon.send_header "Content-Type" "text/xml" outchan; @@ -211,6 +227,28 @@ let return_list_servers outchan = (Http_getter.list_servers ())))) outchan +let log_failure msg = debug_print ("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 + * given output channel. Response is sent embedded in an HTML document. + * Channel is closed afterwards. *) +let send_log_to ?prepend action outchan = + Http_daemon.send_basic_headers ~code:200 outchan; + Http_daemon.send_header "Content-Type" "text/html" outchan; + Http_daemon.send_CRLF outchan; + output_string outchan "\n"; flush outchan; + (match prepend with + | None -> () + | Some text -> output_string outchan text; flush outchan); + let logger tag = + output_string outchan (HelmLogger.html_of_html_tag tag); + flush outchan + in + action logger; + output_string outchan "\n"; + close_out outchan + (* thread action *) let callback (req: Http_types.request) outchan = @@ -241,29 +279,26 @@ let callback (req: Http_types.request) outchan = return_html_msg "Done." outchan | "/update" -> Http_getter_env.reload (); (* reload servers list from servers file *) - let log = Http_getter.update () in - return_html_msg (HelmLogger.html_of_html_msg log) outchan + send_log_to (fun logger -> Http_getter.update ~logger ()) outchan | "/list_servers" -> return_list_servers outchan | "/add_server" -> let name = req#param "url" in let position = parse_position req in - let log = Http_getter.add_server ~position name in - return_html_msg - (sprintf "Added server %s in position %d)
\n%s" - name position (HelmLogger.html_of_html_msg log)) - outchan + let prepend = + sprintf "Added server %s in position %d)
\n" name position + in + send_log_to ~prepend + (fun logger -> Http_getter.add_server ~logger ~position name) outchan | "/remove_server" -> let position = parse_position req in - let log = - try - Http_getter.remove_server position - with Invalid_argument _ -> - raise (Bad_request (sprintf "no server with position %d" position)) - in - return_html_msg - (sprintf "Removed server at position %d
\n%s" - position (HelmLogger.html_of_html_msg log)) - outchan + if not (Http_getter.has_server position) then + raise (Bad_request (sprintf "no server with position %d" position)) + else + let prepend = + sprintf "Removed server at position %d
\n" position + in + send_log_to ~prepend + (fun logger -> Http_getter.remove_server ~logger position) outchan | "/getalluris" -> return_all_xml_uris (parse_output_format "getalluris" req) outchan | "/getallrdfuris" -> return_all_rdf_uris (parse_rdf_class req) outchan @@ -276,22 +311,28 @@ let callback (req: Http_types.request) outchan = debug_print "Done!\n" with | Http_types.Param_not_found attr_name -> - return_400 (sprintf "Parameter '%s' is missing" attr_name) outchan - | Bad_request msg -> return_html_error msg outchan - | Internal_error msg -> return_html_internal_error msg outchan + let msg = sprintf "Parameter '%s' is missing" attr_name in + log_failure msg; + return_400 msg outchan + | Bad_request msg -> + log_failure msg; + return_html_error msg outchan + | Internal_error msg -> + log_failure msg; + return_html_internal_error msg outchan | Shell.Subprocess_error l -> - return_html_internal_error - (String.concat "
\n" - (List.map - (fun (cmd, code) -> - sprintf "Command '%s' returned %s" - cmd (string_of_proc_status code)) - l)) - outchan + let msgs = + List.map + (fun (cmd, code) -> + sprintf "Command '%s' returned %s" cmd (string_of_proc_status code)) + l + in + log_failure (String.concat ", " msgs); + return_html_internal_error (String.concat "
\n" msgs) outchan | exc -> - return_html_error - ("Uncaught exception: " ^ (Printexc.to_string exc)) - outchan + let msg = "Uncaught exception: " ^ (Printexc.to_string exc) in + log_failure msg; + return_html_error msg outchan (* Main *)