4 (* First of all we load the configuration *)
6 let configuration_file = "/projects/helm/etc/rdfly.conf.xml" in
7 Helm_registry.load_from configuration_file
10 let open_db ?host ?database ?port ?password ?user =
12 M.quick_connect ?host ?database ?port ?password ?user
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)
22 let mk_new_msg () = ref []
24 let msg_output_string msg s = msg := s::!msg
26 let msg_serialize msg =
27 List.fold_left (fun acc s -> s ^ acc) "" !msg
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")
33 let msg_output_trailer msg =
34 msg_output_string msg " </h:Object>\n</rdf:RDF>\n"
36 let value_of_optional_value =
42 let forward_metadata db obj =
43 let res = M.exec db ("SELECT * FROM refObj WHERE source = '" ^ obj ^ "';") in
44 let msg = mk_new_msg () in
45 msg_output_header msg obj ;
48 let position = extract_position (value_of_optional_value (cols.(2))) in
49 let occurrence = value_of_optional_value (cols.(1)) in
50 msg_output_string msg " <h:refObj>\n <h:Occurrence>\n" ;
51 msg_output_string msg (" <h:position>" ^ position ^ "</h:position>\n") ;
52 msg_output_string msg (" <h:occurrence>" ^ occurrence ^ "</h:occurrence>\n") ;
53 msg_output_string msg " </h:Occurrence>\n </h:refObj>\n"
55 msg_output_trailer msg ;
58 let backward_metadata db obj =
59 let res = M.exec db ("SELECT * FROM refObj WHERE h_occurrence = '" ^ obj ^ "';") in
60 let msg = mk_new_msg () in
61 msg_output_header msg obj ;
64 let position = extract_position (value_of_optional_value (cols.(2))) in
65 let occurrence = value_of_optional_value (cols.(0)) in
66 msg_output_string msg " <h:backPointer>\n <h:Occurrence>\n" ;
67 msg_output_string msg (" <h:position>" ^ position ^ "</h:position>\n") ;
68 msg_output_string msg (" <h:occurrence>" ^ occurrence ^ "</h:occurrence>\n") ;
69 msg_output_string msg " </h:Occurrence>\n </h:backPointer>\n"
71 msg_output_trailer msg ;
74 let debug_print s = prerr_endline ("[RDFly] " ^ s)
76 let mk_return_fun contype msg outchan =
78 ~body:msg ~headers:["Content-Type", contype] outchan
80 let return_html = mk_return_fun "text/html"
81 let return_xml = mk_return_fun "text/xml"
82 let return_400 body ch = Http_daemon.respond_error ~code:400 ~body ch
83 let return_html_error s = return_html ("<html><body>" ^ s ^ "</body></html>")
87 Some (Helm_registry.get key)
88 with Helm_registry.Key_not_found _ -> None
90 let get_int_option key =
92 Some (Helm_registry.get_int key)
93 with Helm_registry.Key_not_found _ -> None
95 let host = get_option "rdfly.mysql_connection.host";;
96 let database = get_option "rdfly.mysql_connection.database";;
97 let port = get_int_option "rdfly.mysql_connection.port";;
98 let password = get_option "rdfly.mysql_connection.password";;
99 let user = get_option "rdfly.mysql_connection.user";;
100 let daemonport = Helm_registry.get_int "rdfly.port";;
102 let callback (req: Http_types.request) ch =
104 debug_print ("Connection from " ^ req#clientAddr) ;
105 debug_print ("Received request: " ^ req#path) ;
108 return_html_error "yeah right..." ch
110 let obj = req#param "object"
111 and kind = req#param "kind" in
112 let db = open_db ?host ?database ?port ?password ?user () in
115 "forward" -> return_xml (forward_metadata db obj) ch
116 | "backward" -> return_xml (backward_metadata db obj) ch
117 | s -> return_html_error ("unsupported kind: " ^ s) ch
120 | invalid_request -> Http_daemon.respond_error ~status:(`Client_error `Bad_request) ch)
122 | Http_types.Param_not_found attr_name ->
123 return_400 (Printf.sprintf "Parameter '%s' is missing" attr_name) ch
125 return_html_error ("Uncaught exception: " ^ (Printexc.to_string exc)) ch
128 Sys.catch_break true;
131 ~timeout:(Some 600) ~port:daemonport callback