(* 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";
| "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 "<html><body>Http Getter error: %s</body></html>" s
+let pp_internal_error s =
+ sprintf "<html><body>Http Getter Internal error: %s</body></html>" s
+let pp_msg s = sprintf "<html><body>%s</body></html>" 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;
(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 "<html><body>\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</body></html>";
+ close_out outchan
+
(* thread action *)
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)<br />\n%s"
- name position (HelmLogger.html_of_html_msg log))
- outchan
+ let prepend =
+ sprintf "Added server %s in position %d)<br />\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<br />\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<br />\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
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 "<br />\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 "<br />\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 *)
projects / helm.git / blobdiff