ocaml 3.09 transition

[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..3418956ea4807ffed0c49615f4e275653b8503c1 100644 (file)
--- a/helm/ocaml/getter/http_getter_storage.ml
+++ b/helm/ocaml/getter/http_getter_storage.ml
@@ -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
 
@@ -177,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)
@@ -195,17 +204,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