]> matita.cs.unibo.it Git - helm.git/blob - matitaB/components/getter/http_getter_storage.ml
update in alpha_1
[helm.git] / matitaB / components / getter / http_getter_storage.ml
1 (* Copyright (C) 2004-2005, HELM Team.
2  * 
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.
6  * 
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.
11  * 
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.
16  *
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,
20  * MA  02111-1307, USA.
21  * 
22  * For details, see the HELM World-Wide-Web page,
23  * http://helm.cs.unibo.it/
24  *)
25
26 (* $Id$ *)
27
28 open Printf
29
30 open Http_getter_misc
31 open Http_getter_types
32
33 exception Not_found'
34 exception Resource_not_found of string * string  (** method, uri *)
35
36 let index_fname = "INDEX"
37
38 (******************************* HELPERS **************************************)
39
40 let trailing_slash_RE = Pcre.regexp "/$"
41 let relative_RE_raw = "(^[^/]+(/[^/]+)*/?$)"
42 let relative_RE = Pcre.regexp relative_RE_raw
43 let file_scheme_RE_raw = "(^file://)"
44 let extended_file_scheme_RE = Pcre.regexp "(^file:/+)"
45 let file_scheme_RE = Pcre.regexp (relative_RE_raw ^ "|" ^ file_scheme_RE_raw)
46 let http_scheme_RE = Pcre.regexp "^http://"
47 let newline_RE = Pcre.regexp "\\n"
48 let cic_scheme_sep_RE = Pcre.regexp ":/"
49 let gz_suffix = ".gz"
50 let gz_suffix_len = String.length gz_suffix
51
52   (* file:///bla -> bla, bla -> bla *)
53 let path_of_file_url url =
54   assert (Pcre.pmatch ~rex:file_scheme_RE url);
55   if Pcre.pmatch ~rex:relative_RE url then
56     url
57   else  (* absolute path, add heading "/" if missing *)
58     "/" ^ (Pcre.replace ~rex:extended_file_scheme_RE url)
59
60 let strip_gz_suffix fname =
61   if extension fname = gz_suffix then
62     String.sub fname 0 (String.length fname - gz_suffix_len)
63   else
64     fname
65
66 let normalize_root uri =  (* add trailing slash to roots *)
67   try
68     if uri.[String.length uri - 1] = ':' then uri ^ "/"
69     else uri
70   with Invalid_argument _ -> uri
71
72 let remove_duplicates l =
73   Http_getter_misc.list_uniq (List.stable_sort Pervasives.compare l)
74
75 let has_rdonly l =  List.exists ((=) `Read_only) l
76 let has_legacy l =  List.exists ((=) `Legacy) l
77 let is_readwrite attrs = (not (has_legacy attrs) && not (has_rdonly attrs))
78
79 let is_file_schema url = Pcre.pmatch ~rex:file_scheme_RE url
80 let is_http_schema url = Pcre.pmatch ~rex:http_scheme_RE url
81
82 let is_empty_listing files = 
83   List.for_all
84    (fun s ->
85      let len = String.length s in
86       len < 4 || String.sub s (len - 4) 4 <> ".xml") files
87
88 (************************* GLOBALS PREFIXES **********************************)
89     
90   (** associative list regular expressions -> url prefixes
91    * sorted with longest prefixes first *)
92 let prefix_map_ref = ref (lazy (
93   List.map
94     (fun (uri_prefix, (url_prefix, attrs)) ->
95       let uri_prefix = normalize_dir uri_prefix in
96       let url_prefix = normalize_dir url_prefix in
97       let regexp = Pcre.regexp ("^(" ^ Pcre.quote uri_prefix ^ ")") in
98       regexp, strip_trailing_slash uri_prefix, url_prefix, attrs)
99     (List.rev (Lazy.force Http_getter_env.prefixes))))
100
101 let prefix_map () = !prefix_map_ref
102
103 let keep_first l = 
104   let cmp (_,x) (_,y) = x = y in
105   let rec aux prev = function
106     | [] -> []
107     | hd::tl -> if cmp prev hd then hd :: aux prev tl else []
108   in
109   match l with
110   | hd :: tl -> hd :: aux hd tl
111   | _ -> assert false
112 ;;
113
114   (** given an uri returns the prefixes for it *)
115 let lookup uri =
116   let matches =
117     HExtlib.filter_map 
118       (fun (rex, _, l, _ as entry) -> 
119          try
120            let got = Pcre.extract ~full_match:true ~rex uri in
121            Some (entry, String.length got.(0))
122          with Not_found -> None)
123       (Lazy.force (prefix_map ())) 
124   in
125   if matches = [] then raise (Unresolvable_URI uri);
126   List.map fst (keep_first (List.sort (fun (_,l1) (_,l2) -> l2 - l1) matches))
127 ;;
128
129 let get_attrs uri = List.map (fun (_, _, _, attrs) -> attrs) (lookup uri)
130
131 (*************************** ACTIONS ******************************************)
132   
133 let exists_http ~local _ url =
134   if local then false else
135   Http_getter_wget.exists (url ^ gz_suffix) || Http_getter_wget.exists url
136
137 let exists_file _ fname =
138   Sys.file_exists (fname ^ gz_suffix) || Sys.file_exists fname
139
140 let resolve_http ~must_exists ~local _ url =
141   if local then raise Not_found' else
142   try
143     if must_exists then
144       List.find Http_getter_wget.exists [ url ^ gz_suffix; url ]
145     else
146       url
147   with Not_found -> raise Not_found'
148
149 let resolve_file ~must_exists _ fname =
150   try
151     if must_exists then
152       List.find Sys.file_exists [ fname ^ gz_suffix; fname ]
153     else
154       fname
155   with Not_found -> raise Not_found'
156
157 let ls_file_single _ path_prefix =
158   let is_dir fname = (Unix.stat fname).Unix.st_kind = Unix.S_DIR in
159   let is_useless dir = try dir.[0] = '.' with _ -> false in
160   let entries = ref [] in
161   try
162     let dir_handle = Unix.opendir path_prefix in
163     (try
164       while true do
165         let entry = Unix.readdir dir_handle in
166         if is_useless entry then
167           ()
168         else if is_dir (path_prefix ^ "/" ^ entry) then
169           entries := normalize_dir entry :: !entries
170         else
171           entries := strip_gz_suffix entry :: !entries
172       done
173     with End_of_file -> Unix.closedir dir_handle);
174     remove_duplicates !entries
175   with Unix.Unix_error (_, "opendir", _) -> []
176
177 let ls_http_single ~local _ url_prefix =
178   if local then raise (Resource_not_found ("get","")) else
179   let url = normalize_dir url_prefix ^ index_fname in
180   try
181     let index = Http_getter_wget.get url in
182     Pcre.split ~rex:newline_RE index
183   with Http_client_error _ -> raise (Resource_not_found ("get",url))
184 ;;
185
186 let get_file _ path =
187   if Sys.file_exists (path ^ gz_suffix) then
188     path ^ gz_suffix
189   else if Sys.file_exists path then
190     path
191   else
192     raise Not_found'
193
194 let get_http ~local uri url =
195   if local then raise Not_found' else
196   let scheme, path =
197     match Pcre.split ~rex:cic_scheme_sep_RE uri with
198     | [scheme; path] -> scheme, path
199     | _ -> assert false
200   in
201   let cache_name =
202     sprintf "%s%s/%s" (Lazy.force Http_getter_env.cache_dir) scheme path
203   in
204   if Sys.file_exists (cache_name ^ gz_suffix) then
205     cache_name ^ gz_suffix
206   else if Sys.file_exists cache_name then
207     cache_name
208   else begin  (* fill cache *)
209     Http_getter_misc.mkdir ~parents:true (Filename.dirname cache_name);
210     (try
211       Http_getter_wget.get_and_save (url ^ gz_suffix) (cache_name ^ gz_suffix);
212       cache_name ^ gz_suffix
213     with Http_client_error _ ->
214       (try
215         Http_getter_wget.get_and_save url cache_name;
216         cache_name
217       with Http_client_error _ ->
218         raise Not_found'))
219   end
220
221 let remove_file _ path =
222   if Sys.file_exists (path ^ gz_suffix) then Sys.remove (path ^ gz_suffix);
223   if Sys.file_exists path then Sys.remove path
224
225 let remove_http _ _ =
226   prerr_endline "Http_getter_storage.remove: not implemented for HTTP scheme";
227   assert false
228
229 (**************************** RESOLUTION OF PREFIXES ************************)
230   
231 let resolve_prefixes n local write exists uri =
232   let exists_test new_uri =
233     if is_file_schema new_uri then 
234       exists_file () (path_of_file_url new_uri)
235     else if is_http_schema new_uri then
236       exists_http ~local () new_uri
237     else false
238   in
239   let rec aux n = function
240     | (rex, _, url_prefix, attrs) :: tl when n > 0->
241         (match write, is_readwrite attrs, exists with
242         | true ,false, _ -> aux n tl
243         | true ,true ,true  
244         | false,_ ,true ->
245             let new_uri = (Pcre.replace_first ~rex ~templ:url_prefix uri) in
246             if exists_test new_uri then new_uri::aux (n-1) tl else aux n tl
247         | true ,true ,false
248         | false,_ ,false -> 
249             (Pcre.replace_first ~rex ~templ:url_prefix uri) :: (aux (n-1) tl))
250     | _ -> []
251   in
252   aux n (lookup uri)
253
254 let resolve_prefix l w e u =
255   match resolve_prefixes 1 l w e u with
256   | hd :: _ -> hd
257   | [] -> 
258       raise 
259         (Resource_not_found 
260           (Printf.sprintf "resolve_prefix write:%b exists:%b" w e,u))
261   
262 (* uncomment to debug prefix resolution *)
263 (*
264 let resolve_prefix w e u =
265   prerr_endline 
266     ("XXX w=" ^ string_of_bool w ^ " e=" ^ string_of_bool e ^" :" ^ u);
267   let rc = resolve_prefix w e u in
268   prerr_endline ("YYY :" ^ rc ^ "\n");
269   rc 
270 *)
271
272 (************************* DISPATCHERS ***************************************)
273
274 type 'a storage_method = {
275   name: string;
276   write: bool;
277   exists: bool;
278   local: bool;
279   file: string -> string -> 'a; (* unresolved uri, resolved uri *)
280   http: string -> string -> 'a; (* unresolved uri, resolved uri *)
281 }
282
283 let invoke_method storage_method uri url =
284   try
285     if is_file_schema url then 
286       storage_method.file uri (path_of_file_url url)
287     else if is_http_schema url then
288       storage_method.http uri url
289     else
290       raise (Unsupported_scheme url)
291   with Not_found' -> raise (Resource_not_found (storage_method.name, uri))
292   
293 let dispatch_single storage_method uri =
294   assert (extension uri <> gz_suffix);
295   let uri = normalize_root uri in
296   let url = 
297     resolve_prefix 
298       storage_method.local storage_method.write storage_method.exists uri 
299   in
300   invoke_method storage_method uri url
301
302 let dispatch_multi storage_method uri =
303   let urls = 
304     resolve_prefixes max_int
305       storage_method.local storage_method.write storage_method.exists uri 
306   in
307   let rec aux = function
308     | [] -> raise (Resource_not_found (storage_method.name, uri))
309     | url :: tl ->
310         (try
311           invoke_method storage_method uri url
312         with Resource_not_found _ -> aux tl)
313   in
314   aux urls
315
316 let dispatch_all storage_method uri =
317   let urls = 
318     resolve_prefixes max_int
319       storage_method.local storage_method.write storage_method.exists uri 
320   in
321   List.map (fun url -> invoke_method storage_method uri url) urls
322  
323 (******************************** EXPORTED FUNCTIONS *************************)
324   
325 let exists ~local s =
326   try 
327     dispatch_single 
328     { write = false; 
329       name = "exists"; 
330       exists = true;
331       local=local;
332       file = exists_file; http = exists_http ~local; } s
333   with Resource_not_found _ -> false
334
335 let resolve ~local ?(must_exists=true) ~writable =
336   (if must_exists then
337     dispatch_multi
338   else
339     dispatch_single)
340     { write = writable;
341       name="resolve"; 
342       exists = must_exists;
343       local=local;
344       file = resolve_file ~must_exists; 
345       http = resolve_http ~local ~must_exists; }
346
347 let remove =
348   dispatch_single 
349     { write = false;
350       name = "remove"; 
351       exists=true;
352       local=false;
353       file = remove_file; http = remove_http; }
354
355 let filename ~local ?(find = false) =
356   (if find then dispatch_multi else dispatch_single)
357     { write = false;
358       name = "filename"; 
359       exists=true;
360       local=local;
361       file = get_file; http = get_http ~local ; }
362
363 let ls ~local uri_prefix =
364   let ls_all s =
365     try 
366       dispatch_all 
367         { write=false;
368           name = "ls"; 
369           exists=true;
370           local=local;
371           file = ls_file_single; http = ls_http_single ~local; } s
372     with Resource_not_found _ -> []
373   in 
374   let direct_results = List.flatten (ls_all uri_prefix) in
375   List.fold_left
376     (fun results (_, uri_prefix', _, _) ->
377       if Filename.dirname uri_prefix' = strip_trailing_slash uri_prefix then
378         (Filename.basename uri_prefix' ^ "/") :: results
379       else
380         results)
381     direct_results
382     (Lazy.force (prefix_map ()))
383
384 let clean_cache () =
385   ignore (Sys.command
386     (sprintf "rm -rf %s/" (Lazy.force Http_getter_env.cache_dir)))
387  
388 let list_writable_prefixes _ =
389   HExtlib.filter_map 
390     (fun (_,_,url,attrs) -> 
391       if is_readwrite attrs then 
392         Some url 
393       else 
394         None) 
395     (Lazy.force (prefix_map ()))
396
397 let is_legacy uri = List.for_all has_legacy (get_attrs uri) 
398
399 (* implement this in a fast way! *)
400 let is_empty ~local buri =
401   let buri = strip_trailing_slash buri ^ "/" in
402   let files = ls ~local buri in
403   is_empty_listing files
404
405 let is_read_only uri = 
406   let is_empty_dir path =
407     let files = 
408       try
409         if is_file_schema path then 
410           ls_file_single () (path_of_file_url path)
411         else if is_http_schema path then
412           ls_http_single ~local:false () path
413         else 
414           assert false
415       with Resource_not_found _ -> []
416     in
417     is_empty_listing files
418   in
419   let rec aux found_writable = function
420     | (rex, _, url_prefix, attrs)::tl -> 
421         let new_url = (Pcre.replace_first ~rex ~templ:url_prefix uri) in
422         let rdonly = has_legacy attrs || has_rdonly attrs in
423         (match rdonly, is_empty_dir new_url, found_writable with
424         | true, false, _ -> true
425         | true, true, _ -> aux found_writable tl
426         | false, _, _ -> aux true tl)
427     | [] -> not found_writable (* if found_writable then false else true *)
428   in 
429   aux false (lookup uri)
430
431 let activate_system_mode () =
432   let map = Lazy.force (prefix_map ()) in
433   let map = 
434     HExtlib.filter_map 
435       (fun ((rex, urip, urlp, attrs) as entry) -> 
436          if has_legacy attrs then
437            Some entry
438          else if has_rdonly attrs then
439            Some (rex, urip, urlp, List.filter ((<>) `Read_only) attrs)
440          else
441            None) 
442       map
443   in
444   let map = map in (* just to remember that ocamlc 'lazy' is a ... *)
445   prefix_map_ref := (lazy map)
446
447 (* eof *)