1 (* Copyright (C) 2005, HELM Team.
3 * This file is part of HELM, an Hypertextual, Electronic
4 * Library of Mathematics, developed at the Computer Science
5 * Department, University of Bologna, Italy.
7 * HELM is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * HELM is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with HELM; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
22 * For details, see the HELM World-Wide-Web page,
23 * http://helm.cs.unibo.it/
28 open Http_getter_common
30 open Http_getter_types
32 exception Not_implemented of string
33 exception UnexpectedGetterOutput
40 type logger_callback = HelmLogger.html_tag -> unit
42 let stdout_logger tag = print_string (HelmLogger.string_of_html_tag tag)
44 let not_implemented s = raise (Not_implemented ("Http_getter." ^ s))
46 let index_line_sep_RE = Pcre.regexp "[ \t]+"
47 let index_sep_RE = Pcre.regexp "\r\n|\r|\n"
48 let trailing_types_RE = Pcre.regexp "\\.types$"
49 let heading_cic_RE = Pcre.regexp "^cic:"
50 let heading_theory_RE = Pcre.regexp "^theory:"
51 let heading_nuprl_RE = Pcre.regexp "^nuprl:"
52 let types_RE = Pcre.regexp "\\.types$"
53 let types_ann_RE = Pcre.regexp "\\.types\\.ann$"
54 let body_RE = Pcre.regexp "\\.body$"
55 let body_ann_RE = Pcre.regexp "\\.body\\.ann$"
56 let proof_tree_RE = Pcre.regexp "\\.proof_tree$"
57 let proof_tree_ann_RE = Pcre.regexp "\\.proof_tree\\.ann$"
58 let theory_RE = Pcre.regexp "\\.theory$"
59 let basepart_RE = Pcre.regexp
60 "^([^.]*\\.[^.]*)((\\.body)|(\\.proof_tree)|(\\.types))?(\\.ann)?$"
61 let slash_RE = Pcre.regexp "/"
62 let pipe_RE = Pcre.regexp "\\|"
63 let til_slash_RE = Pcre.regexp "^.*/"
64 let no_slashes_RE = Pcre.regexp "^[^/]*$"
65 let fix_regexp_RE = Pcre.regexp ("^" ^ (Pcre.quote "(cic|theory)"))
66 let showable_file_RE =
67 Pcre.regexp "(\\.con|\\.ind|\\.var|\\.body|\\.types|\\.proof_tree)$"
69 let xml_suffix = ".xml"
70 let theory_suffix = ".theory"
72 (* global maps, shared by all threads *)
74 let ends_with_slash s =
76 s.[String.length s - 1] = '/'
77 with Invalid_argument _ -> false
79 (* should we use a remote getter or not *)
82 Helm_registry.get "getter.mode" = "remote"
83 with Helm_registry.Key_not_found _ -> false
85 let getter_url () = Helm_registry.get "getter.url"
87 (* Remote interface: getter methods implemented using a remote getter *)
90 let getxml_remote uri = not_implemented "getxml_remote"
91 let getxslt_remote uri = not_implemented "getxslt_remote"
92 let getdtd_remote uri = not_implemented "getdtd_remote"
93 let clean_cache_remote () = not_implemented "clean_cache_remote"
94 let list_servers_remote () = not_implemented "list_servers_remote"
95 let add_server_remote ~logger ~position name =
96 not_implemented "add_server_remote"
97 let remove_server_remote ~logger position =
98 not_implemented "remove_server_remote"
99 let getalluris_remote () = not_implemented "getalluris_remote"
100 let ls_remote lsuri = not_implemented "ls_remote"
101 let exists_remote uri = not_implemented "exists_remote"
104 let resolve_remote uri =
105 (* deliver resolve request to http_getter *)
107 Http_getter_wget.get (sprintf "%sresolve?uri=%s" (getter_url ()) uri)
109 let res = ref Unknown in
110 let start_element tag attrs =
114 res := Resolved (List.assoc "value" attrs)
115 with Not_found -> ())
116 | "unresolvable" -> res := Exception (Unresolvable_URI uri)
117 | "not_found" -> res := Exception (Key_not_found uri)
121 XmlPushParser.default_callbacks with
122 XmlPushParser.start_element = Some start_element
124 let xml_parser = XmlPushParser.create_parser callbacks in
125 XmlPushParser.parse xml_parser (`String doc);
126 XmlPushParser.final xml_parser;
128 | Unknown -> raise UnexpectedGetterOutput
129 | Exception e -> raise e
130 | Resolved url -> url
132 let deref_index_theory uri =
133 if Http_getter_storage.exists (uri ^ xml_suffix) then uri
134 else if is_theory_uri uri && Filename.basename uri = "index.theory" then
135 strip_trailing_slash (Filename.dirname uri) ^ theory_suffix
141 let help () = Http_getter_const.usage_string (Http_getter_env.env_to_string ())
144 (* prerr_endline ("Http_getter.exists " ^ uri); *)
148 let uri = deref_index_theory uri in
149 Http_getter_storage.exists (uri ^ xml_suffix)
155 let uri = deref_index_theory uri in
157 Http_getter_storage.resolve (uri ^ xml_suffix)
158 with Http_getter_storage.Resource_not_found _ -> raise (Key_not_found uri)
161 if remote () then getxml_remote uri
163 let uri' = deref_index_theory uri in
165 Http_getter_storage.filename (uri' ^ xml_suffix)
166 with Http_getter_storage.Resource_not_found _ -> raise (Key_not_found uri))
170 if remote () then getxslt_remote uri
171 else Http_getter_storage.filename ~find:true ("xslt:/" ^ uri)
177 let fname = Lazy.force Http_getter_env.dtd_dir ^ "/" ^ uri in
178 if not (Sys.file_exists fname) then raise (Dtd_not_found uri);
184 clean_cache_remote ()
186 Http_getter_storage.clean_cache ()
188 let (++) (oldann, oldtypes, oldbody, oldtree)
189 (newann, newtypes, newbody, newtree) =
190 ((if newann > oldann then newann else oldann),
191 (if newtypes > oldtypes then newtypes else oldtypes),
192 (if newbody > oldbody then newbody else oldbody),
193 (if newtree > oldtree then newtree else oldtree))
195 let store_obj tbl o =
196 (* prerr_endline ("Http_getter.store_obj " ^ o); *)
197 if Pcre.pmatch ~rex:showable_file_RE o then begin
198 let basepart = Pcre.replace ~rex:basepart_RE ~templ:"$1" o in
199 let no_flags = false, No, No, No in
202 Hashtbl.find tbl basepart
203 with Not_found -> (* no ann, no types, no body, no proof tree *)
208 | s when Pcre.pmatch ~rex:types_RE s -> (false, Yes, No, No)
209 | s when Pcre.pmatch ~rex:types_ann_RE s -> (true, Ann, No, No)
210 | s when Pcre.pmatch ~rex:body_RE s -> (false, No, Yes, No)
211 | s when Pcre.pmatch ~rex:body_ann_RE s -> (true, No, Ann, No)
212 | s when Pcre.pmatch ~rex:proof_tree_RE s -> (false, No, No, Yes)
213 | s when Pcre.pmatch ~rex:proof_tree_ann_RE s -> (true, No, No, Ann)
216 Hashtbl.replace tbl basepart (oldflags ++ newflags)
219 let store_dir set_ref d =
220 set_ref := StringSet.add (List.hd (Pcre.split ~rex:slash_RE d)) !set_ref
222 let collect_ls_items dirs_set objs_tbl =
223 let items = ref [] in
224 StringSet.iter (fun dir -> items := Ls_section dir :: !items) dirs_set;
225 Http_getter_misc.hashtbl_sorted_iter
226 (fun uri (annflag, typesflag, bodyflag, treeflag) ->
229 uri = uri; ann = annflag;
230 types = typesflag; body = bodyflag; proof_tree = treeflag
235 let contains_object = (<>) []
237 (** non regexp-aware version of ls *)
238 let rec dumb_ls uri_prefix =
239 (* prerr_endline ("Http_getter.dumb_ls " ^ uri_prefix); *)
240 if is_cic_obj_uri uri_prefix then begin
241 let dirs = ref StringSet.empty in
242 let objs = Hashtbl.create 17 in
245 if ends_with_slash fname then
249 store_obj objs (strip_suffix ~suffix:xml_suffix fname)
250 with Invalid_argument _ -> ())
251 (Http_getter_storage.ls uri_prefix);
252 collect_ls_items !dirs objs
253 end else if is_theory_uri uri_prefix then begin
254 let items = ref [] in
255 let add_theory fname =
258 uri = fname; ann = false; types = No; body = No; proof_tree = No }
262 Pcre.replace_first ~rex:heading_theory_RE ~templ:"cic:" uri_prefix
266 if ends_with_slash fname then
267 items := Ls_section (strip_trailing_slash fname) :: !items
270 let fname = strip_suffix ~suffix:xml_suffix fname in
271 let theory_name = strip_suffix ~suffix:theory_suffix fname in
272 let sub_theory = normalize_dir cic_uri_prefix ^ theory_name ^ "/" in
273 if is_empty_theory sub_theory then add_theory fname
274 with Invalid_argument _ -> ())
275 (Http_getter_storage.ls uri_prefix);
277 if contains_object (dumb_ls cic_uri_prefix)
278 && exists (strip_trailing_slash uri_prefix ^ theory_suffix)
280 add_theory "index.theory";
281 with Unresolvable_URI _ -> ());
284 raise (Invalid_URI uri_prefix)
286 and is_empty_theory uri_prefix =
287 (* prerr_endline ("is_empty_theory " ^ uri_prefix); *)
288 not (contains_object (dumb_ls uri_prefix))
290 (* handle simple regular expressions of the form "...(..|..|..)..." on cic
291 * uris, not meant to be a real implementation of regexp. The only we use is
292 * "(cic|theory):/..." *)
293 let explode_ls_regexp regexp =
295 let len = String.length regexp in
296 let lparen_idx = String.index regexp '(' in
297 let rparen_idx = String.index_from regexp lparen_idx ')' in
298 let choices_str = (* substring between parens, parens excluded *)
299 String.sub regexp (lparen_idx + 1) (rparen_idx - lparen_idx - 1)
301 let choices = Pcre.split ~rex:pipe_RE choices_str in
302 let prefix = String.sub regexp 0 lparen_idx in
303 let suffix = String.sub regexp (rparen_idx + 1) (len - (rparen_idx + 1)) in
304 List.map (fun choice -> prefix ^ choice ^ suffix) choices
305 with Not_found -> [regexp]
307 let merge_results results =
308 let rec aux objects_acc dirs_acc = function
309 | [] -> dirs_acc @ objects_acc
310 | Ls_object _ as obj :: tl -> aux (obj :: objects_acc) dirs_acc tl
311 | Ls_section _ as dir :: tl ->
312 if List.mem dir dirs_acc then (* filters out dir duplicates *)
313 aux objects_acc dirs_acc tl
315 aux objects_acc (dir :: dirs_acc) tl
317 aux [] [] (List.concat results)
323 let prefixes = explode_ls_regexp regexp in
324 merge_results (List.map dumb_ls prefixes)
327 let rec aux acc = function
332 (fun (acc, subdirs) result ->
334 | Ls_object obj -> (dir ^ obj.uri) :: acc, subdirs
335 | Ls_section sect -> acc, (dir ^ sect ^ "/") :: subdirs)
341 aux [] ["cic:/"] (* trailing slash required *)
343 (* Shorthands from now on *)
345 let getxml' uri = getxml (UriManager.string_of_uri uri)
346 let resolve' uri = resolve (UriManager.string_of_uri uri)
347 let exists' uri = exists (UriManager.string_of_uri uri)
349 let tilde_expand_key k =
351 Helm_registry.set k (HExtlib.tilde_expand (Helm_registry.get k))
352 with Helm_registry.Key_not_found _ -> ()
355 List.iter tilde_expand_key ["getter.cache_dir"; "getter.dtd_dir"];
356 Http_getter_logger.set_log_level
357 (Helm_registry.get_opt_default Helm_registry.int ~default:1
359 Http_getter_logger.set_log_file
360 (Helm_registry.get_opt Helm_registry.string "getter.log_file")