let msg_output_string msg s = msg := s::!msg
let msg_serialize msg =
- List.fold_left (fun acc s -> s ^ acc) "" !msg
+ String.concat "" (List.rev !msg)
let msg_output_header msg obj =
msg_output_string msg "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n\n" ;
let msg_output_trailer msg =
msg_output_string msg " </h:Object>\n</rdf:RDF>\n"
+let msg_output_dc_header msg obj =
+ msg_output_string msg "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n\n" ;
+ 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") ;
+ msg_output_string msg " <h:DirectoryOfObjects>"
+;;
+
+let msg_output_dc_trailer msg =
+ msg_output_string msg " </h:DirectoryOfObjects>\n</rdf:RDF>"
+;;
+
let value_of_optional_value =
function
None -> assert false
) ;
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
) ;
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 ^ "</" ^ propertyname ^ ">\n") ;
+ ) ;
+ ) tables ;
+ msg_output_dc_trailer msg ;
+ msg_serialize msg
+;;
let debug_print s = prerr_endline ("[RDFly] " ^ s)
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_400 body ch =
+ Http_daemon.respond_error ~code:(`Code 400) ~body ch
let return_html_error s = return_html ("<html><body>" ^ s ^ "</body></html>")
let get_option key =
let callback (req: Http_types.request) ch =
try
debug_print ("Connection from " ^ req#clientAddr) ;
- debug_print ("Received request: " ^ req#path) ;
+ debug_print ("Received request: " ^ req#uri) ;
(match req#path with
| "/help" ->
return_html_error "yeah right..." ch
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 ~status:(`Client_error `Bad_request) ch)
+ | 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
projects / helm.git / blobdiff