-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
+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
msg_output_string msg "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n\n" ;
msg_output_string msg ("<rdf:RDF xml:lang=\"en\"\n xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\n xmlns:rdfs=\"http://www.w3.org/2000/01/rdf-schema#\"\n xmlns:dc=\"http://purl.org/metadata/dublin_core#\"\n xmlns:dcq=\"http://purl.org/metadata/dublin_core_qualifiers#\"\n xmlns:h=\"http:/www.cs.unibo.it/helm/schemas/schema-h.rdf#\"\n xmlns:hth=\"http://www.cs.unibo.it/helm/schemas/schema-hth.rdf#\">\n") ;
msg_output_string msg " <h:DirectoryOfObjects>"
-;;
let msg_output_dc_trailer msg =
msg_output_string msg " </h:DirectoryOfObjects>\n</rdf:RDF>"
-;;
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 forward_metadata dbd obj =
let msg = mk_new_msg () in
- msg_output_header msg obj ;
- M.iter res
- ~f:(function cols ->
+ 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 " <h:refObj>\n <h:Occurrence>\n" ;
msg_output_string msg (" <h:position>" ^ position ^ "</h:position>\n") ;
msg_output_string msg (" <h:occurrence>" ^ occurrence ^ "</h:occurrence>\n") ;
msg_output_string msg " </h:Occurrence>\n </h:refObj>\n"
- ) ;
+ in
+ msg_output_header msg obj ;
+ exec_and_iter dbd query map ;
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 backward_metadata dbd obj =
let msg = mk_new_msg () in
- msg_output_header msg obj ;
- M.iter res
- ~f:(function cols ->
+ 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 " <h:backPointer>\n <h:Occurrence>\n" ;
msg_output_string msg (" <h:position>" ^ position ^ "</h:position>\n") ;
msg_output_string msg (" <h:occurrence>" ^ occurrence ^ "</h:occurrence>\n") ;
msg_output_string msg " </h:Occurrence>\n </h:backPointer>\n"
- ) ;
+ in
+ msg_output_header msg obj ;
+ exec_and_iter dbd query map ;
msg_output_trailer msg ;
msg_serialize msg
-;;
-let dc_metadata db 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
- msg_output_dc_header msg obj ;
- List.iter
- (fun (propertyname,tablename) ->
- let res =
- M.exec db
- ("SELECT * FROM " ^ tablename ^ " WHERE uri = '" ^ obj ^ "';") in
- M.iter res
- ~f:(function cols ->
- let value = value_of_optional_value (cols.(0)) in
- msg_output_string msg
- (" <" ^ propertyname ^ ">" ^ value ^ "</" ^ propertyname ^ ">\n") ;
- ) ;
- ) tables ;
+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 ^ "</" ^ propertyname ^ ">\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 ("<html><body>" ^ s ^ "</body></html>")
-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";;
+(* 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) =
+let callback (req: Http_types.request) ch =
try
debug_print ("Connection from " ^ req#clientAddr) ;
debug_print ("Received request: " ^ req#uri) ;
| "/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
+ 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 db obj) ch
- | "backward" -> return_xml (backward_metadata db obj) ch
- | "dc" -> return_xml (dc_metadata db obj) ch
+ "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 ;
- M.disconnect db
+ SQL.disconnect dbd
| invalid_request ->
Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
ch)
| 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 callback req ch =
- HExtlib.finally
- (fun () -> try close_out ch with Sys_error _ -> ())
- callback (req, ch)
-
let main () =
- Sys.catch_break true;
+ Sys.catch_break true;
try
- Http_daemon.start'
- ~timeout:(Some 600) ~port:daemonport callback
+ 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 -> ()
-in
-
-main ()
+;;
+main ()
projects / helm.git / blobdiff