+++ /dev/null
-(* $Id$
- * ----------------------------------------------------------------------
- *
- *)
-
-exception Malformed_URL
-
-type url_syntax_option =
- Url_part_not_recognized
- | Url_part_allowed
- | Url_part_required
-
-
-type url_syntax =
- { url_enable_scheme : url_syntax_option;
- url_enable_user : url_syntax_option;
- url_enable_password : url_syntax_option;
- url_enable_host : url_syntax_option;
- url_enable_port : url_syntax_option;
- url_enable_path : url_syntax_option;
- url_enable_param : url_syntax_option;
- url_enable_query : url_syntax_option;
- url_enable_fragment : url_syntax_option;
- url_enable_other : url_syntax_option;
- url_accepts_8bits : bool;
- url_is_valid : url -> bool;
- }
-
-and url =
- {
- url_syntax : url_syntax;
- mutable url_validity : bool;
- url_scheme : string option;
- url_user : string option;
- url_password : string option;
- url_host : string option;
- url_port : int option;
- url_path : string list;
- url_param : string list;
- url_query : string option;
- url_fragment : string option;
- url_other : string option;
- }
-;;
-
-
-type char_category =
- Accepted
- | Rejected
- | Separator
-
-
-
-let scan_url_part s k_from k_to cats accept_8bits =
- (* Scans the longest word of accepted characters from position 'k_from'
- * in 's' until at most position 'k_to'. The character following the
- * word (if any) must be a separator character.
- * On success, the function returns the position of the last character
- * of the word + 1.
- * If there is any rejected character before the separator or the end
- * of the string (i.e. position 'k_to') is reached, the exception
- * Malformed_URL is raised.
- * Furthermore, if the character '%' is accepted it is checked whether
- * two hexadecimal digits follow (which must be accepted, too). If this
- * is not true, the exception Malformed_URL is raised, too.
- * 'cats': contains for every character code (0 to 255) the category
- * of the character.
- *)
- let check_hex c =
- if cats.( Char.code c ) <> Accepted then raise Malformed_URL;
- match c with
- ('0'..'9'|'A'..'F'|'a'..'f') -> ()
- | _ -> raise Malformed_URL
- in
-
- let rec scan k =
- if k >= k_to then
- k
- else begin
- let c = s.[k] in
- let cat = cats.(Char.code c) in
- match cat with
- Accepted ->
- if c = '%' then begin
- if k+2 >= k_to then raise Malformed_URL;
- let c1 = s.[k+1] in
- let c2 = s.[k+2] in
- check_hex c1;
- check_hex c2;
- scan (k+3)
- end
- else
- scan (k+1)
- | Separator -> k
- | Rejected ->
- if accept_8bits && c >= '\128'
- then scan (k+1)
- else raise Malformed_URL
- end
- in
-
- assert (Array.length cats = 256);
- assert (k_from >= 0);
- assert (k_from <= k_to);
- assert (k_to <= String.length s);
-
- scan k_from
-;;
-
-
-(* Create a categorization: *)
-
-let lalpha = [ 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; 'g'; 'h'; 'i'; 'j'; 'k'; 'l'; 'm';
- 'n'; 'o'; 'p'; 'q'; 'r'; 's'; 't'; 'u'; 'v'; 'w'; 'x'; 'y'; 'z' ]
-
-let ualpha = [ 'A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M';
- 'N'; 'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z' ]
-
-let digit = [ '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9' ]
-
-let safe = [ '$'; '-'; '_'; '.'; '+' ]
-
-let extra = [ '!'; '*'; '\''; '('; ')'; ',' ]
-
-let make_cats accepted separators =
- (* create a categorization:
- * - All characters listed in 'separators' are separators.
- * - All characters listed in 'accepted' and which do not occur in
- * 'separators' are accepted characters.
- * - All other characters are rejected.
- *)
- let cats = Array.make 256 Rejected in
- List.iter
- (fun c ->
- cats.(Char.code c) <- Accepted
- )
- accepted;
-
- List.iter
- (fun c ->
- cats.(Char.code c) <- Separator
- )
- separators;
- cats
-;;
-
-
-let scheme_cats =
- make_cats (lalpha @ ualpha @ ['+'; '-'; '.']) [':'] ;;
-
- (* scheme_cats: character categorization to _extract_ the URL scheme *)
-
-
-let login_cats =
- make_cats
- (lalpha @ ualpha @ digit @ safe @ extra @ [';'; '?'; '&'; '='; '%'])
- [':'; '@'; '/'; '#' ]
-;;
-
- (* login_cats: character categorization to _extract_ user name, password,
- * host name, and port.
- *)
-
-let host_cats =
- make_cats
- (lalpha @ ualpha @ digit @ ['.'; '-'])
- []
-;;
-
- (* host_cats: character categorization to _check_ whether the host name
- * is formed only by legal characters.
- * Especially '%' is not allowed here!
- *)
-
-let port_cats =
- make_cats
- digit
- []
-;;
-
- (* port_cats: character categorization to _check_ whether the port number
- * is formed only by legal characters.
- * Especially '%' is not allowed here!
- *)
-
-let path_cats separators =
- make_cats
- (lalpha @ ualpha @ digit @ safe @ extra @
- ['?'; ':'; '@'; '&'; '='; ';'; '%'; '/'; '~'])
- separators
-;;
-
-
-let separators_from_syntax syn =
- let include_if syn_option clist =
- if syn_option <> Url_part_not_recognized then
- clist
- else
- []
- in
- (include_if syn.url_enable_param [';']) @
- (include_if syn.url_enable_query ['?']) @
- (include_if syn.url_enable_fragment ['#'])
-;;
-
-
-let path_cats_from_syntax syn extraseps =
- let separators = separators_from_syntax syn in
- path_cats (separators @ extraseps)
-;;
-
-(* path_cats_from_syntax:
- * Computes a character categorization to extract the path from an URL.
- * This depends on the syntax because the list of possible separators
- * contains the characters that may begin the next URL clause.
- *
- * Notes:
- * - The '#' is rejected unless fragments are enabled.
- * - The '~' is accepted although this violates RFC 1738.
- *)
-
-
-let other_cats_from_syntax syn =
- let include_if syn_option clist =
- if syn_option <> Url_part_not_recognized then
- clist
- else
- []
- in
- let separators =
- (include_if syn.url_enable_param [';']) @
- (include_if syn.url_enable_query ['?']) @
- (include_if syn.url_enable_fragment ['#'])
- in
-
- make_cats
- (lalpha @ ualpha @ digit @ safe @ extra @
- (separators @ ['?'; ':'; '@'; '&'; '='; ';'; '%'; '/']))
- []
-;;
-
- (* other_cats: character categorization to extract or check the
- * "other" part of the URL.
- *)
-
-
-
-let extract_url_scheme s =
- let l = String.length s in
- let k = scan_url_part s 0 l scheme_cats false in
- (* or raise Malformed_URL *)
- if k = l then raise Malformed_URL;
- assert (s.[k] = ':');
- String.lowercase(String.sub s 0 k)
-;;
-
-
-let ( => ) a b = not a or b;; (* implication *)
-
-let ( <=> ) (a:bool) b = ( a = b );; (* equivalence *)
-
-let url_syntax_is_valid syn =
- let recognized x = x <> Url_part_not_recognized in
- let not_recognized x = x = Url_part_not_recognized in
- (recognized syn.url_enable_password => recognized syn.url_enable_user) &
- (recognized syn.url_enable_port => recognized syn.url_enable_host) &
- (recognized syn.url_enable_user => recognized syn.url_enable_host) &
- not ( (recognized syn.url_enable_user ||
- recognized syn.url_enable_password ||
- recognized syn.url_enable_host ||
- recognized syn.url_enable_port ||
- recognized syn.url_enable_path) &&
- (recognized syn.url_enable_other))
-;;
-
-
-let partial_url_syntax syn =
- let weaken =
- function
- Url_part_not_recognized -> Url_part_not_recognized
- | Url_part_allowed -> Url_part_allowed
- | Url_part_required -> Url_part_allowed
- in
- { url_enable_scheme = weaken syn.url_enable_scheme;
- url_enable_user = weaken syn.url_enable_user;
- url_enable_password = weaken syn.url_enable_password;
- url_enable_host = weaken syn.url_enable_host;
- url_enable_port = weaken syn.url_enable_port;
- url_enable_path = weaken syn.url_enable_path;
- url_enable_param = weaken syn.url_enable_param;
- url_enable_query = weaken syn.url_enable_query;
- url_enable_fragment = weaken syn.url_enable_fragment;
- url_enable_other = weaken syn.url_enable_other;
- url_accepts_8bits = syn.url_accepts_8bits;
- url_is_valid = syn.url_is_valid;
- }
-;;
-
-
-
-let file_url_syntax =
- { url_enable_scheme = Url_part_required;
- url_enable_user = Url_part_not_recognized;
- url_enable_password = Url_part_not_recognized;
- url_enable_host = Url_part_allowed;
- url_enable_port = Url_part_not_recognized;
- url_enable_path = Url_part_required;
- url_enable_param = Url_part_not_recognized;
- url_enable_query = Url_part_not_recognized;
- url_enable_fragment = Url_part_not_recognized;
- url_enable_other = Url_part_not_recognized;
- url_accepts_8bits = false;
- url_is_valid = (fun _ -> true);
- }
-;;
-
-
-let ftp_url_syntax =
- { url_enable_scheme = Url_part_required;
- url_enable_user = Url_part_allowed;
- url_enable_password = Url_part_allowed;
- url_enable_host = Url_part_required;
- url_enable_port = Url_part_allowed;
- url_enable_path = Url_part_allowed;
- url_enable_param = Url_part_allowed;
- url_enable_query = Url_part_not_recognized;
- url_enable_fragment = Url_part_not_recognized;
- url_enable_other = Url_part_not_recognized;
- url_accepts_8bits = false;
- url_is_valid = (fun _ -> true);
- }
-;;
-
-
-let http_url_syntax =
- { url_enable_scheme = Url_part_required;
- url_enable_user = Url_part_allowed;
- url_enable_password = Url_part_allowed;
- url_enable_host = Url_part_required;
- url_enable_port = Url_part_allowed;
- url_enable_path = Url_part_allowed;
- url_enable_param = Url_part_not_recognized;
- url_enable_query = Url_part_allowed;
- url_enable_fragment = Url_part_not_recognized;
- url_enable_other = Url_part_not_recognized;
- url_accepts_8bits = false;
- url_is_valid = (fun _ -> true);
- }
-;;
-
-
-let mailto_url_syntax =
- { url_enable_scheme = Url_part_required;
- url_enable_user = Url_part_not_recognized;
- url_enable_password = Url_part_not_recognized;
- url_enable_host = Url_part_not_recognized;
- url_enable_port = Url_part_not_recognized;
- url_enable_path = Url_part_not_recognized;
- url_enable_param = Url_part_not_recognized;
- url_enable_query = Url_part_not_recognized;
- url_enable_fragment = Url_part_not_recognized;
- url_enable_other = Url_part_required;
- url_accepts_8bits = false;
- url_is_valid = (fun _ -> true);
- }
-;;
-
-
-let null_url_syntax =
- { url_enable_scheme = Url_part_not_recognized;
- url_enable_user = Url_part_not_recognized;
- url_enable_password = Url_part_not_recognized;
- url_enable_host = Url_part_not_recognized;
- url_enable_port = Url_part_not_recognized;
- url_enable_path = Url_part_not_recognized;
- url_enable_param = Url_part_not_recognized;
- url_enable_query = Url_part_not_recognized;
- url_enable_fragment = Url_part_not_recognized;
- url_enable_other = Url_part_not_recognized;
- url_accepts_8bits = false;
- url_is_valid = (fun _ -> true);
- }
-;;
-
-
-let ip_url_syntax =
- { url_enable_scheme = Url_part_allowed;
- url_enable_user = Url_part_allowed;
- url_enable_password = Url_part_allowed;
- url_enable_host = Url_part_allowed;
- url_enable_port = Url_part_allowed;
- url_enable_path = Url_part_allowed;
- url_enable_param = Url_part_allowed;
- url_enable_query = Url_part_allowed;
- url_enable_fragment = Url_part_allowed;
- url_enable_other = Url_part_not_recognized;
- url_accepts_8bits = false;
- url_is_valid = (fun _ -> true);
- }
-;;
-
-
-let common_url_syntax =
- let h = Hashtbl.create 10 in
- Hashtbl.add h "file" file_url_syntax;
- Hashtbl.add h "ftp" ftp_url_syntax;
- Hashtbl.add h "http" http_url_syntax;
- Hashtbl.add h "mailto" mailto_url_syntax;
- h
-;;
-
-
-let url_conforms_to_syntax url =
- let recognized x = x <> Url_part_not_recognized in
- let required x = x = Url_part_required in
- let present x = x <> None in
- let syn = url.url_syntax in
- (present url.url_scheme => recognized syn.url_enable_scheme) &
- (present url.url_user => recognized syn.url_enable_user) &
- (present url.url_password => recognized syn.url_enable_password) &
- (present url.url_host => recognized syn.url_enable_host) &
- (present url.url_port => recognized syn.url_enable_port) &
- ((url.url_path <> []) => recognized syn.url_enable_path) &
- ((url.url_param <> []) => recognized syn.url_enable_param) &
- (present url.url_query => recognized syn.url_enable_query) &
- (present url.url_fragment => recognized syn.url_enable_fragment) &
- (present url.url_other => recognized syn.url_enable_other) &
- (required syn.url_enable_scheme => present url.url_scheme) &
- (required syn.url_enable_user => present url.url_user) &
- (required syn.url_enable_password => present url.url_password) &
- (required syn.url_enable_host => present url.url_host) &
- (required syn.url_enable_port => present url.url_port) &
- (required syn.url_enable_path => (url.url_path <> [])) &
- (required syn.url_enable_param => (url.url_param <> [])) &
- (required syn.url_enable_query => present url.url_query) &
- (required syn.url_enable_fragment => present url.url_fragment) &
- (required syn.url_enable_other => present url.url_other) &
- (url.url_validity or syn.url_is_valid url)
-;;
-
-
-let url_syntax_of_url url = url.url_syntax
-;;
-
-
-let modify_url
- ?syntax
- ?(encoded = false)
- ?scheme
- ?user
- ?password
- ?host
- ?port
- ?path
- ?param
- ?query
- ?fragment
- ?other
- url
- =
-
- let encode = Netencoding.Url.encode in
- let enc x =
- if encoded then
- x
- else
- match x with
- None -> None
- | Some x' -> Some (encode x')
- in
- let enc_list l =
- if encoded then
- l
- else
- List.map encode l
- in
-
- let new_syntax =
- match syntax with
- None -> url.url_syntax
- | Some syn -> syn
- in
-
- let check_string s_opt cats =
- match s_opt with
- None -> ()
- | Some s ->
- let l = String.length s in
- let k = scan_url_part s 0 l cats new_syntax.url_accepts_8bits in
- (* or raise Malformed_URL *)
- if k <> l then raise Malformed_URL
- in
-
- let check_string_list p cats sep =
- List.iter
- (fun p_component ->
- let l = String.length p_component in
- let k =
- scan_url_part p_component 0 l cats new_syntax.url_accepts_8bits in
- (* or raise Malformed_URL *)
- if k <> l then raise Malformed_URL;
- if String.contains p_component sep then raise Malformed_URL;
- )
- p
- in
-
- (* Create the modified record: *)
- let url' =
- {
- url_syntax = new_syntax;
- url_validity = false;
- url_scheme = if scheme = None then url.url_scheme else scheme;
- url_user = if user = None then url.url_user else enc user;
- url_password = if password = None then url.url_password else enc password;
- url_host = if host = None then url.url_host else host;
- url_port = if port = None then url.url_port else port;
- url_path = (match path with
- None -> url.url_path
- | Some p -> enc_list p);
- url_param = (match param with
- None -> url.url_param
- | Some p -> enc_list p);
- url_query = if query = None then url.url_query else enc query;
- url_fragment = if fragment = None then url.url_fragment else enc fragment;
- url_other = if other = None then url.url_other else enc other;
- }
- in
- (* Check whether the URL conforms to the syntax:
- *)
- if not (url_conforms_to_syntax url') then raise Malformed_URL;
- if url'.url_password <> None && url'.url_user = None then raise Malformed_URL;
- if url'.url_user <> None && url'.url_host = None then raise Malformed_URL;
- if url'.url_port <> None && url'.url_host = None then raise Malformed_URL;
- (* Check every part: *)
- check_string url'.url_scheme scheme_cats;
- check_string url'.url_user login_cats;
- check_string url'.url_password login_cats;
- check_string url'.url_host host_cats;
- (match url'.url_port with
- None -> ()
- | Some p -> if p < 0 || p > 65535 then raise Malformed_URL
- );
- let path_cats = path_cats_from_syntax new_syntax [] in
- let other_cats = other_cats_from_syntax new_syntax in
- check_string url'.url_query path_cats;
- check_string url'.url_fragment path_cats;
- check_string url'.url_other other_cats;
- (* Check the lists: *)
- check_string_list url'.url_param path_cats ';';
- check_string_list url'.url_path path_cats '/';
- (* Further path checks: *)
- begin match url'.url_path with
- [] ->
- (* The path is empty: There must not be a 'param' or 'query' *)
- if url'.url_host <> None then begin
- if url'.url_param <> [] then raise Malformed_URL;
- if url'.url_query <> None then raise Malformed_URL;
- end
- | ["";""] ->
- (* This is illegal. *)
- raise Malformed_URL;
- | "" :: p' ->
- (* The path is absolute: always ok *)
- ()
- | _ ->
- (* The path is relative: there must not be a host *)
- if url'.url_host <> None then raise Malformed_URL;
- end;
- begin match url'.url_path with
- _ :: rest -> (* "//" ambiguity *)
- begin match List.rev rest with
- _ :: rest' ->
- if List.exists (fun p -> p = "") rest' then
- raise Malformed_URL;
- | [] ->
- ()
- end
- | [] ->
- ()
- end;
- (* Cache that the URL is valid: *)
- url'.url_validity <- true;
-
- url'
-;;
-
-
-let null_url =
- {
- url_syntax = null_url_syntax;
- url_validity = true;
- url_scheme = None;
- url_user = None;
- url_password = None;
- url_host = None;
- url_port = None;
- url_path = [];
- url_param = [];
- url_query = None;
- url_fragment = None;
- url_other = None;
- }
-;;
-
-
-let make_url
- ?(encoded = false)
- ?scheme
- ?user
- ?password
- ?host
- ?port
- ?path
- ?param
- ?query
- ?fragment
- ?other
- url_syntax
- =
-
- if not (url_syntax_is_valid url_syntax) then
- invalid_arg "Neturl.make_url";
-
- modify_url
- ~encoded:encoded
- ~syntax:url_syntax
- ?scheme:scheme
- ?user:user
- ?password:password
- ?host:host
- ?port:port
- ?path:path
- ?param:param
- ?query:query
- ?fragment:fragment
- ?other:other
- null_url
-;;
-
-
-let remove_from_url
- ?(scheme = false)
- ?(user = false)
- ?(password = false)
- ?(host = false)
- ?(port = false)
- ?(path = false)
- ?(param = false)
- ?(query = false)
- ?(fragment = false)
- ?(other = false)
- url
- =
-
- make_url
- ~encoded: true
- ?scheme: (if scheme then None else url.url_scheme)
- ?user: (if user then None else url.url_user)
- ?password: (if password then None else url.url_password)
- ?host: (if host then None else url.url_host)
- ?port: (if port then None else url.url_port)
- ?path: (if path then None else Some url.url_path)
- ?param: (if param then None else Some url.url_param)
- ?query: (if query then None else url.url_query)
- ?fragment: (if fragment then None else url.url_fragment)
- ?other: (if other then None else url.url_other)
- url.url_syntax
-;;
-
-
-let default_url
- ?(encoded = false)
- ?scheme
- ?user
- ?password
- ?host
- ?port
- ?(path = [])
- ?(param = [])
- ?query
- ?fragment
- ?other
- url
- =
-
- let encode = Netencoding.Url.encode in
-
- let enc x =
- if encoded then
- x
- else
- match x with
- None -> None
- | Some x' -> Some (encode x')
- in
-
- let enc_list l =
- if encoded then
- l
- else
- List.map encode l
- in
-
- let pass_if_missing current arg =
- match current with
- None -> arg
- | _ -> current
- in
-
- make_url
- ~encoded: true
- ?scheme: (pass_if_missing url.url_scheme scheme)
- ?user: (pass_if_missing url.url_user (enc user))
- ?password: (pass_if_missing url.url_password (enc password))
- ?host: (pass_if_missing url.url_host host)
- ?port: (pass_if_missing url.url_port port)
- ~path: (if url.url_path = [] then enc_list path else url.url_path)
- ~param: (if url.url_param = [] then enc_list param else url.url_param)
- ?query: (pass_if_missing url.url_query (enc query))
- ?fragment: (pass_if_missing url.url_fragment (enc fragment))
- ?other: (pass_if_missing url.url_other (enc other))
- url.url_syntax
-;;
-
-
-let undefault_url
- ?scheme
- ?user
- ?password
- ?host
- ?port
- ?path
- ?param
- ?query
- ?fragment
- ?other
- url
- =
-
- let remove_if_matching current arg =
- match current with
- None -> None
- | Some x ->
- (match arg with
- None -> current
- | Some x' ->
- if x=x' then
- None
- else
- current)
- in
-
- make_url
- ~encoded: true
- ?scheme: (remove_if_matching url.url_scheme scheme)
- ?user: (remove_if_matching url.url_user user)
- ?password: (remove_if_matching url.url_password password)
- ?host: (remove_if_matching url.url_host host)
- ?port: (remove_if_matching url.url_port port)
- ~path: (match path with
- None -> url.url_path
- | Some x ->
- if x = url.url_path then
- []
- else
- url.url_path)
- ~param: (match param with
- None -> url.url_param
- | Some x ->
- if x = url.url_param then
- []
- else
- url.url_param)
- ?query: (remove_if_matching url.url_query query)
- ?fragment: (remove_if_matching url.url_fragment fragment)
- ?other: (remove_if_matching url.url_other other)
- url.url_syntax
-;;
-
-
-let url_provides
- ?(scheme = false)
- ?(user = false)
- ?(password = false)
- ?(host = false)
- ?(port = false)
- ?(path = false)
- ?(param = false)
- ?(query = false)
- ?(fragment = false)
- ?(other = false)
- url
- =
-
- (scheme => (url.url_scheme <> None)) &
- (user => (url.url_user <> None)) &
- (password => (url.url_password <> None)) &
- (host => (url.url_host <> None)) &
- (port => (url.url_port <> None)) &
- (path => (url.url_path <> [])) &
- (param => (url.url_param <> [])) &
- (query => (url.url_query <> None)) &
- (fragment => (url.url_fragment <> None)) &
- (other => (url.url_other <> None))
-;;
-
-
-let return_if value =
- match value with
- None -> raise Not_found
- | Some x -> x
-;;
-
-
-let decode_if want_encoded value =
- let value' = return_if value in
- if want_encoded then
- value'
- else
- Netencoding.Url.decode value' (* WARNING: not thread-safe! *)
-;;
-
-
-let decode_path_if want_encoded value =
- if want_encoded then
- value
- else
- List.map Netencoding.Url.decode value (* WARNING: not thread-safe! *)
-;;
-
-
-let url_scheme url = return_if url.url_scheme;;
-let url_user ?(encoded=false) url = decode_if encoded url.url_user;;
-let url_password ?(encoded=false) url = decode_if encoded url.url_password;;
-let url_host url = return_if url.url_host;;
-let url_port url = return_if url.url_port;;
-let url_path ?(encoded=false) url = decode_path_if encoded url.url_path;;
-let url_param ?(encoded=false) url = decode_path_if encoded url.url_param;;
-let url_query ?(encoded=false) url = decode_if encoded url.url_query;;
-let url_fragment ?(encoded=false) url = decode_if encoded url.url_fragment;;
-let url_other ?(encoded=false) url = decode_if encoded url.url_other;;
-
-
-let string_of_url url =
- if not (url.url_validity) then
- failwith "Neturl.string_of_url: URL not flagged as valid";
- (match url.url_scheme with
- None -> ""
- | Some s -> s ^ ":") ^
- (match url.url_host with
- None -> ""
- | Some host ->
- "//" ^
- (match url.url_user with
- None -> ""
- | Some user ->
- user ^
- (match url.url_password with
- None -> ""
- | Some password ->
- ":" ^ password
- ) ^
- "@") ^
- host ^
- (match url.url_port with
- None -> ""
- | Some port ->
- ":" ^ string_of_int port)) ^
- (match url.url_path with
- | [""] ->
- "/"
- | x :: p when url.url_scheme = None &&
- url.url_host = None &&
- String.contains x ':'
- ->
- (* Really a special case: The colon contained in 'x' may cause
- * that a prefix of 'x' is interpreted as URL scheme. In this
- * case, "./" is prepended (as recommended in RFC 1808, 5.3).
- *)
- "./"
- | _ ->
- ""
- ) ^
- String.concat "/" url.url_path ^
- (match url.url_other with
- None -> ""
- | Some other ->
- other) ^
- String.concat "" (List.map (fun s -> ";" ^ s) url.url_param) ^
- (match url.url_query with
- None -> ""
- | Some query ->
- "?" ^ query) ^
- (match url.url_fragment with
- None -> ""
- | Some fragment ->
- "#" ^ fragment)
-;;
-
-
-let url_of_string url_syntax s =
- let l = String.length s in
- let recognized x = x <> Url_part_not_recognized in
-
- let rec collect_words terminators eof_char cats k =
- (* Collect words as recognized by 'cats', starting at position 'k' in
- * 's'. Collection stops if one the characters listed in 'terminators'
- * is found. If the end of the string is reached, it is treated as
- * 'eof_char'.
- *)
- let k' = scan_url_part s k l cats url_syntax.url_accepts_8bits in
- (* or raise Malformed_URL *)
- let word, sep =
- String.sub s k (k'-k), (if k'<l then s.[k'] else eof_char) in
- if List.mem sep terminators then
- [word, sep], k'
- else
- let word_sep_list', k'' =
- collect_words terminators eof_char cats (k'+1) in
- ((word, sep) :: word_sep_list'), k''
- in
-
- (* Try to extract the scheme name: *)
- let scheme, k1 =
- if recognized url_syntax.url_enable_scheme then
- try
- let k = scan_url_part s 0 l scheme_cats false in
- (* or raise Malformed_URL *)
- if k = l then raise Malformed_URL;
- assert (s.[k] = ':');
- Some (String.sub s 0 k), (k+1)
- with
- Malformed_URL -> None, 0
- else
- None, 0
- in
-
- (* If there is a "//", a host will follow: *)
- let host, port, user, password, k2 =
- if recognized url_syntax.url_enable_host &&
- k1 + 2 <= l && s.[k1]='/' && s.[k1+1]='/' then begin
-
- let word_sep_list, k' = collect_words [ '/'; '#' ] '/' login_cats (k1+2)
- in
- (* or raise Malformed_URL *)
-
- let int x =
- try int_of_string x with _ -> raise Malformed_URL in
-
- match word_sep_list with
- [ host, ('/'|'#') ] ->
- Some host, None, None, None, k'
- | [ host, ':'; port, ('/'|'#') ] ->
- Some host, Some (int port), None, None, k'
- | [ user, '@'; host, ('/'|'#') ] ->
- Some host, None, Some user, None, k'
- | [ user, '@'; host, ':'; port, ('/'|'#') ] ->
- Some host, Some (int port), Some user, None, k'
- | [ user, ':'; password, '@'; host, ('/'|'#') ] ->
- Some host, None, Some user, Some password, k'
- | [ user, ':'; password, '@'; host, ':'; port, ('/'|'#') ] ->
- Some host, Some (int port), Some user, Some password, k'
- | _ ->
- raise Malformed_URL
- end
- else
- None, None, None, None, k1
- in
-
- let path, k3 =
- if recognized url_syntax.url_enable_path &&
- k2 < l (* && s.[k2]='/' *)
- then begin
- let cats = path_cats_from_syntax url_syntax [ '/' ] in
- let seps = separators_from_syntax url_syntax in
-
- (* Note: '>' is not allowed within URLs; because of this we can use
- * it as end-of-string character.
- *)
-
- let word_sep_list, k' = collect_words ('>'::seps) '>' cats k2 in
- (* or raise Malformed_URL *)
- match word_sep_list with
- [ "", '/'; "", _ ] ->
- [ "" ], k'
- | [ "", _ ] ->
- [], k'
- | _ ->
- List.map fst word_sep_list, k'
- end
- else begin
- (* If there is a single '/': skip it *)
- if not (recognized url_syntax.url_enable_other) &&
- k2 < l && s.[k2]='/'
- then
- [], (k2+1)
- else
- [], k2
- end
- in
-
- let other, k4 =
- if recognized url_syntax.url_enable_other &&
- k3 < l
- then begin
-
- let cats = other_cats_from_syntax url_syntax in
-
- (* Note: '>' is not allowed within URLs; because of this we can use
- * it as end-of-string character.
- *)
-
- let word_sep_list, k' = collect_words ['>';'#'] '>' cats k3 in
- (* or raise Malformed_URL *)
-
- match word_sep_list with
- [ other, _ ] -> Some other, k'
- | _ -> assert false
- end
- else
- None, k3
- in
-
- let param, k5 =
- if recognized url_syntax.url_enable_param &&
- k4 < l && s.[k4]=';'
- then begin
- let cats = path_cats_from_syntax url_syntax [] in
- let seps = separators_from_syntax url_syntax in
- let seps' = List.filter (fun c -> c <> ';') seps in
-
- (* Note: '>' is not allowed within URLs; because of this we can use
- * it as end-of-string character.
- *)
-
- let word_sep_list, k' = collect_words ('>'::seps') '>' cats (k4+1) in
- (* or raise Malformed_URL *)
-
- List.map fst word_sep_list, k'
- end
- else
- [], k4
- in
-
- let query, k6 =
- if recognized url_syntax.url_enable_query &&
- k5 < l && s.[k5]='?'
- then begin
- let cats = path_cats_from_syntax url_syntax [] in
- let seps = separators_from_syntax url_syntax in
-
- (* Note: '>' is not allowed within URLs; because of this we can use
- * it as end-of-string character.
- *)
-
- let word_sep_list, k' = collect_words ('>'::seps) '>' cats (k5+1) in
- (* or raise Malformed_URL *)
-
- match word_sep_list with
- [ query, _ ] -> Some query, k'
- | _ -> assert false
- end
- else
- None, k5
- in
-
- let fragment, k7 =
- if recognized url_syntax.url_enable_fragment &&
- k6 < l && s.[k6]='#'
- then begin
- let cats = path_cats_from_syntax url_syntax [] in
- let seps = separators_from_syntax url_syntax in
-
- (* Note: '>' is not allowed within URLs; because of this we can use
- * it as end-of-string character.
- *)
-
- let word_sep_list, k' = collect_words ('>'::seps) '>' cats (k6+1) in
- (* or raise Malformed_URL *)
-
- match word_sep_list with
- [ fragment, _ ] -> Some fragment, k'
- | _ -> assert false
- end
- else
- None, k6
- in
-
- if k7 <> l then raise Malformed_URL;
-
- make_url
- ~encoded:true
- ?scheme:scheme
- ?user:user
- ?password:password
- ?host:host
- ?port:port
- ~path:path
- ~param:param
- ?query:query
- ?fragment:fragment
- ?other:other
- url_syntax
-;;
-
-
-let split_path s =
- let l = String.length s in
- let rec collect_words k =
- let k' =
- try
- String.index_from s k '/'
- with
- Not_found -> l
- in
- let word = String.sub s k (k'-k) in
- if k' >= l then
- [word]
- else
- word :: collect_words (k'+1)
- in
- match collect_words 0 with
- [ "" ] -> []
- | [ "";"" ] -> [ "" ]
- | other -> other
-;;
-
-
-let join_path l =
- match l with
- [ "" ] -> "/"
- | _ -> String.concat "/" l;;
-
-
-let norm_path l =
-
- let rec remove_slash_slash l first =
- match l with
- | [ "" ] ->
- [ "" ]
- | [ ""; "" ] when first ->
- [ "" ]
- | "" :: l' when not first ->
- remove_slash_slash l' false
- | x :: l' ->
- x :: remove_slash_slash l' false
- | [] ->
- []
- in
-
- let rec remove_dot l first =
- match l with
- | ([ "." ] | ["."; ""]) ->
- if first then [] else [ "" ]
- | "." :: x :: l' ->
- remove_dot (x :: l') false
- | x :: l' ->
- x :: remove_dot l' false
- | [] ->
- []
- in
-
- let rec remove_dot_dot_once l first =
- match l with
- x :: ".." :: [] when x <> "" && x <> ".." && not first ->
- [ "" ]
- | x :: ".." :: l' when x <> "" && x <> ".." ->
- l'
- | x :: l' ->
- x :: remove_dot_dot_once l' false
- | [] ->
- raise Not_found
- in
-
- let rec remove_dot_dot l =
- try
- let l' = remove_dot_dot_once l true in
- remove_dot_dot l'
- with
- Not_found -> l
- in
-
- let l' = remove_dot_dot (remove_dot (remove_slash_slash l true) true) in
- match l' with
- [".."] -> [".."; ""]
- | ["";""] -> [ "" ]
- | _ -> l'
-;;
-
-
-let apply_relative_url baseurl relurl =
- if not (baseurl.url_validity) or not (relurl.url_validity) then
- failwith "Neturl.apply_relative_url: URL not flagged as valid";
-
- if relurl.url_scheme <> None then
- modify_url
- ~syntax:baseurl.url_syntax (* inherit syntax *)
- relurl
- else
- if relurl.url_host <> None then
- modify_url
- ~syntax:baseurl.url_syntax (* inherit syntax and scheme *)
- ?scheme:baseurl.url_scheme
- relurl
- else
- match relurl.url_path with
- "" :: other ->
- (* An absolute path *)
- modify_url
- ~syntax:baseurl.url_syntax (* inherit syntax, scheme, and *)
- ~encoded:true
- ?scheme:baseurl.url_scheme (* login info *)
- ?host:baseurl.url_host
- ?port:baseurl.url_port
- ?user:baseurl.url_user
- ?password:baseurl.url_password
- relurl
- | [] ->
- (* Empty: Inherit also path, params, query, and fragment *)
- let new_params, new_query, new_fragment =
- match relurl.url_param, relurl.url_query, relurl.url_fragment
- with
- [], None, None ->
- (* Inherit all three *)
- baseurl.url_param, baseurl.url_query, baseurl.url_fragment
- | [], None, f ->
- (* Inherit params and query *)
- baseurl.url_param, baseurl.url_query, f
- | [], q, f ->
- (* Inherit params *)
- baseurl.url_param, q, f
- | p, q, f ->
- (* Inherit none of them *)
- p, q, f
- in
- modify_url
- ~syntax:baseurl.url_syntax
- ~encoded:true
- ?scheme:baseurl.url_scheme
- ?host:baseurl.url_host
- ?port:baseurl.url_port
- ?user:baseurl.url_user
- ?password:baseurl.url_password
- ~path:baseurl.url_path
- ~param:new_params
- ?query:new_query
- ?fragment:new_fragment
- relurl
- | relpath ->
- (* A relative path *)
- let rec change_path basepath =
- match basepath with
- | [] ->
- relpath
- | [ x ] ->
- relpath
- | x :: basepath' ->
- x :: change_path basepath'
- in
- let new_path = norm_path (change_path baseurl.url_path) in
- modify_url
- ~syntax:baseurl.url_syntax (* inherit syntax, scheme, and *)
- ~encoded:true
- ?scheme:baseurl.url_scheme (* login info *)
- ?host:baseurl.url_host
- ?port:baseurl.url_port
- ?user:baseurl.url_user
- ?password:baseurl.url_password
- ~path:new_path (* and change path *)
- relurl
-
-;;
-
-
-let print_url url =
- Format.print_string ("<URL:" ^ string_of_url url ^ ">")
-;;
-
-
-(* ======================================================================
- * History:
- *
- * $Log$
- * Revision 1.1 2000/11/17 09:57:28 lpadovan
- * Initial revision
- *
- * Revision 1.4 2000/07/04 21:50:51 gerd
- * Fixed typo.
- *
- * Revision 1.3 2000/06/26 22:57:49 gerd
- * Change: The record 'url_syntax' has an additional component
- * 'url_accepts_8bits'. Setting this option to 'true' causes that
- * the bytes >= 0x80 are no longer rejected.
- *
- * Revision 1.2 2000/06/25 19:39:48 gerd
- * Lots of Bugfixes.
- *
- * Revision 1.1 2000/06/24 20:19:59 gerd
- * Initial revision.
- *
- *
- *)
projects / helm.git / blobdiff