--- /dev/null
+*.o *.cm[iox] rdfly rdfly.opt
BIN_DIR = /usr/local/bin
-REQUIRES = postgres http
+REQUIRES = mysql http helm-registry
PREDICATES =
OCAMLOPTIONS = -package "$(REQUIRES)" -predicates "$(PREDICATES)" -pp camlp4o
OCAMLFIND = ocamlfind
LIBRARIES = $(shell $(OCAMLFIND) query -recursive -predicates "byte $(PREDICATES)" -format "%d/%a" $(REQUIRES))
LIBRARIES_OPT = $(shell $(OCAMLFIND) query -recursive -predicates "native $(PREDICATES)" -format "%d/%a" $(REQUIRES))
-OBJS = query.cmo
+OBJS = rdfly.cmo
+
+all: rdfly
+opt: rdfly.opt
rdfly: $(OBJS) $(LIBRARIES)
$(OCAMLC) -linkpkg -o $@ $(OBJS)
+++ /dev/null
-
-module PG = Postgres
-
-let open_db connection_string =
- try
- new PG.connection connection_string
- with
- PG.Error e as exc ->
- prerr_endline (PG.string_of_error e) ;
- raise exc
-
-let extract_position s =
- let sharp_pos = String.rindex s '#' + 1 in
- String.sub s sharp_pos ((String.length s) - sharp_pos)
-
-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
-
-let msg_output_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\" 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")
-
-let msg_output_trailer msg =
- msg_output_string msg " </h:Object>\n</rdf:RDF>\n"
-
-let forward_metadata db obj =
- let res = db#exec ("SELECT * FROM refObj WHERE source = '" ^ obj ^ "';") in
- let msg = mk_new_msg () in
- msg_output_header msg obj ;
- for i = res#ntuples downto 1 do
- let position = extract_position (res#getvalue (i - 1) 2)
- and occurrence = res#getvalue (i - 1) 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"
- done ;
- msg_output_trailer msg ;
- msg_serialize msg
-
-let backward_metadata db obj =
- let res = db#exec ("SELECT * FROM refObj WHERE h_occurrence = '" ^ obj ^ "';") in
- let msg = mk_new_msg () in
- msg_output_header msg obj ;
- for i = res#ntuples downto 1 do
- let position = extract_position (res#getvalue (i - 1) 2)
- and occurrence = res#getvalue (i - 1) 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"
- done ;
- msg_output_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:400 ~body ch
-let return_html_error s = return_html ("<html><body>" ^ s ^ "</body></html>")
-
-let callback (req: Http_types.request) ch =
- try
- debug_print ("Connection from " ^ req#clientAddr) ;
- debug_print ("Received request: " ^ req#path) ;
- (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 "dbname='mowgli' user='helm'" in
- begin
- match kind with
- "forward" -> return_xml (forward_metadata db obj) ch
- | "backward" -> return_xml (backward_metadata db obj) ch
- | s -> return_html_error ("unsupported kind: " ^ s) ch
- end ;
- db#close
- | invalid_request -> Http_daemon.respond_error ~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
- | exc ->
- return_html_error ("Uncaught exception: " ^ (Printexc.to_string exc)) ch
-
-let main () =
- Sys.catch_break true;
- try
- Http_daemon.start'
- ~timeout:(Some 600) ~port:58088 callback
- with Sys.Break -> ()
-in
-
-main ()
-
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+<helm_registry>
+ <section name="rdfly">
+ <section name="mysql_connection">
+ <key name="host">localhost</key>
+ <key name="password">bjIcRpru</key>
+ <key name="user">helmadmin</key>
+ <key name="database">mowgli</key>
+ <key name="port">3306</key>
+ </section>
+ <key name="port">58086</key>
+ </section>
+</helm_registry>
--- /dev/null
+
+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
+
+let extract_position s =
+ let sharp_pos = String.rindex s '#' + 1 in
+ String.sub s sharp_pos ((String.length s) - sharp_pos)
+
+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
+
+let msg_output_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\" 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")
+
+let msg_output_trailer msg =
+ msg_output_string msg " </h:Object>\n</rdf:RDF>\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 msg = mk_new_msg () in
+ msg_output_header msg obj ;
+ M.iter res
+ ~f:(function 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"
+ ) ;
+ 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 msg = mk_new_msg () in
+ msg_output_header msg obj ;
+ M.iter res
+ ~f:(function 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"
+ ) ;
+ msg_output_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: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 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) ;
+ (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
+ begin
+ match kind with
+ "forward" -> return_xml (forward_metadata db obj) ch
+ | "backward" -> return_xml (backward_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)
+ with
+ | Http_types.Param_not_found attr_name ->
+ return_400 (Printf.sprintf "Parameter '%s' is missing" attr_name) ch
+ | exc ->
+ return_html_error ("Uncaught exception: " ^ (Printexc.to_string exc)) ch
+
+let main () =
+ Sys.catch_break true;
+ try
+ Http_daemon.start'
+ ~timeout:(Some 600) ~port:daemonport callback
+ with Sys.Break -> ()
+in
+
+main ()
+
projects / helm.git / commitdiff