X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fgetter%2Fhttp_getter_storage.ml;h=3418956ea4807ffed0c49615f4e275653b8503c1;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=8266c96112118cf769a13adc8d0d072b8b446e28;hpb=a3fb06e72407e3590fa60a74ac5fec01e6bfe1f9;p=helm.git

diff --git a/helm/ocaml/getter/http_getter_storage.ml b/helm/ocaml/getter/http_getter_storage.ml
index 8266c9611..3418956ea 100644
--- a/helm/ocaml/getter/http_getter_storage.ml
+++ b/helm/ocaml/getter/http_getter_storage.ml
@@ -29,7 +29,7 @@ open Http_getter_misc
 open Http_getter_types
 
 exception Not_found'
-exception Resource_not_found of string  (** uri *)
+exception Resource_not_found of string * string  (** method, uri *)
 
 let index_fname = "INDEX"
 
@@ -43,6 +43,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);
@@ -78,6 +79,16 @@ let resolve_prefix uri =
   | (rex, _, url_prefix) :: _ -> Pcre.replace_first ~rex ~templ:url_prefix uri
   | [] -> raise (Unresolvable_URI uri)
 
+let resolve_prefixes uri =
+  let matches =
+    List.filter (fun (rex, _, _) -> Pcre.pmatch ~rex uri)
+      (Lazy.force prefix_map)
+  in
+  if matches = [] then raise (Unresolvable_URI uri);
+  List.map
+    (fun (rex, _, url_prefix) -> Pcre.replace_first ~rex ~templ:url_prefix uri)
+    matches
+
 let exists_http _ url =
   Http_getter_wget.exists (url ^ gz_suffix) || Http_getter_wget.exists url
 
@@ -95,8 +106,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
 
@@ -124,8 +135,10 @@ let ls_file_single _ path_prefix =
   with Unix.Unix_error (_, "opendir", _) -> []
 
 let ls_http_single _ url_prefix =
-  let index = Http_getter_wget.get (normalize_dir url_prefix ^ index_fname) in
-  Pcre.split ~rex:newline_RE index
+  try
+    let index = Http_getter_wget.get (normalize_dir url_prefix ^ index_fname) in
+    Pcre.split ~rex:newline_RE index
+  with Http_client_error _ -> raise Not_found'
 
 let get_file _ path =
   if Sys.file_exists (path ^ gz_suffix) then
@@ -141,20 +154,25 @@ let get_http uri url =
     | [scheme; path] -> scheme, path
     | _ -> assert false
   in
-  let cache_dest =
+  let cache_name =
     sprintf "%s%s/%s" (Lazy.force Http_getter_env.cache_dir) scheme path
   in
-  if not (Sys.file_exists cache_dest) then begin  (* fill cache *)
-    Http_getter_misc.mkdir ~parents:true (Filename.dirname cache_dest);
+  if Sys.file_exists (cache_name ^ gz_suffix) then
+    cache_name ^ gz_suffix
+  else if Sys.file_exists cache_name then
+    cache_name
+  else begin  (* fill cache *)
+    Http_getter_misc.mkdir ~parents:true (Filename.dirname cache_name);
     (try
-      Http_getter_wget.get_and_save (url ^ gz_suffix) (cache_dest ^ gz_suffix)
-    with Http_user_agent.Http_error _ ->
+      Http_getter_wget.get_and_save (url ^ gz_suffix) (cache_name ^ gz_suffix);
+      cache_name ^ gz_suffix
+    with Http_client_error _ ->
       (try
-        Http_getter_wget.get_and_save url cache_dest
-      with Http_user_agent.Http_error _ ->
+        Http_getter_wget.get_and_save url cache_name;
+        cache_name
+      with Http_client_error _ ->
         raise Not_found'))
-  end;
-  cache_dest
+  end
 
 let remove_file _ path =
   if Sys.file_exists (path ^ gz_suffix) then Sys.remove (path ^ gz_suffix);
@@ -170,15 +188,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)
@@ -186,25 +202,49 @@ let dispatch storage_method uri =
       storage_method.http uri url
     else
       raise (Unsupported_scheme url)
-  with Not_found' -> raise (Resource_not_found uri)
+  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
    * for example: when doing "ls cic:/" we would like to see the "cic:/matita"
    * directory *)
 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', _) ->