module Registry = Helm_registry
module SQL = HSql
module DB = LibraryDb
let exec_and_iter dbd query f =
let db_types = [SQL.Library; SQL.Legacy] in
let map db_type =
let res = SQL.exec db_type dbd query in
SQL.iter res ~f
in
List.iter map db_types
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 =
String.concat "" (List.rev !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 msg_output_dc_header msg obj =
msg_output_string msg "\n\n" ;
msg_output_string msg ("\n") ;
msg_output_string msg " "
let msg_output_dc_trailer msg =
msg_output_string msg " \n"
let value_of_optional_value =
function
None -> assert false
| Some v -> v
let forward_metadata dbd obj =
let msg = mk_new_msg () in
let query = "SELECT * FROM refObj WHERE source = '" ^ obj ^ "';" in
let map 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"
in
msg_output_header msg obj ;
exec_and_iter dbd query map ;
msg_output_trailer msg ;
msg_serialize msg
let backward_metadata dbd obj =
let msg = mk_new_msg () in
let query = "SELECT * FROM refObj WHERE h_occurrence = '" ^ obj ^ "';" in
let map 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"
in
msg_output_header msg obj ;
exec_and_iter dbd query map ;
msg_output_trailer msg ;
msg_serialize msg
let dc_metadata dbd obj =
let tables =
[ "dc:creator","dccreator" ;
"dc:date","dcdate" ;
"dc:description","dcdescription" ;
"dc:format","dcformat" ;
"dc:identifier","dcidentifier" ;
"dc:language","dclanguage" ;
"dc:publisher","dcpublisher" ;
"dcq:RelationType","dcqRelationType" ;
"dc:relation","dcrelation" ;
"dc:rights","dcrights" ;
"dc:source","dcsource" ;
"dc:subject","dcsubject" ;
"dc:title","dctitle" ;
"hth:ResourceFormat","hthResourceFormat" ;
"hth:contact","hthcontact" ;
"hth:firstVersion","hthfirstVersion" ;
"hth:institution","hthinstitution" ;
"hth:modified","hthmodified"
]
in
let msg = mk_new_msg () in
let table_map (propertyname, tablename) =
let query = "SELECT * FROM " ^ tablename ^ " WHERE uri = '" ^ obj ^ "';" in
let map cols =
let value = value_of_optional_value (cols.(0)) in
msg_output_string msg
(" <" ^ propertyname ^ ">" ^ value ^ "\n")
in
exec_and_iter dbd query map
in
msg_output_dc_header msg obj ;
List.iter table_map tables ;
msg_output_dc_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:(`Code 400) ~body ch
let return_html_error s = return_html ("" ^ s ^ "")
(* First of all we load the configuration *)
let configuration_file = "/projects/helm/etc/rdfly.conf.xml"
let _ = Registry.load_from configuration_file
let db_spec = DB.parse_dbd_conf ()
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#uri) ;
(match req#path with
| "/help" ->
return_html_error "yeah right..." ch
| "/get" ->
let obj = req#param "object" in
let kind = req#param "kind" in
let dbd = SQL.quick_connect db_spec in
begin
match kind with
"forward" -> return_xml (forward_metadata dbd obj) ch
| "backward" -> return_xml (backward_metadata dbd obj) ch
| "dc" -> return_xml (dc_metadata dbd obj) ch
| s -> return_html_error ("unsupported kind: " ^ s) ch
end ;
SQL.disconnect dbd
| invalid_request ->
Http_daemon.respond_error ~code:(`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 ->
prerr_endline (Printexc.to_string exc);
return_html_error ("Uncaught exception: " ^ (Printexc.to_string exc)) ch
let main () =
Sys.catch_break true;
try
let d_spec =
Http_daemon.daemon_spec ~timeout:(Some 600) ~port:daemonport ~callback ~auto_close:true ()
in
Http_daemon.main d_spec
with Sys.Break -> ()
;;
main ()