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 (fun s -> s.[String.length s - 1] = '/') files
  84
  85 (************************* GLOBALS PREFIXES **********************************)
  86
  87   (** associative list regular expressions -> url prefixes
  88    * sorted with longest prefixes first *)
  89 let prefix_map_ref = ref (lazy (
  90   List.map
  91     (fun (uri_prefix, (url_prefix, attrs)) ->
  92       let uri_prefix = normalize_dir uri_prefix in
  93       let url_prefix = normalize_dir url_prefix in
  94       let regexp = Pcre.regexp ("^(" ^ Pcre.quote uri_prefix ^ ")") in
  95       regexp, strip_trailing_slash uri_prefix, url_prefix, attrs)
  96     (List.rev (Lazy.force Http_getter_env.prefixes))))
  97
  98 let prefix_map () = !prefix_map_ref
  99
 100   (** given an uri returns the prefixes for it *)
 101 let lookup uri =
 102   let matches =
 103     List.filter (fun (rex, _, l, _) -> Pcre.pmatch ~rex uri)
 104       (Lazy.force (prefix_map ())) in
 105   if matches = [] then raise (Unresolvable_URI uri);
 106   matches
 107
 108 let get_attrs uri = List.map (fun (_, _, _, attrs) -> attrs) (lookup uri)
 109
 110 (*************************** ACTIONS ******************************************)
 111
 112 let exists_http _ url =
 113   Http_getter_wget.exists (url ^ gz_suffix) || Http_getter_wget.exists url
 114
 115 let exists_file _ fname =
 116   Sys.file_exists (fname ^ gz_suffix) || Sys.file_exists fname
 117
 118 let resolve_http ~must_exists _ url =
 119   try
 120     if must_exists then
 121       List.find Http_getter_wget.exists [ url ^ gz_suffix; url ]
 122     else
 123       url
 124   with Not_found -> raise Not_found'
 125
 126 let resolve_file ~must_exists _ fname =
 127   try
 128     if must_exists then
 129       List.find Sys.file_exists [ fname ^ gz_suffix; fname ]
 130     else
 131       fname
 132   with Not_found -> raise Not_found'
 133
 134 let ls_file_single _ path_prefix =
 135   let is_dir fname = (Unix.stat fname).Unix.st_kind = Unix.S_DIR in
 136   let is_useless dir = try dir.[0] = '.' with _ -> false in
 137   let entries = ref [] in
 138   try
 139     let dir_handle = Unix.opendir path_prefix in
 140     (try
 141       while true do
 142         let entry = Unix.readdir dir_handle in
 143         if is_useless entry then
 144           ()
 145         else if is_dir (path_prefix ^ "/" ^ entry) then
 146           entries := normalize_dir entry :: !entries
 147         else
 148           entries := strip_gz_suffix entry :: !entries
 149       done
 150     with End_of_file -> Unix.closedir dir_handle);
 151     remove_duplicates !entries
 152   with Unix.Unix_error (_, "opendir", _) -> []
 153
 154 let ls_http_single _ url_prefix =
 155   try
 156     let index = Http_getter_wget.get (normalize_dir url_prefix ^ index_fname) in
 157     Pcre.split ~rex:newline_RE index
 158   with Http_client_error _ -> raise Not_found'
 159
 160 let get_file _ path =
 161   if Sys.file_exists (path ^ gz_suffix) then
 162     path ^ gz_suffix
 163   else if Sys.file_exists path then
 164     path
 165   else
 166     raise Not_found'
 167
 168 let get_http uri url =
 169   let scheme, path =
 170     match Pcre.split ~rex:cic_scheme_sep_RE uri with
 171     | [scheme; path] -> scheme, path
 172     | _ -> assert false
 173   in
 174   let cache_name =
 175     sprintf "%s%s/%s" (Lazy.force Http_getter_env.cache_dir) scheme path
 176   in
 177   if Sys.file_exists (cache_name ^ gz_suffix) then
 178     cache_name ^ gz_suffix
 179   else if Sys.file_exists cache_name then
 180     cache_name
 181   else begin  (* fill cache *)
 182     Http_getter_misc.mkdir ~parents:true (Filename.dirname cache_name);
 183     (try
 184       Http_getter_wget.get_and_save (url ^ gz_suffix) (cache_name ^ gz_suffix);
 185       cache_name ^ gz_suffix
 186     with Http_client_error _ ->
 187       (try
 188         Http_getter_wget.get_and_save url cache_name;
 189         cache_name
 190       with Http_client_error _ ->
 191         raise Not_found'))
 192   end
 193
 194 let remove_file _ path =
 195   if Sys.file_exists (path ^ gz_suffix) then Sys.remove (path ^ gz_suffix);
 196   if Sys.file_exists path then Sys.remove path
 197
 198 let remove_http _ _ =
 199   prerr_endline "Http_getter_storage.remove: not implemented for HTTP scheme";
 200   assert false
 201
 202 (**************************** RESOLUTION OF PREFIXES ************************)
 203
 204 let resolve_prefixes write exists uri =
 205   let exists_test new_uri =
 206     if is_file_schema new_uri then
 207       exists_file () (path_of_file_url new_uri)
 208     else if is_http_schema new_uri then
 209       exists_http () new_uri
 210     else false
 211   in
 212   let rec aux = function
 213     | (rex, _, url_prefix, attrs) :: tl ->
 214         (match write, is_readwrite attrs, exists with
 215         | true ,false, _ -> aux tl
 216         | true ,true ,true
 217         | false,_ ,true ->
 218             let new_uri = (Pcre.replace_first ~rex ~templ:url_prefix uri) in
 219             if exists_test new_uri then new_uri::aux tl else aux tl
 220         | true ,true ,false
 221         | false,_ ,false ->
 222             (Pcre.replace_first ~rex ~templ:url_prefix uri) :: (aux tl))
 223     | [] -> []
 224   in
 225   aux (lookup uri)
 226
 227 let resolve_prefix w e u =
 228   match resolve_prefixes w e u with
 229   | hd :: _ -> hd
 230   | [] ->
 231       raise
 232         (Resource_not_found
 233           (Printf.sprintf "resolve_prefix write:%b exists:%b" w e,u))
 234
 235 (* uncomment to debug prefix resolution *)
 236 (*
 237 let resolve_prefix w e u =
 238   prerr_endline
 239     ("XXX w=" ^ string_of_bool w ^ " e=" ^ string_of_bool e ^" :" ^ u);
 240   let rc = resolve_prefix w e u in
 241   prerr_endline ("YYY :" ^ rc ^ "\n");
 242   rc
 243 *)
 244
 245 (************************* DISPATCHERS ***************************************)
 246
 247 type 'a storage_method = {
 248   name: string;
 249   write: bool;
 250   exists: bool;
 251   file: string -> string -> 'a; (* unresolved uri, resolved uri *)
 252   http: string -> string -> 'a; (* unresolved uri, resolved uri *)
 253 }
 254
 255 let invoke_method storage_method uri url =
 256   try
 257     if is_file_schema url then
 258       storage_method.file uri (path_of_file_url url)
 259     else if is_http_schema url then
 260       storage_method.http uri url
 261     else
 262       raise (Unsupported_scheme url)
 263   with Not_found' -> raise (Resource_not_found (storage_method.name, uri))
 264
 265 let dispatch_single storage_method uri =
 266   assert (extension uri <> gz_suffix);
 267   let uri = normalize_root uri in
 268   let url = resolve_prefix storage_method.write storage_method.exists uri in
 269   invoke_method storage_method uri url
 270
 271 let dispatch_multi storage_method uri =
 272   let urls = resolve_prefixes storage_method.write storage_method.exists uri in
 273   let rec aux = function
 274     | [] -> raise (Resource_not_found (storage_method.name, uri))
 275     | url :: tl ->
 276         (try
 277           invoke_method storage_method uri url
 278         with Resource_not_found _ -> aux tl)
 279   in
 280   aux urls
 281
 282 let dispatch_all storage_method uri =
 283   let urls = resolve_prefixes storage_method.write storage_method.exists uri in
 284   List.map (fun url -> invoke_method storage_method uri url) urls
 285
 286 (******************************** EXPORTED FUNCTIONS *************************)
 287
 288 let exists s =
 289   try
 290     dispatch_single
 291     { write = false;
 292       name = "exists";
 293       exists = true;
 294       file = exists_file; http = exists_http; } s
 295   with Resource_not_found _ -> false
 296
 297 let resolve ?(must_exists=true) ~writable =
 298   dispatch_single
 299     { write = writable;
 300       name="resolve";
 301       exists = must_exists;
 302       file = resolve_file ~must_exists;
 303       http = resolve_http ~must_exists; }
 304
 305 let remove =
 306   dispatch_single
 307     { write = false;
 308       name = "remove";
 309       exists=true;
 310       file = remove_file; http = remove_http; }
 311
 312 let filename ?(find = false) =
 313   (if find then dispatch_multi else dispatch_single)
 314     { write = false;
 315       name = "filename";
 316       exists=true;
 317       file = get_file; http = get_http; }
 318
 319 let ls uri_prefix =
 320   let ls_all s =
 321     try
 322       dispatch_all
 323         { write=false;
 324           name = "ls";
 325           exists=true;
 326           file = ls_file_single; http = ls_http_single; } s
 327     with Resource_not_found _ -> []
 328   in
 329   let direct_results = List.flatten (ls_all uri_prefix) in
 330   List.fold_left
 331     (fun results (_, uri_prefix', _, _) ->
 332       if Filename.dirname uri_prefix' = strip_trailing_slash uri_prefix then
 333         (Filename.basename uri_prefix' ^ "/") :: results
 334       else
 335         results)
 336     direct_results
 337     (Lazy.force (prefix_map ()))
 338
 339 let clean_cache () =
 340   ignore (Sys.command
 341     (sprintf "rm -rf %s/" (Lazy.force Http_getter_env.cache_dir)))
 342
 343 let list_writable_prefixes _ =
 344   HExtlib.filter_map
 345     (fun (_,_,url,attrs) ->
 346       if is_readwrite attrs then
 347         Some url
 348       else
 349         None)
 350     (Lazy.force (prefix_map ()))
 351
 352 let is_legacy uri = List.for_all has_legacy (get_attrs uri)
 353
 354 (* implement this in a fast way! *)
 355 let is_empty buri =
 356   let buri = strip_trailing_slash buri ^ "/" in
 357   let files = ls buri in
 358   is_empty_listing files
 359
 360 let is_read_only uri =
 361   let is_empty_dir path =
 362     let files =
 363       if is_file_schema path then
 364         ls_file_single () (path_of_file_url path)
 365       else if is_http_schema path then
 366         ls_http_single () path
 367       else
 368         assert false
 369     in
 370     is_empty_listing files
 371   in
 372   let rec aux found_writable = function
 373     | (rex, _, url_prefix, attrs)::tl ->
 374         let new_url = (Pcre.replace_first ~rex ~templ:url_prefix uri) in
 375         let rdonly = has_legacy attrs || has_rdonly attrs in
 376         (match rdonly, is_empty_dir new_url, found_writable with
 377         | true, false, _ -> true
 378         | true, true, _ -> aux found_writable tl
 379         | false, _, _ -> aux true tl)
 380     | [] -> not found_writable (* if found_writable then false else true *)
 381   in
 382   aux false (lookup uri)
 383
 384 let activate_system_mode () =
 385   let map = Lazy.force (prefix_map ()) in
 386   let map =
 387     HExtlib.filter_map
 388       (fun ((rex, urip, urlp, attrs) as entry) ->
 389          if has_legacy attrs then
 390            Some entry
 391          else if has_rdonly attrs then
 392            Some (rex, urip, urlp, List.filter ((<>) `Read_only) attrs)
 393          else
 394            None)
 395       map
 396   in
 397   let map = map in (* just to remember that ocamlc 'lazy' is a ... *)
 398   prefix_map_ref := (lazy map)
 399
 400 (* eof *)