helm/software/daemons/rdfly/rdfly.ml

   1
   2 module Registry = Helm_registry
   3 module SQL = HSql
   4 module DB = LibraryDb
   5
   6 let exec_and_iter dbd query f =
   7    let db_types = [SQL.Library; SQL.Legacy] in
   8    let map db_type =
   9       let res = SQL.exec db_type dbd query in
  10       SQL.iter res ~f
  11    in
  12    List.iter map db_types
  13
  14 let extract_position s =
  15   let sharp_pos = String.rindex s '#' + 1 in
  16   String.sub s sharp_pos ((String.length s) - sharp_pos)
  17
  18 let mk_new_msg () = ref []
  19
  20 let msg_output_string msg s = msg := s::!msg
  21
  22 let msg_serialize msg =
  23   String.concat "" (List.rev !msg)
  24
  25 let msg_output_header msg obj =
  26   msg_output_string msg "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n\n" ;
  27   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")
  28
  29 let msg_output_trailer msg =
  30   msg_output_string msg "  </h:Object>\n</rdf:RDF>\n"
  31
  32 let msg_output_dc_header msg obj =
  33   msg_output_string msg "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n\n" ;
  34   msg_output_string msg ("<rdf:RDF xml:lang=\"en\"\n         xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\n         xmlns:rdfs=\"http://www.w3.org/2000/01/rdf-schema#\"\n         xmlns:dc=\"http://purl.org/metadata/dublin_core#\"\n         xmlns:dcq=\"http://purl.org/metadata/dublin_core_qualifiers#\"\n         xmlns:h=\"http:/www.cs.unibo.it/helm/schemas/schema-h.rdf#\"\n         xmlns:hth=\"http://www.cs.unibo.it/helm/schemas/schema-hth.rdf#\">\n") ;
  35   msg_output_string msg "  <h:DirectoryOfObjects>"
  36
  37 let msg_output_dc_trailer msg =
  38   msg_output_string msg "  </h:DirectoryOfObjects>\n</rdf:RDF>"
  39
  40 let value_of_optional_value =
  41  function
  42     None -> assert false
  43   | Some v -> v
  44
  45 let forward_metadata dbd obj =
  46   let msg = mk_new_msg () in
  47   let query = "SELECT * FROM refObj WHERE source = '" ^ obj ^ "';" in
  48   let map cols =
  49      let position = extract_position (value_of_optional_value (cols.(2))) in
  50      let occurrence = value_of_optional_value (cols.(1)) in
  51      msg_output_string msg "    <h:refObj>\n      <h:Occurrence>\n" ;
  52      msg_output_string msg ("        <h:position>" ^ position ^ "</h:position>\n") ;
  53      msg_output_string msg ("        <h:occurrence>" ^ occurrence ^ "</h:occurrence>\n") ;
  54      msg_output_string msg "      </h:Occurrence>\n    </h:refObj>\n"
  55   in
  56   msg_output_header msg obj ;
  57   exec_and_iter dbd query map ;
  58   msg_output_trailer msg ;
  59   msg_serialize msg
  60
  61 let backward_metadata dbd obj =
  62   let msg = mk_new_msg () in
  63   let query = "SELECT * FROM refObj WHERE h_occurrence = '" ^ obj ^ "';" in
  64   let map cols =
  65      let position = extract_position (value_of_optional_value (cols.(2))) in
  66      let occurrence = value_of_optional_value (cols.(0)) in
  67      msg_output_string msg "    <h:backPointer>\n      <h:Occurrence>\n" ;
  68      msg_output_string msg ("        <h:position>" ^ position ^ "</h:position>\n") ;
  69      msg_output_string msg ("        <h:occurrence>" ^ occurrence ^ "</h:occurrence>\n") ;
  70      msg_output_string msg "      </h:Occurrence>\n    </h:backPointer>\n"
  71   in
  72   msg_output_header msg obj ;
  73   exec_and_iter dbd query map ;
  74   msg_output_trailer msg ;
  75   msg_serialize msg
  76
  77 let dc_metadata dbd obj =
  78    let tables =
  79    [ "dc:creator","dccreator" ;
  80      "dc:date","dcdate" ;
  81      "dc:description","dcdescription" ;
  82      "dc:format","dcformat" ;
  83      "dc:identifier","dcidentifier" ;
  84      "dc:language","dclanguage" ;
  85      "dc:publisher","dcpublisher" ;
  86      "dcq:RelationType","dcqRelationType" ;
  87      "dc:relation","dcrelation" ;
  88      "dc:rights","dcrights" ;
  89      "dc:source","dcsource" ;
  90      "dc:subject","dcsubject" ;
  91      "dc:title","dctitle" ;
  92      "hth:ResourceFormat","hthResourceFormat" ;
  93      "hth:contact","hthcontact" ;
  94      "hth:firstVersion","hthfirstVersion" ;
  95      "hth:institution","hthinstitution" ;
  96      "hth:modified","hthmodified"
  97    ]
  98    in
  99    let msg = mk_new_msg () in
 100    let table_map (propertyname, tablename) =
 101       let query = "SELECT * FROM " ^ tablename ^ " WHERE uri = '" ^ obj ^ "';" in
 102       let map cols =
 103          let value = value_of_optional_value (cols.(0)) in
 104          msg_output_string msg
 105          ("    <" ^ propertyname ^ ">" ^ value ^ "</" ^ propertyname ^ ">\n")
 106       in
 107       exec_and_iter dbd query map
 108    in
 109    msg_output_dc_header msg obj ;
 110    List.iter table_map tables ;
 111    msg_output_dc_trailer msg ;
 112    msg_serialize msg
 113
 114 let debug_print s = prerr_endline ("[RDFly] " ^ s)
 115
 116 let mk_return_fun contype msg outchan =
 117   Http_daemon.respond
 118     ~body:msg ~headers:["Content-Type", contype] outchan
 119
 120 let return_html = mk_return_fun "text/html"
 121 let return_xml = mk_return_fun "text/xml"
 122 let return_400 body ch =
 123   Http_daemon.respond_error ~code:(`Code 400) ~body ch
 124 let return_html_error s = return_html ("<html><body>" ^ s ^ "</body></html>")
 125
 126 (* First of all we load the configuration *)
 127 let configuration_file = "/projects/helm/etc/rdfly.conf.xml"
 128 let _ = Registry.load_from configuration_file
 129 let db_spec = DB.parse_dbd_conf ()
 130 let daemonport = Helm_registry.get_int "rdfly.port"
 131
 132 let callback (req: Http_types.request) ch =
 133   try
 134     debug_print ("Connection from " ^ req#clientAddr) ;
 135     debug_print ("Received request: " ^ req#uri) ;
 136     (match req#path with
 137     | "/help" ->
 138         return_html_error "yeah right..." ch
 139     | "/get" ->
 140       let obj = req#param "object" in
 141       let kind = req#param "kind" in
 142       let dbd = SQL.quick_connect db_spec in
 143       begin
 144         match kind with
 145           "forward" -> return_xml (forward_metadata dbd obj) ch
 146         | "backward" -> return_xml (backward_metadata dbd obj) ch
 147         | "dc" -> return_xml (dc_metadata dbd obj) ch
 148         | s -> return_html_error ("unsupported kind: " ^ s) ch
 149       end ;
 150       SQL.disconnect dbd
 151     | invalid_request ->
 152         Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
 153           ch)
 154   with
 155   | Http_types.Param_not_found attr_name ->
 156       return_400 (Printf.sprintf "Parameter '%s' is missing" attr_name) ch
 157   | exc ->
 158       prerr_endline (Printexc.to_string exc);
 159       return_html_error ("Uncaught exception: " ^ (Printexc.to_string exc)) ch
 160
 161 let main () =
 162   Sys.catch_break true;
 163   try
 164     let d_spec =
 165       Http_daemon.daemon_spec ~timeout:(Some 600) ~port:daemonport ~callback ~auto_close:true ()
 166     in
 167     Http_daemon.main d_spec
 168   with Sys.Break -> ()
 169 ;;
 170
 171 main ()