helm/software/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 *)