X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Frdfly%2Frdfly.ml;h=b9a79d1397da4941f444b678bc6d62d04322e995;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=0a268ce7cc40d2f06b8058fe383619cdf8056465;hpb=5a9b1f46a8e866382a71d686e689e9e5907f1824;p=helm.git

diff --git a/helm/DEVEL/rdfly/rdfly.ml b/helm/DEVEL/rdfly/rdfly.ml
index 0a268ce7c..b9a79d139 100644
--- a/helm/DEVEL/rdfly/rdfly.ml
+++ b/helm/DEVEL/rdfly/rdfly.ml
@@ -7,9 +7,9 @@ let _ =
   Helm_registry.load_from configuration_file
 ;;
 
-let open_db ~host ~database ~port ~password ~user =
+let open_db ?host ?database ?port ?password ?user =
   try
-    M.quick_connect ~host ~database ~port ~password ~user
+    M.quick_connect ?host ?database ?port ?password ?user
   with
     M.Error e as exc ->
       prerr_endline e ;
@@ -24,7 +24,7 @@ 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
+  String.concat "" (List.rev !msg)
 
 let msg_output_header msg obj =
   msg_output_string msg "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n\n" ;
@@ -33,6 +33,16 @@ let msg_output_header msg obj =
 let msg_output_trailer msg =
   msg_output_string msg "  </h:Object>\n</rdf:RDF>\n"
 
+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
@@ -54,6 +64,7 @@ let forward_metadata db obj =
    ) ;
   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
@@ -70,6 +81,47 @@ let backward_metadata db obj =
    ) ;
   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 ;
+   msg_output_dc_trailer msg ;
+   msg_serialize msg
+;;
 
 let debug_print s = prerr_endline ("[RDFly] " ^ s)
 
@@ -79,35 +131,49 @@ let mk_return_fun contype msg 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_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 host = Helm_registry.get "rdfly.mysql_connection.host";;
-let database = Helm_registry.get "rdfly.mysql_connection.database";;
-let port = Helm_registry.get_int "rdfly.mysql_connection.port";;
-let password = Helm_registry.get "rdfly.mysql_connection.password";;
-let user = Helm_registry.get "rdfly.mysql_connection.user";;
+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) ;
+    debug_print ("Received request: " ^ req#uri) ;
     (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
+      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
+        | "dc" -> return_xml (dc_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)
+    | 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