helm/DEVEL/rdfly/query.ml

   1
   2 module PG = Postgres
   3
   4 let open_db connection_string =
   5   try
   6     new PG.connection connection_string
   7   with
   8     PG.Error e as exc ->
   9       prerr_endline (PG.string_of_error e) ;
  10       raise exc
  11
  12 let extract_position s =
  13   let sharp_pos = String.rindex s '#' + 1 in
  14   String.sub s sharp_pos ((String.length s) - sharp_pos)
  15
  16 let mk_new_msg () = ref []
  17
  18 let msg_output_string msg s = msg := s::!msg
  19
  20 let msg_serialize msg =
  21   List.fold_left (fun acc s -> s ^ acc) "" !msg
  22
  23 let msg_output_header msg obj =
  24   msg_output_string msg "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n\n" ;
  25   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")
  26
  27 let msg_output_trailer msg =
  28   msg_output_string msg "  </h:Object>\n</rdf:RDF>\n"
  29
  30 let forward_metadata db obj =
  31   let res = db#exec ("SELECT * FROM refObj WHERE source = '" ^ obj ^ "';") in
  32   let msg = mk_new_msg () in
  33   msg_output_header msg obj ;
  34   for i = res#ntuples downto 1 do
  35     let position = extract_position (res#getvalue (i - 1) 2)
  36     and occurrence = res#getvalue (i - 1) 1 in
  37     msg_output_string msg "    <h:refObj>\n      <h:Occurrence>\n" ;
  38     msg_output_string msg ("        <h:position>" ^ position ^ "</h:position>\n") ;
  39     msg_output_string msg ("        <h:occurrence>" ^ occurrence ^ "</h:occurrence>\n") ;
  40     msg_output_string msg "      </h:Occurrence>\n    </h:refObj>\n"
  41   done ;
  42   msg_output_trailer msg ;
  43   msg_serialize msg
  44
  45 let backward_metadata db obj =
  46   let res = db#exec ("SELECT * FROM refObj WHERE h_occurrence = '" ^ obj ^ "';") in
  47   let msg = mk_new_msg () in
  48   msg_output_header msg obj ;
  49   for i = res#ntuples downto 1 do
  50     let position = extract_position (res#getvalue (i - 1) 2)
  51     and occurrence = res#getvalue (i - 1) 0 in
  52     msg_output_string msg "    <h:backPointer>\n      <h:Occurrence>\n" ;
  53     msg_output_string msg ("        <h:position>" ^ position ^ "</h:position>\n") ;
  54     msg_output_string msg ("        <h:occurrence>" ^ occurrence ^ "</h:occurrence>\n") ;
  55     msg_output_string msg "      </h:Occurrence>\n    </h:backPointer>\n"
  56   done ;
  57   msg_output_trailer msg ;
  58   msg_serialize msg
  59
  60 let debug_print s = prerr_endline ("[RDFly] " ^ s)
  61
  62 let mk_return_fun contype msg outchan =
  63   Http_daemon.respond
  64     ~body:msg ~headers:["Content-Type", contype] outchan
  65
  66 let return_html = mk_return_fun "text/html"
  67 let return_xml = mk_return_fun "text/xml"
  68 let return_400 body ch = Http_daemon.respond_error ~code:400 ~body ch
  69 let return_html_error s = return_html ("<html><body>" ^ s ^ "</body></html>")
  70
  71 let callback (req: Http_types.request) ch =
  72   try
  73     debug_print ("Connection from " ^ req#clientAddr) ;
  74     debug_print ("Received request: " ^ req#path) ;
  75     (match req#path with
  76     | "/help" ->
  77         return_html_error "yeah right..." ch
  78     | "/get" ->
  79       let obj = req#param "object"
  80       and kind = req#param "kind" in
  81       let db = open_db "dbname='mowgli' user='helm'" in
  82       begin
  83         match kind with
  84           "forward" -> return_xml (forward_metadata db obj) ch
  85         | "backward" -> return_xml (backward_metadata db obj) ch
  86         | s -> return_html_error ("unsupported kind: " ^ s) ch
  87       end ;
  88       db#close
  89     | invalid_request -> Http_daemon.respond_error ~status:(`Client_error `Bad_request) ch)
  90   with
  91   | Http_types.Param_not_found attr_name ->
  92       return_400 (Printf.sprintf "Parameter '%s' is missing" attr_name) ch
  93   | exc ->
  94       return_html_error ("Uncaught exception: " ^ (Printexc.to_string exc)) ch
  95
  96 let main () =
  97   Sys.catch_break true;
  98   try
  99     Http_daemon.start'
 100       ~timeout:(Some 600) ~port:58088 callback
 101   with Sys.Break -> ()
 102 in
 103
 104 main ()
 105