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 = String.concat "" (List.rev !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 msg_output_dc_header msg obj = msg_output_string msg "\n\n" ; msg_output_string msg ("\n") ; msg_output_string msg " " ;; let msg_output_dc_trailer msg = msg_output_string msg " \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 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 ^ "\n") ; ) ; ) tables ; msg_output_dc_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:(`Code 400) ~body ch let return_html_error s = return_html ("" ^ s ^ "") 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#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 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 ~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 | 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 ()