helm/DEVEL/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   List.fold_left (fun acc s -> s ^ acc) "" !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 value_of_optional_value =
  37  function
  38     None -> assert false
  39   | Some v -> v
  40 ;;
  41
  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 ;
  46   M.iter res
  47    ~f:(function cols ->
  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"
  54    ) ;
  55   msg_output_trailer msg ;
  56   msg_serialize msg
  57
  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 ;
  62   M.iter res
  63    ~f:(function cols ->
  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"
  70    ) ;
  71   msg_output_trailer msg ;
  72   msg_serialize msg
  73
  74 let debug_print s = prerr_endline ("[RDFly] " ^ s)
  75
  76 let mk_return_fun contype msg outchan =
  77   Http_daemon.respond
  78     ~body:msg ~headers:["Content-Type", contype] outchan
  79
  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>")
  84
  85 let get_option key =
  86   try
  87     Some (Helm_registry.get key)
  88   with Helm_registry.Key_not_found _ -> None
  89
  90 let get_int_option key =
  91   try
  92     Some (Helm_registry.get_int key)
  93   with Helm_registry.Key_not_found _ -> None
  94
  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";;
 101
 102 let callback (req: Http_types.request) ch =
 103   try
 104     debug_print ("Connection from " ^ req#clientAddr) ;
 105     debug_print ("Received request: " ^ req#path) ;
 106     (match req#path with
 107     | "/help" ->
 108         return_html_error "yeah right..." ch
 109     | "/get" ->
 110       let obj = req#param "object"
 111       and kind = req#param "kind" in
 112       let db = open_db ?host ?database ?port ?password ?user () in
 113       begin
 114         match kind with
 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
 118       end ;
 119       M.disconnect db
 120     | invalid_request -> Http_daemon.respond_error ~status:(`Client_error `Bad_request) ch)
 121   with
 122   | Http_types.Param_not_found attr_name ->
 123       return_400 (Printf.sprintf "Parameter '%s' is missing" attr_name) ch
 124   | exc ->
 125       return_html_error ("Uncaught exception: " ^ (Printexc.to_string exc)) ch
 126
 127 let main () =
 128   Sys.catch_break true;
 129   try
 130     Http_daemon.start'
 131       ~timeout:(Some 600) ~port:daemonport callback
 132   with Sys.Break -> ()
 133 in
 134
 135 main ()
 136