X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=components%2Fgetter%2Fhttp_getter_storage.ml;h=c17435f6a25a4f5f7848fc9dcc2435a3e36d2911;hb=42f2dc48b4fef5b404f406bf512d6a0cde35c067;hp=77bfe138da3450d9a484fdf2a6e8681b591d7e83;hpb=726f5e6ae2b5d7c7699bd9253936ad46558e6f38;p=helm.git

diff --git a/components/getter/http_getter_storage.ml b/components/getter/http_getter_storage.ml
index 77bfe138d..c17435f6a 100644
--- a/components/getter/http_getter_storage.ml
+++ b/components/getter/http_getter_storage.ml
@@ -100,25 +100,45 @@ let prefix_map_ref = ref (lazy (
 
 let prefix_map () = !prefix_map_ref
 
+let keep_first l = 
+  let cmp (_,x) (_,y) = x = y in
+  let rec aux prev = function
+    | [] -> []
+    | hd::tl -> if cmp prev hd then hd :: aux prev tl else []
+  in
+  match l with
+  | hd :: tl -> hd :: aux hd tl
+  | _ -> assert false
+;;
+
   (** given an uri returns the prefixes for it *)
 let lookup uri =
   let matches =
-    List.filter (fun (rex, _, l, _) -> Pcre.pmatch ~rex uri)
-      (Lazy.force (prefix_map ())) in
+    HExtlib.filter_map 
+      (fun (rex, _, l, _ as entry) -> 
+         try
+           let got = Pcre.extract ~full_match:true ~rex uri in
+           Some (entry, String.length got.(0))
+         with Not_found -> None)
+      (Lazy.force (prefix_map ())) 
+  in
   if matches = [] then raise (Unresolvable_URI uri);
-  matches
+  List.map fst (keep_first (List.sort (fun (_,l1) (_,l2) -> l2 - l1) matches))
+;;
 
 let get_attrs uri = List.map (fun (_, _, _, attrs) -> attrs) (lookup uri)
 
 (*************************** ACTIONS ******************************************)
   
-let exists_http _ url =
+let exists_http ~local _ url =
+  if local then false else
   Http_getter_wget.exists (url ^ gz_suffix) || Http_getter_wget.exists url
 
 let exists_file _ fname =
   Sys.file_exists (fname ^ gz_suffix) || Sys.file_exists fname
 
-let resolve_http ~must_exists _ url =
+let resolve_http ~must_exists ~local _ url =
+  if local then raise Not_found' else
   try
     if must_exists then
       List.find Http_getter_wget.exists [ url ^ gz_suffix; url ]
@@ -154,11 +174,14 @@ let ls_file_single _ path_prefix =
     remove_duplicates !entries
   with Unix.Unix_error (_, "opendir", _) -> []
 
-let ls_http_single _ url_prefix =
+let ls_http_single ~local _ url_prefix =
+  if local then raise (Resource_not_found ("get","")) else
+  let url = normalize_dir url_prefix ^ index_fname in
   try
-    let index = Http_getter_wget.get (normalize_dir url_prefix ^ index_fname) in
+    let index = Http_getter_wget.get url in
     Pcre.split ~rex:newline_RE index
-  with Http_client_error _ -> raise Not_found'
+  with Http_client_error _ -> raise (Resource_not_found ("get",url))
+;;
 
 let get_file _ path =
   if Sys.file_exists (path ^ gz_suffix) then
@@ -168,7 +191,8 @@ let get_file _ path =
   else
     raise Not_found'
 
-let get_http uri url =
+let get_http ~local uri url =
+  if local then raise Not_found' else
   let scheme, path =
     match Pcre.split ~rex:cic_scheme_sep_RE uri with
     | [scheme; path] -> scheme, path
@@ -204,31 +228,31 @@ let remove_http _ _ =
 
 (**************************** RESOLUTION OF PREFIXES ************************)
   
-let resolve_prefixes write exists uri =
+let resolve_prefixes n local write exists uri =
   let exists_test new_uri =
     if is_file_schema new_uri then 
       exists_file () (path_of_file_url new_uri)
     else if is_http_schema new_uri then
-      exists_http () new_uri
+      exists_http ~local () new_uri
     else false
   in
-  let rec aux = function
-    | (rex, _, url_prefix, attrs) :: tl ->
+  let rec aux n = function
+    | (rex, _, url_prefix, attrs) :: tl when n > 0->
         (match write, is_readwrite attrs, exists with
-        | true ,false, _ -> aux tl
+        | true ,false, _ -> aux n tl
         | true ,true ,true  
         | false,_ ,true ->
             let new_uri = (Pcre.replace_first ~rex ~templ:url_prefix uri) in
-            if exists_test new_uri then new_uri::aux tl else aux tl
+            if exists_test new_uri then new_uri::aux (n-1) tl else aux n tl
         | true ,true ,false
         | false,_ ,false -> 
-            (Pcre.replace_first ~rex ~templ:url_prefix uri) :: (aux tl))
-    | [] -> []
+            (Pcre.replace_first ~rex ~templ:url_prefix uri) :: (aux (n-1) tl))
+    | _ -> []
   in
-  aux (lookup uri)
+  aux n (lookup uri)
 
-let resolve_prefix w e u =
-  match resolve_prefixes w e u with
+let resolve_prefix l w e u =
+  match resolve_prefixes 1 l w e u with
   | hd :: _ -> hd
   | [] -> 
       raise 
@@ -251,6 +275,7 @@ type 'a storage_method = {
   name: string;
   write: bool;
   exists: bool;
+  local: bool;
   file: string -> string -> 'a; (* unresolved uri, resolved uri *)
   http: string -> string -> 'a; (* unresolved uri, resolved uri *)
 }
@@ -268,11 +293,17 @@ let invoke_method storage_method uri url =
 let dispatch_single storage_method uri =
   assert (extension uri <> gz_suffix);
   let uri = normalize_root uri in
-  let url = resolve_prefix storage_method.write storage_method.exists uri in
+  let url = 
+    resolve_prefix 
+      storage_method.local storage_method.write storage_method.exists uri 
+  in
   invoke_method storage_method uri url
 
 let dispatch_multi storage_method uri =
-  let urls = resolve_prefixes storage_method.write storage_method.exists uri in
+  let urls = 
+    resolve_prefixes max_int
+      storage_method.local storage_method.write storage_method.exists uri 
+  in
   let rec aux = function
     | [] -> raise (Resource_not_found (storage_method.name, uri))
     | url :: tl ->
@@ -283,21 +314,25 @@ let dispatch_multi storage_method uri =
   aux urls
 
 let dispatch_all storage_method uri =
-  let urls = resolve_prefixes storage_method.write storage_method.exists uri in
+  let urls = 
+    resolve_prefixes max_int
+      storage_method.local storage_method.write storage_method.exists uri 
+  in
   List.map (fun url -> invoke_method storage_method uri url) urls
  
 (******************************** EXPORTED FUNCTIONS *************************)
   
-let exists s =
+let exists ~local s =
   try 
     dispatch_single 
     { write = false; 
       name = "exists"; 
       exists = true;
-      file = exists_file; http = exists_http; } s
+      local=local;
+      file = exists_file; http = exists_http ~local; } s
   with Resource_not_found _ -> false
 
-let resolve ?(must_exists=true) ~writable =
+let resolve ~local ?(must_exists=true) ~writable =
   (if must_exists then
     dispatch_multi
   else
@@ -305,31 +340,35 @@ let resolve ?(must_exists=true) ~writable =
     { write = writable;
       name="resolve"; 
       exists = must_exists;
+      local=local;
       file = resolve_file ~must_exists; 
-      http = resolve_http ~must_exists; }
+      http = resolve_http ~local ~must_exists; }
 
 let remove =
   dispatch_single 
     { write = false;
       name = "remove"; 
       exists=true;
+      local=false;
       file = remove_file; http = remove_http; }
 
-let filename ?(find = false) =
+let filename ~local ?(find = false) =
   (if find then dispatch_multi else dispatch_single)
     { write = false;
       name = "filename"; 
       exists=true;
-      file = get_file; http = get_http; }
+      local=local;
+      file = get_file; http = get_http ~local ; }
 
-let ls uri_prefix =
+let ls ~local uri_prefix =
   let ls_all s =
     try 
       dispatch_all 
         { write=false;
           name = "ls"; 
           exists=true;
-          file = ls_file_single; http = ls_http_single; } s
+          local=local;
+          file = ls_file_single; http = ls_http_single ~local; } s
     with Resource_not_found _ -> []
   in 
   let direct_results = List.flatten (ls_all uri_prefix) in
@@ -355,23 +394,25 @@ let list_writable_prefixes _ =
         None) 
     (Lazy.force (prefix_map ()))
 
-let is_legacy uri = List.for_all has_legacy (get_attrs uri)
+let is_legacy uri = List.for_all has_legacy (get_attrs uri) 
 
 (* implement this in a fast way! *)
-let is_empty buri =
+let is_empty ~local buri =
   let buri = strip_trailing_slash buri ^ "/" in
-  let files = ls buri in
+  let files = ls ~local buri in
   is_empty_listing files
 
 let is_read_only uri = 
   let is_empty_dir path =
     let files = 
-      if is_file_schema path then 
-        ls_file_single () (path_of_file_url path)
-      else if is_http_schema path then
-        ls_http_single () path
-      else 
-        assert false
+      try
+        if is_file_schema path then 
+          ls_file_single () (path_of_file_url path)
+        else if is_http_schema path then
+          ls_http_single ~local:false () path
+        else 
+          assert false
+      with Resource_not_found _ -> []
     in
     is_empty_listing files
   in