- | uri -> raise (Http_getter_unresolvable_URI uri)
-in
-let resolve uri = (map_of_uri uri)#resolve uri in
-let register uri = (map_of_uri uri )#add uri in
-let return_all_foo_uris map doctype filter outchan =
- (** return all URIs contained in 'map' which satisfy predicate 'filter'; URIs
- are written in an XMLish format ('doctype' is the XML doctype) onto 'outchan'
- *)
- Http_daemon.send_basic_headers ~code:200 outchan;
- Http_daemon.send_header "Content-Type" "text/xml" outchan;
- Http_daemon.send_headers common_headers outchan;
- Http_daemon.send_CRLF outchan;
- output_string
- outchan
- (sprintf
-"<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>
-<!DOCTYPE %s SYSTEM \"%s/getdtd?uri=%s.dtd\">
-
-<%s>
-"
- doctype
- Http_getter_env.my_own_url
- doctype
- doctype);
- map#iter
- (fun uri _ ->
- if filter uri then
- output_string outchan (sprintf "\t<uri value=\"%s\" />\n" uri));
- output_string outchan (sprintf "</%s>\n" doctype)
-in
-let return_all_xml_uris = return_all_foo_uris xml_map "alluris" in
-let return_all_rdf_uris = return_all_foo_uris rdf_map "allrdfuris" in
-let return_ls =
- let (++) (oldann, oldtypes, oldbody) (newann, newtypes, newbody) =
- ((if newann > oldann then newann else oldann),
- (if newtypes > oldtypes then newtypes else oldtypes),
- (if newbody > oldbody then newbody else oldbody))
- in
- let basepart_RE =
- Pcre.regexp "^([^.]*\\.[^.]*)((\\.body)|(\\.types))?(\\.ann)?"
- in
- let (types_RE, types_ann_RE, body_RE, body_ann_RE) =
- (Pcre.regexp "\\.types", Pcre.regexp "\\.types.ann",
- Pcre.regexp "\\.body", Pcre.regexp "\\.body.ann")
- in
- let (slash_RE, til_slash_RE, no_slashes_RE) =
- (Pcre.regexp "/", Pcre.regexp "^.*/", Pcre.regexp "^[^/]*$")
- in
- fun lsuri fmt outchan ->
- let pat =
- "^" ^
- (match lsuri with Cic p -> ("cic:" ^ p) | Theory p -> ("theory:" ^ p))
- in
- let (dir_RE, obj_RE) =
- (Pcre.regexp (pat ^ "/"), Pcre.regexp (pat ^ "(\\.|$)"))
- in
- let dirs = ref StringSet.empty in
- let objs = Hashtbl.create 17 in
- let store_dir d =
- dirs := StringSet.add (List.hd (Pcre.split ~rex:slash_RE d)) !dirs
- in
- let store_obj o =
- let basepart = Pcre.replace ~rex:basepart_RE ~templ:"$1" o in
- let oldflags =
- try
- Hashtbl.find objs basepart
- with Not_found -> (false, No, No) (* no ann, no types no body *)
- in
- let newflags =
- match o with
- | s when Pcre.pmatch ~rex:types_RE s -> (false, Yes, No)
- | s when Pcre.pmatch ~rex:types_ann_RE s -> (true, Ann, No)
- | s when Pcre.pmatch ~rex:body_RE s -> (false, No, Yes)
- | s when Pcre.pmatch ~rex:body_ann_RE s -> (true, No, Ann)
- | s -> (false, No, No)
- in
- Hashtbl.replace objs basepart (oldflags ++ newflags)
- in
- xml_map#iter (* BLEARGH Dbm module lacks support for fold-like functions *)
- (fun key _ ->
- match key with
- | uri when Pcre.pmatch ~rex:dir_RE uri -> (* directory hit *)
- let localpart = Pcre.replace ~rex:dir_RE uri in
- if Pcre.pmatch ~rex:no_slashes_RE localpart then
- store_obj localpart
- else
- store_dir localpart
- | uri when Pcre.pmatch ~rex:obj_RE uri -> (* file hit *)
- store_obj (Pcre.replace ~rex:til_slash_RE uri)
- | uri -> () (* miss *));
- match fmt with
- | Fmt_text ->
- let body =
- (List.fold_left
- (fun s d -> sprintf "%sdir, %s\n" s d) ""
- (StringSet.elements !dirs)) ^
- (Http_getter_misc.hashtbl_sorted_fold
- (fun uri (annflag, typesflag, bodyflag) cont ->
- sprintf "%sobject, %s, <%s,%s,%s>\n"
- cont uri (if annflag then "YES" else "NO")
- (string_of_ls_flag typesflag) (string_of_ls_flag bodyflag))
- objs "")
- in
- Http_daemon.respond
- ~headers:(("Content-Type", "text/plain") :: common_headers)
- ~body outchan
- | Fmt_xml ->
- let body =
- sprintf
-"<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>
-<!DOCTYPE ls SYSTEM \"%s/getdtd?uri=ls.dtd\">