X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fdaemons%2Frdfly%2Frdfly.ml;h=9b2a08d2a742bcd91f42bca94f0251012e6c4512;hb=2b4ed41c3d8a105f1f9921b37e7f11160001bbe7;hp=8dbb6b051c484a48101d68f590a3adeb18c87d75;hpb=9571f24af9d981219cac993604997f80bb2e1b97;p=helm.git diff --git a/helm/software/daemons/rdfly/rdfly.ml b/helm/software/daemons/rdfly/rdfly.ml index 8dbb6b051..9b2a08d2a 100644 --- a/helm/software/daemons/rdfly/rdfly.ml +++ b/helm/software/daemons/rdfly/rdfly.ml @@ -1,19 +1,15 @@ -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 @@ -37,120 +33,101 @@ 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 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 " \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 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 " \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 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 ^ "\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 ^ "\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 ^ "") -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 = try @@ -160,17 +137,17 @@ let callback (req: Http_types.request) ch = | "/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) @@ -178,17 +155,17 @@ let callback (req: Http_types.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 main () = - Sys.catch_break true; + 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 -> () -in - -main () +;; +main ()