From: Claudio Sacerdoti Coen Date: Fri, 20 Feb 2004 16:47:21 +0000 (+0000) Subject: Ported to X-Git-Tag: v0_0_4~127 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=5a9b1f46a8e866382a71d686e689e9e5907f1824;p=helm.git Ported to - Helm_registry - Mysql --- diff --git a/helm/DEVEL/rdfly/.cvsignore b/helm/DEVEL/rdfly/.cvsignore new file mode 100644 index 000000000..5424f8c69 --- /dev/null +++ b/helm/DEVEL/rdfly/.cvsignore @@ -0,0 +1 @@ +*.o *.cm[iox] rdfly rdfly.opt diff --git a/helm/DEVEL/rdfly/Makefile b/helm/DEVEL/rdfly/Makefile index 92fdb740e..779bb7b44 100644 --- a/helm/DEVEL/rdfly/Makefile +++ b/helm/DEVEL/rdfly/Makefile @@ -1,5 +1,5 @@ BIN_DIR = /usr/local/bin -REQUIRES = postgres http +REQUIRES = mysql http helm-registry PREDICATES = OCAMLOPTIONS = -package "$(REQUIRES)" -predicates "$(PREDICATES)" -pp camlp4o OCAMLFIND = ocamlfind @@ -10,7 +10,10 @@ OCAMLDEP = ocamldep -pp camlp4o 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) diff --git a/helm/DEVEL/rdfly/query.ml b/helm/DEVEL/rdfly/query.ml deleted file mode 100644 index f63d780cb..000000000 --- a/helm/DEVEL/rdfly/query.ml +++ /dev/null @@ -1,105 +0,0 @@ - -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 "\n\n" ; - msg_output_string msg ("\n \n") - -let msg_output_trailer msg = - msg_output_string msg " \n\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 " \n \n" ; - msg_output_string msg (" " ^ position ^ "\n") ; - msg_output_string msg (" " ^ occurrence ^ "\n") ; - msg_output_string msg " \n \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 " \n \n" ; - msg_output_string msg (" " ^ position ^ "\n") ; - msg_output_string msg (" " ^ occurrence ^ "\n") ; - msg_output_string msg " \n \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 ("" ^ s ^ "") - -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 () - diff --git a/helm/DEVEL/rdfly/rdfly.conf.xml.sample b/helm/DEVEL/rdfly/rdfly.conf.xml.sample new file mode 100644 index 000000000..360797898 --- /dev/null +++ b/helm/DEVEL/rdfly/rdfly.conf.xml.sample @@ -0,0 +1,13 @@ + + +
+
+ localhost + bjIcRpru + helmadmin + mowgli + 3306 +
+ 58086 +
+ diff --git a/helm/DEVEL/rdfly/rdfly.ml b/helm/DEVEL/rdfly/rdfly.ml new file mode 100644 index 000000000..0a268ce7c --- /dev/null +++ b/helm/DEVEL/rdfly/rdfly.ml @@ -0,0 +1,126 @@ + +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 "\n\n" ; + msg_output_string msg ("\n \n") + +let msg_output_trailer msg = + msg_output_string msg " \n\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 " \n \n" ; + msg_output_string msg (" " ^ position ^ "\n") ; + msg_output_string msg (" " ^ occurrence ^ "\n") ; + msg_output_string msg " \n \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 " \n \n" ; + msg_output_string msg (" " ^ position ^ "\n") ; + msg_output_string msg (" " ^ occurrence ^ "\n") ; + msg_output_string msg " \n \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 ("" ^ s ^ "") + +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 () +