New reduction strategy (that behaves much better during simplification).

[helm.git] / helm / ocaml / getter / http_getter_storage.ml

diff --git a/helm/ocaml/getter/http_getter_storage.ml b/helm/ocaml/getter/http_getter_storage.ml
index 01a5a521ecc11529f4a071563e4435c1b7cacc22..fc6f415ac31ce68c0897113c0db026e018e6bb40 100644 (file)
--- a/helm/ocaml/getter/http_getter_storage.ml
+++ b/helm/ocaml/getter/http_getter_storage.ml
@@ -23,6 +23,8 @@
  * http://helm.cs.unibo.it/
  *)
 
+(* $Id$ *)
+
 open Printf
 
 open Http_getter_misc
@@ -43,6 +45,7 @@ let http_scheme_RE = Pcre.regexp "^http://"
 let newline_RE = Pcre.regexp "\\n"
 let cic_scheme_sep_RE = Pcre.regexp ":/"
 let gz_suffix = ".gz"
+let gz_suffix_len = String.length gz_suffix
 
 let path_of_file_url url =
   assert (Pcre.pmatch ~rex:file_scheme_RE url);
@@ -56,27 +59,49 @@ let path_of_file_url url =
 let prefix_map = lazy (
   let map_w_length =
     List.map
-      (fun (uri_prefix, url_prefix) ->
+      (fun (uri_prefix, (url_prefix, attrs)) ->
         let uri_prefix = normalize_dir uri_prefix in
         let url_prefix = normalize_dir url_prefix in
         let regexp = Pcre.regexp ("^(" ^ Pcre.quote uri_prefix ^ ")") in
-        (regexp, String.length uri_prefix, uri_prefix, url_prefix))
+        (regexp, String.length uri_prefix, uri_prefix, url_prefix, attrs))
       (Lazy.force Http_getter_env.prefixes)
   in
-  let decreasing_length (_, len1, _, _) (_, len2, _, _) = compare len2 len1 in
+  let decreasing_length (_, len1, _, _, _) (_, len2, _, _, _) =
+    compare len2 len1 in
   List.map
-    (fun (regexp, len, uri_prefix, url_prefix) ->
-      (regexp, strip_trailing_slash uri_prefix, url_prefix))
+    (fun (regexp, len, uri_prefix, url_prefix, attrs) ->
+      (regexp, strip_trailing_slash uri_prefix, url_prefix, attrs))
     (List.fast_sort decreasing_length map_w_length))
 
-let resolve_prefix uri =
+let lookup uri =
   let matches =
-    List.filter (fun (rex, _, _) -> Pcre.pmatch ~rex uri)
-      (Lazy.force prefix_map)
-  in
-  match matches with
-  | (rex, _, url_prefix) :: _ -> Pcre.replace_first ~rex ~templ:url_prefix uri
-  | [] -> raise (Unresolvable_URI uri)
+    List.filter (fun (rex, _, _, _) -> Pcre.pmatch ~rex uri)
+      (Lazy.force prefix_map) in
+  if matches = [] then raise (Unresolvable_URI uri);
+  matches
+
+let resolve_prefix uri =
+  match lookup uri with
+  | (rex, _, url_prefix, _) :: _ ->
+      Pcre.replace_first ~rex ~templ:url_prefix uri
+  | [] -> assert false
+
+let resolve_prefixes uri =
+  let matches = lookup uri in
+  List.map
+    (fun (rex, _, url_prefix, _) ->
+      Pcre.replace_first ~rex ~templ:url_prefix uri)
+    matches
+
+let get_attrs uri =
+  match lookup uri with
+  | (_, _, _, attrs) :: _ -> attrs
+  | [] -> assert false
+
+let is_legacy uri = List.exists ((=) `Legacy) (get_attrs uri)
+
+let is_read_only uri =
+  is_legacy uri || List.exists ((=) `Read_only) (get_attrs uri)
 
 let exists_http _ url =
   Http_getter_wget.exists (url ^ gz_suffix) || Http_getter_wget.exists url
@@ -95,8 +120,8 @@ let resolve_file _ fname =
   with Not_found -> raise Not_found'
 
 let strip_gz_suffix fname =
-  if extension fname = ".gz" then
-    String.sub fname 0 (String.length fname - 3)
+  if extension fname = gz_suffix then
+    String.sub fname 0 (String.length fname - gz_suffix_len)
   else
     fname
 
@@ -177,15 +202,13 @@ type 'a storage_method = {
   http: string -> string -> 'a; (* unresolved uri, resolved uri *)
 }
 
-let dispatch storage_method uri =
-  assert (extension uri <> ".gz");
-  let uri = (* add trailing slash to roots *)
-    try
-      if uri.[String.length uri - 1] = ':' then uri ^ "/"
-      else uri
-    with Invalid_argument _ -> uri
-  in
-  let url = resolve_prefix uri in
+let normalize_root uri =  (* add trailing slash to roots *)
+  try
+    if uri.[String.length uri - 1] = ':' then uri ^ "/"
+    else uri
+  with Invalid_argument _ -> uri
+
+let invoke_method storage_method uri url =
   try
     if Pcre.pmatch ~rex:file_scheme_RE url then
       storage_method.file uri (path_of_file_url url)
@@ -195,17 +218,40 @@ let dispatch storage_method uri =
       raise (Unsupported_scheme url)
   with Not_found' -> raise (Resource_not_found (storage_method.name, uri))
 
+let dispatch_single storage_method uri =
+  assert (extension uri <> gz_suffix);
+  let uri = normalize_root uri in
+  let url = resolve_prefix uri in
+  invoke_method storage_method uri url
+
+let dispatch_multi storage_method uri =
+  let urls = resolve_prefixes uri in
+  let rec aux = function
+    | [] -> raise (Resource_not_found (storage_method.name, uri))
+    | url :: tl ->
+        (try
+          invoke_method storage_method uri url
+        with Resource_not_found _ -> aux tl)
+  in
+  aux urls
+
 let exists =
-  dispatch { name = "exists"; file = exists_file; http = exists_http }
+  dispatch_single { name = "exists"; file = exists_file; http = exists_http }
+
 let resolve =
-  dispatch { name = "resolve"; file = resolve_file; http = resolve_http }
+  dispatch_single { name = "resolve"; file = resolve_file; http = resolve_http }
+
 let ls_single =
-  dispatch { name = "ls"; file = ls_file_single; http = ls_http_single }
-let get = dispatch { name = "get"; file = get_file; http = get_http }
+  dispatch_single { name = "ls"; file = ls_file_single; http = ls_http_single }
+
 let remove =
-  dispatch { name = "remove"; file = remove_file; http = remove_http }
+  dispatch_single { name = "remove"; file = remove_file; http = remove_http }
 
-let filename = get
+let filename ?(find = false) =
+  if find then
+    dispatch_multi { name = "filename"; file = get_file; http = get_http }
+  else
+    dispatch_single { name = "filename"; file = get_file; http = get_http }
 
   (* ls_single performs ls only below a single prefix, but prefixes which have
    * common prefix (sorry) with a given one may need to be considered as well
@@ -215,7 +261,7 @@ let ls uri_prefix =
 (*   prerr_endline ("Http_getter_storage.ls " ^ uri_prefix); *)
   let direct_results = ls_single uri_prefix in
   List.fold_left
-    (fun results (_, uri_prefix', _) ->
+    (fun results (_, uri_prefix', _, _) ->
       if Filename.dirname uri_prefix' = strip_trailing_slash uri_prefix then
         (Filename.basename uri_prefix' ^ "/") :: results
       else