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 ]
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
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
(**************************** 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
name: string;
write: bool;
exists: bool;
+ local: bool;
file: string -> string -> 'a; (* unresolved uri, resolved uri *)
http: string -> string -> 'a; (* unresolved uri, resolved uri *)
}
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 ->
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
{ 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
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
projects / helm.git / blobdiff