From: Ferruccio Guidi <ferruccio.guidi@unibo.it>
Date: Wed, 12 Sep 2007 16:23:20 +0000 (+0000)
Subject: rdfly patched to work with the new db structure
X-Git-Tag: make_still_working~6021
X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=fd0b68d4a811f2938bb045a81ad52c3d1f117e99;p=helm.git

rdfly patched to work with the new db structure
---

diff --git a/helm/software/daemons/rdfly/Makefile b/helm/software/daemons/rdfly/Makefile
index 26e296409..a762f5273 100644
--- a/helm/software/daemons/rdfly/Makefile
+++ b/helm/software/daemons/rdfly/Makefile
@@ -1,5 +1,5 @@
 BIN_DIR = /usr/local/bin
-REQUIRES = mysql http helm-registry
+REQUIRES = http helm-registry helm-hmysql helm-library
 PREDICATES = 
 OCAMLOPTIONS = -package "$(REQUIRES)" -predicates "$(PREDICATES)" -pp camlp4o
 ifeq ($(origin OCAMLPATH), undefined)
diff --git a/helm/software/daemons/rdfly/rdfly.conf.xml.sample b/helm/software/daemons/rdfly/rdfly.conf.xml.sample
index 5d479dacf..d84e22426 100644
--- a/helm/software/daemons/rdfly/rdfly.conf.xml.sample
+++ b/helm/software/daemons/rdfly/rdfly.conf.xml.sample
@@ -1,12 +1,11 @@
 <?xml version="1.0" encoding="utf-8"?>
 <helm_registry>
+  <section name="db">
+    <key name="metadata">mysql://mowgli.cs.unibo.it public helm none library</key>
+    <key name="metadata">mysql://mowgli.cs.unibo.it mowgli helm none legacy</key>
+    <key name="metadata">file:///tmp/ dust.db helm none user</key>
+  </section>
   <section name="rdfly">
-    <section name="mysql_connection">
-      <key name="host">localhost</key>
-      <key name="user">helm</key>
-      <key name="database">mowgli</key>
-      <key name="port">3306</key>
-    </section>
     <key name="port">58086</key>
   </section>
 </helm_registry>
diff --git a/helm/software/daemons/rdfly/rdfly.ml b/helm/software/daemons/rdfly/rdfly.ml
index 8dbb6b051..eadb2c773 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 "<?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 =
   try
@@ -162,15 +139,15 @@ let callback (req: Http_types.request) ch =
     | "/get" ->
       let obj = req#param "object"
       and kind = req#param "kind" in
-      let db = open_db ?host ?database ?port ?password ?user () 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)
@@ -181,7 +158,7 @@ let callback (req: Http_types.request) ch =
       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 ()
@@ -189,6 +166,5 @@ let main () =
     Http_daemon.main d_spec
   with Sys.Break -> ()
 in
-                                                                                                                                                                                    
-main ()
 
+main ()