]> matita.cs.unibo.it Git - helm.git/blob - daemons/rdfly/rdfly.ml
This commit implements the Abort button for the GUI using a clever trick by Xavier...
[helm.git] / daemons / rdfly / rdfly.ml
1
2 module M = Mysql
3
4   (* First of all we load the configuration *)
5 let _ =
6  let configuration_file = "/projects/helm/etc/rdfly.conf.xml" in
7   Helm_registry.load_from configuration_file
8 ;;
9
10 let open_db ?host ?database ?port ?password ?user =
11   try
12     M.quick_connect ?host ?database ?port ?password ?user
13   with
14     M.Error e as exc ->
15       prerr_endline e ;
16       raise exc
17
18 let extract_position s =
19   let sharp_pos = String.rindex s '#' + 1 in
20   String.sub s sharp_pos ((String.length s) - sharp_pos)
21
22 let mk_new_msg () = ref []
23
24 let msg_output_string msg s = msg := s::!msg
25
26 let msg_serialize msg =
27   String.concat "" (List.rev !msg)
28
29 let msg_output_header msg obj =
30   msg_output_string msg "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n\n" ;
31   msg_output_string msg ("<rdf:RDF xml:lang=\"en\" xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\" xmlns:h=\"http://www.cs.unibo.it/helm/schemas/mattone.rdf#\">\n  <h:Object rdf:about=\"" ^ obj ^ "\">\n")
32
33 let msg_output_trailer msg =
34   msg_output_string msg "  </h:Object>\n</rdf:RDF>\n"
35
36 let msg_output_dc_header msg obj =
37   msg_output_string msg "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n\n" ;
38   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") ;
39   msg_output_string msg "  <h:DirectoryOfObjects>"
40 ;;
41
42 let msg_output_dc_trailer msg =
43   msg_output_string msg "  </h:DirectoryOfObjects>\n</rdf:RDF>"
44 ;;
45
46 let value_of_optional_value =
47  function
48     None -> assert false
49   | Some v -> v
50 ;;
51
52 let forward_metadata db obj =
53   let res = M.exec db ("SELECT * FROM refObj WHERE source = '" ^ obj ^ "';") in
54   let msg = mk_new_msg () in
55   msg_output_header msg obj ;
56   M.iter res
57    ~f:(function cols ->
58      let position = extract_position (value_of_optional_value (cols.(2))) in
59      let occurrence = value_of_optional_value (cols.(1)) in
60      msg_output_string msg "    <h:refObj>\n      <h:Occurrence>\n" ;
61      msg_output_string msg ("        <h:position>" ^ position ^ "</h:position>\n") ;
62      msg_output_string msg ("        <h:occurrence>" ^ occurrence ^ "</h:occurrence>\n") ;
63      msg_output_string msg "      </h:Occurrence>\n    </h:refObj>\n"
64    ) ;
65   msg_output_trailer msg ;
66   msg_serialize msg
67 ;;
68
69 let backward_metadata db obj =
70   let res = M.exec db ("SELECT * FROM refObj WHERE h_occurrence = '" ^ obj ^ "';") in
71   let msg = mk_new_msg () in
72   msg_output_header msg obj ;
73   M.iter res
74    ~f:(function cols ->
75      let position = extract_position (value_of_optional_value (cols.(2))) in
76      let occurrence = value_of_optional_value (cols.(0)) in
77      msg_output_string msg "    <h:backPointer>\n      <h:Occurrence>\n" ;
78      msg_output_string msg ("        <h:position>" ^ position ^ "</h:position>\n") ;
79      msg_output_string msg ("        <h:occurrence>" ^ occurrence ^ "</h:occurrence>\n") ;
80      msg_output_string msg "      </h:Occurrence>\n    </h:backPointer>\n"
81    ) ;
82   msg_output_trailer msg ;
83   msg_serialize msg
84 ;;
85
86 let dc_metadata db obj =
87  let tables =
88   [ "dc:creator","dccreator" ;
89     "dc:date","dcdate" ;
90     "dc:description","dcdescription" ;
91     "dc:format","dcformat" ;
92     "dc:identifier","dcidentifier" ;
93     "dc:language","dclanguage" ;
94     "dc:publisher","dcpublisher" ;
95     "dcq:RelationType","dcqRelationType" ;
96     "dc:relation","dcrelation" ;
97     "dc:rights","dcrights" ;
98     "dc:source","dcsource" ;
99     "dc:subject","dcsubject" ;
100     "dc:title","dctitle" ;
101     "hth:ResourceFormat","hthResourceFormat" ;
102     "hth:contact","hthcontact" ;
103     "hth:firstVersion","hthfirstVersion" ;
104     "hth:institution","hthinstitution" ;
105     "hth:modified","hthmodified"
106  ]
107  in
108   let msg = mk_new_msg () in
109   msg_output_dc_header msg obj ;
110   List.iter
111    (fun (propertyname,tablename) -> 
112      let res =
113       M.exec db
114        ("SELECT * FROM " ^ tablename ^ " WHERE uri = '" ^ obj ^ "';") in
115      M.iter res
116       ~f:(function cols ->
117         let value = value_of_optional_value (cols.(0)) in
118         msg_output_string msg
119          ("    <" ^ propertyname ^ ">" ^ value ^ "</" ^ propertyname ^ ">\n") ;
120       ) ;
121    ) tables ;
122    msg_output_dc_trailer msg ;
123    msg_serialize msg
124 ;;
125
126 let debug_print s = prerr_endline ("[RDFly] " ^ s)
127
128 let mk_return_fun contype msg outchan =
129   Http_daemon.respond
130     ~body:msg ~headers:["Content-Type", contype] outchan
131                                                                                                                                                                                     
132 let return_html = mk_return_fun "text/html"
133 let return_xml = mk_return_fun "text/xml"
134 let return_400 body ch =
135   Http_daemon.respond_error ~code:(`Code 400) ~body ch
136 let return_html_error s = return_html ("<html><body>" ^ s ^ "</body></html>")
137
138 let get_option key =
139   try
140     Some (Helm_registry.get key)
141   with Helm_registry.Key_not_found _ -> None
142
143 let get_int_option key =
144   try
145     Some (Helm_registry.get_int key)
146   with Helm_registry.Key_not_found _ -> None
147
148 let host = get_option "rdfly.mysql_connection.host";;
149 let database = get_option "rdfly.mysql_connection.database";;
150 let port = get_int_option "rdfly.mysql_connection.port";;
151 let password = get_option "rdfly.mysql_connection.password";;
152 let user = get_option "rdfly.mysql_connection.user";;
153 let daemonport = Helm_registry.get_int "rdfly.port";;
154
155 let callback (req: Http_types.request) ch =
156   try
157     debug_print ("Connection from " ^ req#clientAddr) ;
158     debug_print ("Received request: " ^ req#uri) ;
159     (match req#path with
160     | "/help" ->
161         return_html_error "yeah right..." ch
162     | "/get" ->
163       let obj = req#param "object"
164       and kind = req#param "kind" in
165       let db = open_db ?host ?database ?port ?password ?user () in
166       begin
167         match kind with
168           "forward" -> return_xml (forward_metadata db obj) ch
169         | "backward" -> return_xml (backward_metadata db obj) ch
170         | "dc" -> return_xml (dc_metadata db obj) ch
171         | s -> return_html_error ("unsupported kind: " ^ s) ch
172       end ;
173       M.disconnect db
174     | invalid_request ->
175         Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
176           ch)
177   with
178   | Http_types.Param_not_found attr_name ->
179       return_400 (Printf.sprintf "Parameter '%s' is missing" attr_name) ch
180   | exc ->
181       return_html_error ("Uncaught exception: " ^ (Printexc.to_string exc)) ch
182
183 let main () =
184   Sys.catch_break true;
185   try
186     let d_spec =
187       Http_daemon.daemon_spec ~timeout:(Some 600) ~port:daemonport ~callback ~auto_close:true ()
188     in
189     Http_daemon.main d_spec
190   with Sys.Break -> ()
191 in
192                                                                                                                                                                                     
193 main ()
194