X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fgetter%2Fhttp_getter_storage.ml;h=fc6f415ac31ce68c0897113c0db026e018e6bb40;hb=ef3f78973c2fa3151c09681bcdb60107cd73c518;hp=01a5a521ecc11529f4a071563e4435c1b7cacc22;hpb=33b0056f5db298388df8fd66b72cd46e5839bf23;p=helm.git diff --git a/helm/ocaml/getter/http_getter_storage.ml b/helm/ocaml/getter/http_getter_storage.ml index 01a5a521e..fc6f415ac 100644 --- a/helm/ocaml/getter/http_getter_storage.ml +++ b/helm/ocaml/getter/http_getter_storage.ml @@ -23,6 +23,8 @@ * http://helm.cs.unibo.it/ *) +(* $Id$ *) + open Printf open Http_getter_misc @@ -43,6 +45,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); @@ -56,27 +59,49 @@ 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 = lookup uri in + List.map + (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 @@ -95,8 +120,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 +202,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 +218,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 @@ -215,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