added support for repository attributes

[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 9d1378caaad8b3c98881c25cd13f773b02f548fc..fc6f415ac31ce68c0897113c0db026e018e6bb40 100644 (file)
--- a/helm/ocaml/getter/http_getter_storage.ml
+++ b/helm/ocaml/getter/http_getter_storage.ml
@@ -59,38 +59,50 @@ 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 =
-    List.filter (fun (rex, _, _) -> Pcre.pmatch ~rex uri)
-      (Lazy.force prefix_map)
-  in
-  if matches = [] then raise (Unresolvable_URI uri);
+  let matches = lookup uri in
   List.map
-    (fun (rex, _, url_prefix) -> Pcre.replace_first ~rex ~templ:url_prefix uri)
+    (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
 
@@ -249,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