module M = Mysql
(* First of all we load the configuration *)
let _ =
let configuration_file = "/projects/helm/etc/rdfly.conf.xml" in
Helm_registry.load_from configuration_file
;;
let open_db ?host ?database ?port ?password ?user =
try
M.quick_connect ?host ?database ?port ?password ?user
with
M.Error e as exc ->
prerr_endline e ;
raise exc
let extract_position s =
let sharp_pos = String.rindex s '#' + 1 in
String.sub s sharp_pos ((String.length s) - sharp_pos)
let mk_new_msg () = ref []
let msg_output_string msg s = msg := s::!msg
let msg_serialize msg =
List.fold_left (fun acc s -> s ^ acc) "" !msg
let msg_output_header msg obj =
msg_output_string msg "\n\n" ;
msg_output_string msg ("\n \n")
let msg_output_trailer msg =
msg_output_string msg " \n\n"
let value_of_optional_value =
function
None -> assert false
| Some v -> v
;;
let forward_metadata db obj =
let res = M.exec db ("SELECT * FROM refObj WHERE source = '" ^ obj ^ "';") in
let msg = mk_new_msg () in
msg_output_header msg obj ;
M.iter res
~f:(function cols ->
let position = extract_position (value_of_optional_value (cols.(2))) in
let occurrence = value_of_optional_value (cols.(1)) in
msg_output_string msg " \n \n" ;
msg_output_string msg (" " ^ position ^ "\n") ;
msg_output_string msg (" " ^ occurrence ^ "\n") ;
msg_output_string msg " \n \n"
) ;
msg_output_trailer msg ;
msg_serialize msg
let backward_metadata db obj =
let res = M.exec db ("SELECT * FROM refObj WHERE h_occurrence = '" ^ obj ^ "';") in
let msg = mk_new_msg () in
msg_output_header msg obj ;
M.iter res
~f:(function cols ->
let position = extract_position (value_of_optional_value (cols.(2))) in
let occurrence = value_of_optional_value (cols.(0)) in
msg_output_string msg " \n \n" ;
msg_output_string msg (" " ^ position ^ "\n") ;
msg_output_string msg (" " ^ occurrence ^ "\n") ;
msg_output_string msg " \n \n"
) ;
msg_output_trailer msg ;
msg_serialize msg
let debug_print s = prerr_endline ("[RDFly] " ^ s)
let mk_return_fun contype msg outchan =
Http_daemon.respond
~body:msg ~headers:["Content-Type", contype] outchan
let return_html = mk_return_fun "text/html"
let return_xml = mk_return_fun "text/xml"
let return_400 body ch = Http_daemon.respond_error ~code:400 ~body ch
let return_html_error s = return_html ("" ^ s ^ "")
let get_option key =
try
Some (Helm_registry.get key)
with Helm_registry.Key_not_found _ -> None
let get_int_option key =
try
Some (Helm_registry.get_int key)
with Helm_registry.Key_not_found _ -> None
let host = get_option "rdfly.mysql_connection.host";;
let database = get_option "rdfly.mysql_connection.database";;
let port = get_int_option "rdfly.mysql_connection.port";;
let password = get_option "rdfly.mysql_connection.password";;
let user = get_option "rdfly.mysql_connection.user";;
let daemonport = Helm_registry.get_int "rdfly.port";;
let callback (req: Http_types.request) ch =
try
debug_print ("Connection from " ^ req#clientAddr) ;
debug_print ("Received request: " ^ req#path) ;
(match req#path with
| "/help" ->
return_html_error "yeah right..." ch
| "/get" ->
let obj = req#param "object"
and kind = req#param "kind" in
let db = open_db ?host ?database ?port ?password ?user () in
begin
match kind with
"forward" -> return_xml (forward_metadata db obj) ch
| "backward" -> return_xml (backward_metadata db obj) ch
| s -> return_html_error ("unsupported kind: " ^ s) ch
end ;
M.disconnect db
| invalid_request -> Http_daemon.respond_error ~status:(`Client_error `Bad_request) ch)
with
| Http_types.Param_not_found attr_name ->
return_400 (Printf.sprintf "Parameter '%s' is missing" attr_name) ch
| exc ->
return_html_error ("Uncaught exception: " ^ (Printexc.to_string exc)) ch
let main () =
Sys.catch_break true;
try
Http_daemon.start'
~timeout:(Some 600) ~port:daemonport callback
with Sys.Break -> ()
in
main ()