helm/DEVEL/pxp/netstring/neturl.ml

   1 (* $Id$
   2  * ----------------------------------------------------------------------
   3  *
   4  *)
   5
   6 exception Malformed_URL
   7
   8 type url_syntax_option =
   9     Url_part_not_recognized
  10   | Url_part_allowed
  11   | Url_part_required
  12
  13
  14 type url_syntax =
  15     { url_enable_scheme    : url_syntax_option;
  16       url_enable_user      : url_syntax_option;
  17       url_enable_password  : url_syntax_option;
  18       url_enable_host      : url_syntax_option;
  19       url_enable_port      : url_syntax_option;
  20       url_enable_path      : url_syntax_option;
  21       url_enable_param     : url_syntax_option;
  22       url_enable_query     : url_syntax_option;
  23       url_enable_fragment  : url_syntax_option;
  24       url_enable_other     : url_syntax_option;
  25       url_accepts_8bits    : bool;
  26       url_is_valid         : url -> bool;
  27     }
  28
  29 and url =
  30     {
  31       url_syntax   : url_syntax;
  32       mutable url_validity : bool;
  33       url_scheme   : string option;
  34       url_user     : string option;
  35       url_password : string option;
  36       url_host     : string option;
  37       url_port     : int option;
  38       url_path     : string list;
  39       url_param    : string list;
  40       url_query    : string option;
  41       url_fragment : string option;
  42       url_other    : string option;
  43     }
  44 ;;
  45
  46
  47 type char_category =
  48     Accepted
  49   | Rejected
  50   | Separator
  51
  52
  53
  54 let scan_url_part s k_from k_to cats accept_8bits =
  55   (* Scans the longest word of accepted characters from position 'k_from'
  56    * in 's' until at most position 'k_to'. The character following the
  57    * word (if any) must be a separator character.
  58    * On success, the function returns the position of the last character
  59    * of the word + 1.
  60    * If there is any rejected character before the separator or the end
  61    * of the string (i.e. position 'k_to') is reached, the exception
  62    * Malformed_URL is raised.
  63    * Furthermore, if the character '%' is accepted it is checked whether
  64    * two hexadecimal digits follow (which must be accepted, too). If this
  65    * is not true, the exception Malformed_URL is raised, too.
  66    * 'cats': contains for every character code (0 to 255) the category
  67    * of the character.
  68    *)
  69   let check_hex c =
  70     if cats.( Char.code c ) <> Accepted then raise Malformed_URL;
  71     match c with
  72         ('0'..'9'|'A'..'F'|'a'..'f') -> ()
  73       | _ -> raise Malformed_URL
  74   in
  75
  76   let rec scan k =
  77     if k >= k_to then
  78       k
  79     else begin
  80       let c = s.[k] in
  81       let cat = cats.(Char.code c) in
  82       match cat with
  83           Accepted ->
  84             if c = '%' then begin
  85               if k+2 >= k_to then raise Malformed_URL;
  86               let c1 = s.[k+1] in
  87               let c2 = s.[k+2] in
  88               check_hex c1;
  89               check_hex c2;
  90               scan (k+3)
  91             end
  92             else
  93               scan (k+1)
  94         | Separator -> k
  95         | Rejected ->
  96             if accept_8bits && c >= '\128'
  97             then scan (k+1)
  98             else raise Malformed_URL
  99     end
 100   in
 101
 102   assert (Array.length cats = 256);
 103   assert (k_from >= 0);
 104   assert (k_from <= k_to);
 105   assert (k_to <= String.length s);
 106
 107   scan k_from
 108 ;;
 109
 110
 111 (* Create a categorization: *)
 112
 113 let lalpha = [ 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; 'g'; 'h'; 'i'; 'j'; 'k'; 'l'; 'm';
 114                'n'; 'o'; 'p'; 'q'; 'r'; 's'; 't'; 'u'; 'v'; 'w'; 'x'; 'y'; 'z' ]
 115
 116 let ualpha = [ 'A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M';
 117                'N'; 'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z' ]
 118
 119 let digit = [ '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9' ]
 120
 121 let safe = [ '$'; '-'; '_'; '.'; '+' ]
 122
 123 let extra = [ '!'; '*'; '\''; '('; ')'; ',' ]
 124
 125 let make_cats accepted separators =
 126   (* create a categorization:
 127    * - All characters listed in 'separators' are separators.
 128    * - All characters listed in 'accepted' and which do not occur in
 129    *   'separators' are accepted characters.
 130    * - All other characters are rejected.
 131    *)
 132   let cats = Array.make 256 Rejected in
 133   List.iter
 134     (fun c ->
 135        cats.(Char.code c) <- Accepted
 136     )
 137     accepted;
 138
 139   List.iter
 140     (fun c ->
 141        cats.(Char.code c) <- Separator
 142     )
 143     separators;
 144   cats
 145 ;;
 146
 147
 148 let scheme_cats =
 149   make_cats (lalpha @ ualpha @ ['+'; '-'; '.']) [':'] ;;
 150
 151     (* scheme_cats: character categorization to _extract_ the URL scheme *)
 152
 153
 154 let login_cats =
 155   make_cats
 156     (lalpha @ ualpha @ digit @ safe @ extra @ [';'; '?'; '&'; '='; '%'])
 157     [':'; '@'; '/'; '#' ]
 158 ;;
 159
 160     (* login_cats: character categorization to _extract_ user name, password,
 161      * host name, and port.
 162      *)
 163
 164 let host_cats =
 165   make_cats
 166     (lalpha @ ualpha @ digit @ ['.'; '-'])
 167     []
 168 ;;
 169
 170     (* host_cats: character categorization to _check_ whether the host name
 171      * is formed only by legal characters.
 172      * Especially '%' is not allowed here!
 173      *)
 174
 175 let port_cats =
 176   make_cats
 177     digit
 178     []
 179 ;;
 180
 181     (* port_cats: character categorization to _check_ whether the port number
 182      * is formed only by legal characters.
 183      * Especially '%' is not allowed here!
 184      *)
 185
 186 let path_cats separators =
 187   make_cats
 188     (lalpha @ ualpha @ digit @ safe @ extra @
 189               ['?'; ':'; '@'; '&'; '='; ';'; '%'; '/'; '~'])
 190     separators
 191 ;;
 192
 193
 194 let separators_from_syntax syn =
 195   let include_if syn_option clist =
 196     if syn_option <> Url_part_not_recognized then
 197       clist
 198     else
 199       []
 200   in
 201   (include_if syn.url_enable_param [';']) @
 202   (include_if syn.url_enable_query ['?']) @
 203   (include_if syn.url_enable_fragment ['#'])
 204 ;;
 205
 206
 207 let path_cats_from_syntax syn extraseps =
 208   let separators = separators_from_syntax syn in
 209   path_cats (separators @ extraseps)
 210 ;;
 211
 212 (* path_cats_from_syntax:
 213  * Computes a character categorization to extract the path from an URL.
 214  * This depends on the syntax because the list of possible separators
 215  * contains the characters that may begin the next URL clause.
 216  *
 217  * Notes:
 218  * - The '#' is rejected unless fragments are enabled.
 219  * - The '~' is accepted although this violates RFC 1738.
 220  *)
 221
 222
 223 let other_cats_from_syntax syn =
 224   let include_if syn_option clist =
 225     if syn_option <> Url_part_not_recognized then
 226       clist
 227     else
 228       []
 229   in
 230   let separators =
 231     (include_if syn.url_enable_param [';']) @
 232     (include_if syn.url_enable_query ['?']) @
 233     (include_if syn.url_enable_fragment ['#'])
 234   in
 235
 236   make_cats
 237     (lalpha @ ualpha @ digit @ safe @ extra @
 238               (separators @ ['?'; ':'; '@'; '&'; '='; ';'; '%'; '/']))
 239     []
 240 ;;
 241
 242     (* other_cats: character categorization to extract or check the
 243      * "other" part of the URL.
 244      *)
 245
 246
 247
 248 let extract_url_scheme s =
 249   let l = String.length s in
 250   let k = scan_url_part s 0 l scheme_cats false in
 251           (* or raise Malformed_URL *)
 252   if k = l then raise Malformed_URL;
 253   assert (s.[k] = ':');
 254   String.lowercase(String.sub s 0 k)
 255 ;;
 256
 257
 258 let ( => ) a b = not a or b;;   (* implication *)
 259
 260 let ( <=> ) (a:bool) b = ( a = b );;  (* equivalence *)
 261
 262 let url_syntax_is_valid syn =
 263   let recognized x = x <> Url_part_not_recognized in
 264   let not_recognized x = x = Url_part_not_recognized in
 265   (recognized syn.url_enable_password => recognized syn.url_enable_user) &
 266   (recognized syn.url_enable_port     => recognized syn.url_enable_host) &
 267   (recognized syn.url_enable_user     => recognized syn.url_enable_host) &
 268   not ( (recognized syn.url_enable_user ||
 269          recognized syn.url_enable_password ||
 270          recognized syn.url_enable_host ||
 271          recognized syn.url_enable_port ||
 272          recognized syn.url_enable_path) &&
 273         (recognized syn.url_enable_other))
 274 ;;
 275
 276
 277 let partial_url_syntax syn =
 278   let weaken =
 279     function
 280         Url_part_not_recognized -> Url_part_not_recognized
 281       | Url_part_allowed        -> Url_part_allowed
 282       | Url_part_required       -> Url_part_allowed
 283   in
 284   { url_enable_scheme    = weaken syn.url_enable_scheme;
 285     url_enable_user      = weaken syn.url_enable_user;
 286     url_enable_password  = weaken syn.url_enable_password;
 287     url_enable_host      = weaken syn.url_enable_host;
 288     url_enable_port      = weaken syn.url_enable_port;
 289     url_enable_path      = weaken syn.url_enable_path;
 290     url_enable_param     = weaken syn.url_enable_param;
 291     url_enable_query     = weaken syn.url_enable_query;
 292     url_enable_fragment  = weaken syn.url_enable_fragment;
 293     url_enable_other     = weaken syn.url_enable_other;
 294     url_accepts_8bits    = syn.url_accepts_8bits;
 295     url_is_valid         = syn.url_is_valid;
 296   }
 297 ;;
 298
 299
 300
 301 let file_url_syntax =
 302   { url_enable_scheme    = Url_part_required;
 303     url_enable_user      = Url_part_not_recognized;
 304     url_enable_password  = Url_part_not_recognized;
 305     url_enable_host      = Url_part_allowed;
 306     url_enable_port      = Url_part_not_recognized;
 307     url_enable_path      = Url_part_required;
 308     url_enable_param     = Url_part_not_recognized;
 309     url_enable_query     = Url_part_not_recognized;
 310     url_enable_fragment  = Url_part_not_recognized;
 311     url_enable_other     = Url_part_not_recognized;
 312     url_accepts_8bits    = false;
 313     url_is_valid         = (fun _ -> true);
 314   }
 315 ;;
 316
 317
 318 let ftp_url_syntax =
 319   { url_enable_scheme    = Url_part_required;
 320     url_enable_user      = Url_part_allowed;
 321     url_enable_password  = Url_part_allowed;
 322     url_enable_host      = Url_part_required;
 323     url_enable_port      = Url_part_allowed;
 324     url_enable_path      = Url_part_allowed;
 325     url_enable_param     = Url_part_allowed;
 326     url_enable_query     = Url_part_not_recognized;
 327     url_enable_fragment  = Url_part_not_recognized;
 328     url_enable_other     = Url_part_not_recognized;
 329     url_accepts_8bits    = false;
 330     url_is_valid         = (fun _ -> true);
 331   }
 332 ;;
 333
 334
 335 let http_url_syntax =
 336   { url_enable_scheme    = Url_part_required;
 337     url_enable_user      = Url_part_allowed;
 338     url_enable_password  = Url_part_allowed;
 339     url_enable_host      = Url_part_required;
 340     url_enable_port      = Url_part_allowed;
 341     url_enable_path      = Url_part_allowed;
 342     url_enable_param     = Url_part_not_recognized;
 343     url_enable_query     = Url_part_allowed;
 344     url_enable_fragment  = Url_part_not_recognized;
 345     url_enable_other     = Url_part_not_recognized;
 346     url_accepts_8bits    = false;
 347     url_is_valid         = (fun _ -> true);
 348   }
 349 ;;
 350
 351
 352 let mailto_url_syntax =
 353   { url_enable_scheme    = Url_part_required;
 354     url_enable_user      = Url_part_not_recognized;
 355     url_enable_password  = Url_part_not_recognized;
 356     url_enable_host      = Url_part_not_recognized;
 357     url_enable_port      = Url_part_not_recognized;
 358     url_enable_path      = Url_part_not_recognized;
 359     url_enable_param     = Url_part_not_recognized;
 360     url_enable_query     = Url_part_not_recognized;
 361     url_enable_fragment  = Url_part_not_recognized;
 362     url_enable_other     = Url_part_required;
 363     url_accepts_8bits    = false;
 364     url_is_valid         = (fun _ -> true);
 365   }
 366 ;;
 367
 368
 369 let null_url_syntax =
 370   { url_enable_scheme    = Url_part_not_recognized;
 371     url_enable_user      = Url_part_not_recognized;
 372     url_enable_password  = Url_part_not_recognized;
 373     url_enable_host      = Url_part_not_recognized;
 374     url_enable_port      = Url_part_not_recognized;
 375     url_enable_path      = Url_part_not_recognized;
 376     url_enable_param     = Url_part_not_recognized;
 377     url_enable_query     = Url_part_not_recognized;
 378     url_enable_fragment  = Url_part_not_recognized;
 379     url_enable_other     = Url_part_not_recognized;
 380     url_accepts_8bits    = false;
 381     url_is_valid         = (fun _ -> true);
 382   }
 383 ;;
 384
 385
 386 let ip_url_syntax =
 387   { url_enable_scheme    = Url_part_allowed;
 388     url_enable_user      = Url_part_allowed;
 389     url_enable_password  = Url_part_allowed;
 390     url_enable_host      = Url_part_allowed;
 391     url_enable_port      = Url_part_allowed;
 392     url_enable_path      = Url_part_allowed;
 393     url_enable_param     = Url_part_allowed;
 394     url_enable_query     = Url_part_allowed;
 395     url_enable_fragment  = Url_part_allowed;
 396     url_enable_other     = Url_part_not_recognized;
 397     url_accepts_8bits    = false;
 398     url_is_valid         = (fun _ -> true);
 399   }
 400 ;;
 401
 402
 403 let common_url_syntax =
 404   let h = Hashtbl.create 10 in
 405   Hashtbl.add h "file"   file_url_syntax;
 406   Hashtbl.add h "ftp"    ftp_url_syntax;
 407   Hashtbl.add h "http"   http_url_syntax;
 408   Hashtbl.add h "mailto" mailto_url_syntax;
 409   h
 410 ;;
 411
 412
 413 let url_conforms_to_syntax url =
 414   let recognized x = x <> Url_part_not_recognized in
 415   let required x = x = Url_part_required in
 416   let present x    = x <> None in
 417   let syn = url.url_syntax in
 418   (present url.url_scheme   => recognized syn.url_enable_scheme)   &
 419   (present url.url_user     => recognized syn.url_enable_user)     &
 420   (present url.url_password => recognized syn.url_enable_password) &
 421   (present url.url_host     => recognized syn.url_enable_host)     &
 422   (present url.url_port     => recognized syn.url_enable_port)     &
 423   ((url.url_path <> [])     => recognized syn.url_enable_path)     &
 424   ((url.url_param <> [])    => recognized syn.url_enable_param)    &
 425   (present url.url_query    => recognized syn.url_enable_query)    &
 426   (present url.url_fragment => recognized syn.url_enable_fragment) &
 427   (present url.url_other    => recognized syn.url_enable_other)    &
 428   (required syn.url_enable_scheme   => present url.url_scheme)     &
 429   (required syn.url_enable_user     => present url.url_user)       &
 430   (required syn.url_enable_password => present url.url_password)   &
 431   (required syn.url_enable_host     => present url.url_host)       &
 432   (required syn.url_enable_port     => present url.url_port)       &
 433   (required syn.url_enable_path     => (url.url_path <> []))       &
 434   (required syn.url_enable_param    => (url.url_param <> []))      &
 435   (required syn.url_enable_query    => present url.url_query)      &
 436   (required syn.url_enable_fragment => present url.url_fragment)   &
 437   (required syn.url_enable_other    => present url.url_other)      &
 438   (url.url_validity or syn.url_is_valid url)
 439 ;;
 440
 441
 442 let url_syntax_of_url url = url.url_syntax
 443 ;;
 444
 445
 446 let modify_url
 447       ?syntax
 448       ?(encoded = false)
 449       ?scheme
 450       ?user
 451       ?password
 452       ?host
 453       ?port
 454       ?path
 455       ?param
 456       ?query
 457       ?fragment
 458       ?other
 459       url
 460   =
 461
 462   let encode = Netencoding.Url.encode in
 463   let enc x =
 464     if encoded then
 465       x
 466     else
 467       match x with
 468           None -> None
 469         | Some x' -> Some (encode x')
 470   in
 471   let enc_list l =
 472     if encoded then
 473       l
 474     else
 475       List.map encode l
 476   in
 477
 478   let new_syntax =
 479     match syntax with
 480         None -> url.url_syntax
 481       | Some syn -> syn
 482   in
 483
 484   let check_string s_opt cats =
 485     match s_opt with
 486         None   -> ()
 487       | Some s ->
 488           let l = String.length s in
 489           let k = scan_url_part s 0 l cats new_syntax.url_accepts_8bits in
 490                   (* or raise Malformed_URL *)
 491           if k <> l then raise Malformed_URL
 492   in
 493
 494   let check_string_list p cats sep =
 495     List.iter
 496       (fun p_component ->
 497          let l = String.length p_component in
 498          let k =
 499            scan_url_part p_component 0 l cats new_syntax.url_accepts_8bits in
 500            (* or raise Malformed_URL *)
 501          if k <> l then raise Malformed_URL;
 502          if String.contains p_component sep then raise Malformed_URL;
 503       )
 504       p
 505   in
 506
 507   (* Create the modified record: *)
 508   let url' =
 509     {
 510       url_syntax   = new_syntax;
 511       url_validity = false;
 512       url_scheme   = if scheme   = None then url.url_scheme   else scheme;
 513       url_user     = if user     = None then url.url_user     else enc user;
 514       url_password = if password = None then url.url_password else enc password;
 515       url_host     = if host     = None then url.url_host     else host;
 516       url_port     = if port     = None then url.url_port     else port;
 517       url_path     = (match path with
 518                           None -> url.url_path
 519                         | Some p -> enc_list p);
 520       url_param    = (match param with
 521                           None -> url.url_param
 522                         | Some p -> enc_list p);
 523       url_query    = if query    = None then url.url_query    else enc query;
 524       url_fragment = if fragment = None then url.url_fragment else enc fragment;
 525       url_other    = if other    = None then url.url_other    else enc other;
 526     }
 527   in
 528   (* Check whether the URL conforms to the syntax:
 529    *)
 530   if not (url_conforms_to_syntax url') then raise Malformed_URL;
 531   if url'.url_password <> None && url'.url_user = None then raise Malformed_URL;
 532   if url'.url_user <> None && url'.url_host = None then raise Malformed_URL;
 533   if url'.url_port <> None && url'.url_host = None then raise Malformed_URL;
 534   (* Check every part: *)
 535   check_string url'.url_scheme   scheme_cats;
 536   check_string url'.url_user     login_cats;
 537   check_string url'.url_password login_cats;
 538   check_string url'.url_host     host_cats;
 539   (match url'.url_port with
 540        None -> ()
 541      | Some p -> if p < 0 || p > 65535 then raise Malformed_URL
 542   );
 543   let path_cats  = path_cats_from_syntax  new_syntax [] in
 544   let other_cats = other_cats_from_syntax new_syntax in
 545   check_string url'.url_query    path_cats;
 546   check_string url'.url_fragment path_cats;
 547   check_string url'.url_other    other_cats;
 548   (* Check the lists: *)
 549   check_string_list url'.url_param path_cats ';';
 550   check_string_list url'.url_path  path_cats '/';
 551   (* Further path checks: *)
 552   begin match url'.url_path with
 553       [] ->
 554         (* The path is empty: There must not be a 'param' or 'query' *)
 555         if url'.url_host <> None then begin
 556           if url'.url_param <> [] then raise Malformed_URL;
 557           if url'.url_query <> None then raise Malformed_URL;
 558         end
 559     | ["";""] ->
 560         (* This is illegal. *)
 561         raise Malformed_URL;
 562     | "" :: p' ->
 563         (* The path is absolute: always ok *)
 564         ()
 565     | _ ->
 566         (* The path is relative: there must not be a host *)
 567         if url'.url_host <> None then raise Malformed_URL;
 568   end;
 569   begin match url'.url_path with
 570       _ :: rest ->              (* "//" ambiguity *)
 571         begin match List.rev rest with
 572             _ :: rest' ->
 573               if List.exists (fun p -> p = "") rest' then
 574                 raise Malformed_URL;
 575           | [] ->
 576               ()
 577         end
 578     | [] ->
 579         ()
 580   end;
 581   (* Cache that the URL is valid: *)
 582   url'.url_validity <- true;
 583
 584   url'
 585 ;;
 586
 587
 588 let null_url =
 589   {
 590     url_syntax   = null_url_syntax;
 591     url_validity = true;
 592     url_scheme   = None;
 593     url_user     = None;
 594     url_password = None;
 595     url_host     = None;
 596     url_port     = None;
 597     url_path     = [];
 598     url_param    = [];
 599     url_query    = None;
 600     url_fragment = None;
 601     url_other    = None;
 602   }
 603 ;;
 604
 605
 606 let make_url
 607       ?(encoded = false)
 608       ?scheme
 609       ?user
 610       ?password
 611       ?host
 612       ?port
 613       ?path
 614       ?param
 615       ?query
 616       ?fragment
 617       ?other
 618       url_syntax
 619   =
 620
 621   if not (url_syntax_is_valid url_syntax) then
 622     invalid_arg "Neturl.make_url";
 623
 624   modify_url
 625     ~encoded:encoded
 626     ~syntax:url_syntax
 627     ?scheme:scheme
 628     ?user:user
 629     ?password:password
 630     ?host:host
 631     ?port:port
 632     ?path:path
 633     ?param:param
 634     ?query:query
 635     ?fragment:fragment
 636     ?other:other
 637     null_url
 638 ;;
 639
 640
 641 let remove_from_url
 642       ?(scheme = false)
 643       ?(user = false)
 644       ?(password = false)
 645       ?(host = false)
 646       ?(port = false)
 647       ?(path = false)
 648       ?(param = false)
 649       ?(query = false)
 650       ?(fragment = false)
 651       ?(other = false)
 652       url
 653   =
 654
 655   make_url
 656     ~encoded:  true
 657     ?scheme:   (if scheme   then None else url.url_scheme)
 658     ?user:     (if user     then None else url.url_user)
 659     ?password: (if password then None else url.url_password)
 660     ?host:     (if host     then None else url.url_host)
 661     ?port:     (if port     then None else url.url_port)
 662     ?path:     (if path     then None else Some url.url_path)
 663     ?param:    (if param    then None else Some url.url_param)
 664     ?query:    (if query    then None else url.url_query)
 665     ?fragment: (if fragment then None else url.url_fragment)
 666     ?other:    (if other    then None else url.url_other)
 667     url.url_syntax
 668 ;;
 669
 670
 671 let default_url
 672       ?(encoded = false)
 673       ?scheme
 674       ?user
 675       ?password
 676       ?host
 677       ?port
 678       ?(path = [])
 679       ?(param = [])
 680       ?query
 681       ?fragment
 682       ?other
 683       url
 684   =
 685
 686   let encode = Netencoding.Url.encode in
 687
 688   let enc x =
 689     if encoded then
 690       x
 691     else
 692       match x with
 693           None -> None
 694         | Some x' -> Some (encode x')
 695   in
 696
 697   let enc_list l =
 698     if encoded then
 699       l
 700     else
 701       List.map encode l
 702   in
 703
 704   let pass_if_missing current arg =
 705     match current with
 706         None -> arg
 707       | _    -> current
 708   in
 709
 710   make_url
 711     ~encoded:  true
 712     ?scheme:   (pass_if_missing url.url_scheme   scheme)
 713     ?user:     (pass_if_missing url.url_user     (enc user))
 714     ?password: (pass_if_missing url.url_password (enc password))
 715     ?host:     (pass_if_missing url.url_host     host)
 716     ?port:     (pass_if_missing url.url_port     port)
 717     ~path:     (if url.url_path  = [] then enc_list path  else url.url_path)
 718     ~param:    (if url.url_param = [] then enc_list param else url.url_param)
 719     ?query:    (pass_if_missing url.url_query    (enc query))
 720     ?fragment: (pass_if_missing url.url_fragment (enc fragment))
 721     ?other:    (pass_if_missing url.url_other    (enc other))
 722     url.url_syntax
 723 ;;
 724
 725
 726 let undefault_url
 727       ?scheme
 728       ?user
 729       ?password
 730       ?host
 731       ?port
 732       ?path
 733       ?param
 734       ?query
 735       ?fragment
 736       ?other
 737       url
 738   =
 739
 740   let remove_if_matching current arg =
 741     match current with
 742         None -> None
 743       | Some x ->
 744           (match arg with
 745                None -> current
 746              | Some x' ->
 747                  if x=x' then
 748                    None
 749                  else
 750                    current)
 751   in
 752
 753   make_url
 754     ~encoded:  true
 755     ?scheme:   (remove_if_matching url.url_scheme   scheme)
 756     ?user:     (remove_if_matching url.url_user     user)
 757     ?password: (remove_if_matching url.url_password password)
 758     ?host:     (remove_if_matching url.url_host     host)
 759     ?port:     (remove_if_matching url.url_port     port)
 760     ~path:     (match path with
 761                      None -> url.url_path
 762                    | Some x ->
 763                        if x = url.url_path then
 764                          []
 765                        else
 766                          url.url_path)
 767     ~param:    (match param with
 768                      None -> url.url_param
 769                    | Some x ->
 770                        if x = url.url_param then
 771                          []
 772                        else
 773                          url.url_param)
 774     ?query:    (remove_if_matching url.url_query    query)
 775     ?fragment: (remove_if_matching url.url_fragment fragment)
 776     ?other:    (remove_if_matching url.url_other    other)
 777     url.url_syntax
 778 ;;
 779
 780
 781 let url_provides
 782       ?(scheme = false)
 783       ?(user = false)
 784       ?(password = false)
 785       ?(host = false)
 786       ?(port = false)
 787       ?(path = false)
 788       ?(param = false)
 789       ?(query = false)
 790       ?(fragment = false)
 791       ?(other = false)
 792       url
 793   =
 794
 795   (scheme   => (url.url_scheme   <> None)) &
 796   (user     => (url.url_user     <> None)) &
 797   (password => (url.url_password <> None)) &
 798   (host     => (url.url_host     <> None)) &
 799   (port     => (url.url_port     <> None)) &
 800   (path     => (url.url_path     <> []))   &
 801   (param    => (url.url_param    <> [])) &
 802   (query    => (url.url_query    <> None)) &
 803   (fragment => (url.url_fragment <> None)) &
 804   (other    => (url.url_other    <> None))
 805 ;;
 806
 807
 808 let return_if value =
 809   match value with
 810       None -> raise Not_found
 811     | Some x -> x
 812 ;;
 813
 814
 815 let decode_if want_encoded value =
 816   let value' = return_if value in
 817   if want_encoded then
 818     value'
 819   else
 820     Netencoding.Url.decode value'     (* WARNING: not thread-safe! *)
 821 ;;
 822
 823
 824 let decode_path_if want_encoded value =
 825   if want_encoded then
 826     value
 827   else
 828     List.map Netencoding.Url.decode value     (* WARNING: not thread-safe! *)
 829 ;;
 830
 831
 832 let url_scheme                    url = return_if url.url_scheme;;
 833 let url_user     ?(encoded=false) url = decode_if encoded url.url_user;;
 834 let url_password ?(encoded=false) url = decode_if encoded url.url_password;;
 835 let url_host                      url = return_if url.url_host;;
 836 let url_port                      url = return_if url.url_port;;
 837 let url_path     ?(encoded=false) url = decode_path_if encoded url.url_path;;
 838 let url_param    ?(encoded=false) url = decode_path_if encoded url.url_param;;
 839 let url_query    ?(encoded=false) url = decode_if encoded url.url_query;;
 840 let url_fragment ?(encoded=false) url = decode_if encoded url.url_fragment;;
 841 let url_other    ?(encoded=false) url = decode_if encoded url.url_other;;
 842
 843
 844 let string_of_url url =
 845   if not (url.url_validity) then
 846     failwith "Neturl.string_of_url: URL not flagged as valid";
 847   (match url.url_scheme with
 848        None -> ""
 849      | Some s -> s ^ ":") ^
 850   (match url.url_host with
 851        None -> ""
 852      | Some host ->
 853          "//" ^
 854          (match url.url_user with
 855               None -> ""
 856             | Some user ->
 857                 user ^
 858                 (match url.url_password with
 859                      None -> ""
 860                    | Some password ->
 861                        ":" ^ password
 862                 ) ^
 863                 "@") ^
 864          host ^
 865          (match url.url_port with
 866               None -> ""
 867             | Some port ->
 868                 ":" ^ string_of_int port)) ^
 869   (match url.url_path with
 870      | [""] ->
 871          "/"
 872      | x :: p  when  url.url_scheme = None &&
 873                      url.url_host = None &&
 874                      String.contains x ':'
 875         ->
 876           (* Really a special case: The colon contained in 'x' may cause
 877            * that a prefix of 'x' is interpreted as URL scheme. In this
 878            * case, "./" is prepended (as recommended in RFC 1808, 5.3).
 879            *)
 880           "./"
 881      | _ ->
 882          ""
 883   ) ^
 884   String.concat "/" url.url_path ^
 885   (match url.url_other with
 886        None -> ""
 887      | Some other ->
 888          other) ^
 889   String.concat ""  (List.map (fun s -> ";" ^ s) url.url_param) ^
 890   (match url.url_query with
 891        None -> ""
 892      | Some query ->
 893          "?" ^ query) ^
 894   (match url.url_fragment with
 895        None -> ""
 896      | Some fragment ->
 897          "#" ^ fragment)
 898 ;;
 899
 900
 901 let url_of_string url_syntax s =
 902   let l = String.length s in
 903   let recognized x = x <> Url_part_not_recognized in
 904
 905   let rec collect_words terminators eof_char cats k =
 906     (* Collect words as recognized by 'cats', starting at position 'k' in
 907      * 's'. Collection stops if one the characters listed in 'terminators'
 908      * is found. If the end of the string is reached, it is treated as
 909      * 'eof_char'.
 910      *)
 911     let k' = scan_url_part s k l cats url_syntax.url_accepts_8bits in
 912              (* or raise Malformed_URL *)
 913     let word, sep =
 914       String.sub s k (k'-k), (if k'<l then s.[k'] else eof_char) in
 915     if List.mem sep terminators then
 916       [word, sep], k'
 917     else
 918       let word_sep_list', k'' =
 919         collect_words terminators eof_char cats (k'+1) in
 920       ((word, sep) :: word_sep_list'), k''
 921   in
 922
 923   (* Try to extract the scheme name: *)
 924   let scheme, k1 =
 925     if recognized url_syntax.url_enable_scheme then
 926       try
 927         let k = scan_url_part s 0 l scheme_cats false in
 928         (* or raise Malformed_URL *)
 929         if k = l then raise Malformed_URL;
 930         assert (s.[k] = ':');
 931         Some (String.sub s 0 k), (k+1)
 932       with
 933           Malformed_URL -> None, 0
 934     else
 935       None, 0
 936   in
 937
 938   (* If there is a "//", a host will follow: *)
 939   let host, port, user, password, k2 =
 940     if recognized url_syntax.url_enable_host  &&
 941        k1 + 2 <= l  &&  s.[k1]='/'  && s.[k1+1]='/' then begin
 942
 943       let word_sep_list, k' = collect_words [ '/'; '#' ] '/' login_cats (k1+2)
 944       in
 945           (* or raise Malformed_URL *)
 946
 947       let int x =
 948         try int_of_string x with _ -> raise Malformed_URL in
 949
 950       match word_sep_list with
 951           [ host, ('/'|'#') ] ->
 952             Some host, None, None, None, k'
 953         | [ host, ':'; port, ('/'|'#') ] ->
 954             Some host, Some (int port), None, None, k'
 955         | [ user, '@'; host, ('/'|'#') ] ->
 956             Some host, None, Some user, None, k'
 957         | [ user, '@'; host, ':'; port, ('/'|'#') ] ->
 958             Some host, Some (int port), Some user, None, k'
 959         | [ user, ':'; password, '@'; host, ('/'|'#') ] ->
 960             Some host, None, Some user, Some password, k'
 961         | [ user, ':'; password, '@'; host, ':'; port, ('/'|'#') ] ->
 962             Some host, Some (int port), Some user, Some password, k'
 963         | _ ->
 964             raise Malformed_URL
 965     end
 966     else
 967       None, None, None, None, k1
 968   in
 969
 970   let path, k3 =
 971     if recognized url_syntax.url_enable_path  &&
 972        k2 < l  (*  &&  s.[k2]='/'  *)
 973     then begin
 974       let cats = path_cats_from_syntax url_syntax [ '/' ] in
 975       let seps = separators_from_syntax url_syntax in
 976
 977       (* Note: '>' is not allowed within URLs; because of this we can use
 978        * it as end-of-string character.
 979        *)
 980
 981       let word_sep_list, k' = collect_words ('>'::seps) '>' cats k2 in
 982           (* or raise Malformed_URL *)
 983       match word_sep_list with
 984           [ "", '/'; "", _ ] ->
 985             [ "" ], k'
 986         | [ "", _ ] ->
 987             [], k'
 988         | _ ->
 989             List.map fst word_sep_list, k'
 990     end
 991     else begin
 992       (* If there is a single '/': skip it *)
 993       if not (recognized url_syntax.url_enable_other) &&
 994          k2 < l  &&  s.[k2]='/'
 995       then
 996         [], (k2+1)
 997       else
 998         [], k2
 999     end
1000   in
1001
1002   let other, k4 =
1003     if recognized url_syntax.url_enable_other  &&
1004        k3 < l
1005     then begin
1006
1007       let cats = other_cats_from_syntax url_syntax in
1008
1009       (* Note: '>' is not allowed within URLs; because of this we can use
1010        * it as end-of-string character.
1011        *)
1012
1013       let word_sep_list, k' = collect_words ['>';'#'] '>' cats k3 in
1014           (* or raise Malformed_URL *)
1015
1016       match word_sep_list with
1017           [ other, _ ] -> Some other, k'
1018         | _ -> assert false
1019     end
1020     else
1021       None, k3
1022   in
1023
1024   let param, k5 =
1025     if recognized url_syntax.url_enable_param  &&
1026        k4 < l  &&  s.[k4]=';'
1027     then begin
1028       let cats  = path_cats_from_syntax url_syntax [] in
1029       let seps  = separators_from_syntax url_syntax in
1030       let seps' = List.filter (fun c -> c <> ';') seps in
1031
1032       (* Note: '>' is not allowed within URLs; because of this we can use
1033        * it as end-of-string character.
1034        *)
1035
1036       let word_sep_list, k' = collect_words ('>'::seps') '>' cats (k4+1) in
1037           (* or raise Malformed_URL *)
1038
1039       List.map fst word_sep_list, k'
1040     end
1041     else
1042       [], k4
1043   in
1044
1045   let query, k6 =
1046     if recognized url_syntax.url_enable_query  &&
1047        k5 < l  &&  s.[k5]='?'
1048     then begin
1049       let cats  = path_cats_from_syntax url_syntax [] in
1050       let seps  = separators_from_syntax url_syntax in
1051
1052       (* Note: '>' is not allowed within URLs; because of this we can use
1053        * it as end-of-string character.
1054        *)
1055
1056       let word_sep_list, k' = collect_words ('>'::seps) '>' cats (k5+1) in
1057           (* or raise Malformed_URL *)
1058
1059       match word_sep_list with
1060           [ query, _ ] -> Some query, k'
1061         | _ -> assert false
1062     end
1063     else
1064       None, k5
1065   in
1066
1067   let fragment, k7 =
1068     if recognized url_syntax.url_enable_fragment  &&
1069        k6 < l  &&  s.[k6]='#'
1070     then begin
1071       let cats  = path_cats_from_syntax url_syntax [] in
1072       let seps  = separators_from_syntax url_syntax in
1073
1074       (* Note: '>' is not allowed within URLs; because of this we can use
1075        * it as end-of-string character.
1076        *)
1077
1078       let word_sep_list, k' = collect_words ('>'::seps) '>' cats (k6+1) in
1079           (* or raise Malformed_URL *)
1080
1081       match word_sep_list with
1082           [ fragment, _ ] -> Some fragment, k'
1083         | _ -> assert false
1084     end
1085     else
1086       None, k6
1087   in
1088
1089   if k7 <> l then raise Malformed_URL;
1090
1091   make_url
1092     ~encoded:true
1093     ?scheme:scheme
1094     ?user:user
1095     ?password:password
1096     ?host:host
1097     ?port:port
1098     ~path:path
1099     ~param:param
1100     ?query:query
1101     ?fragment:fragment
1102     ?other:other
1103     url_syntax
1104 ;;
1105
1106
1107 let split_path s =
1108   let l = String.length s in
1109   let rec collect_words k =
1110     let k' =
1111       try
1112         String.index_from s k '/'
1113       with
1114           Not_found -> l
1115     in
1116     let word = String.sub s k (k'-k) in
1117     if k' >= l then
1118       [word]
1119     else
1120       word :: collect_words (k'+1)
1121   in
1122   match collect_words 0 with
1123       [ "" ] -> []
1124     | [ "";"" ] -> [ "" ]
1125     | other -> other
1126 ;;
1127
1128
1129 let join_path l =
1130   match l with
1131       [ "" ] -> "/"
1132     | _      -> String.concat "/" l;;
1133
1134
1135 let norm_path l =
1136
1137   let rec remove_slash_slash l first =
1138     match l with
1139       | [ "" ] ->
1140           [ "" ]
1141       | [ ""; "" ] when first ->
1142           [ "" ]
1143       | "" :: l' when not first ->
1144           remove_slash_slash l' false
1145       | x :: l' ->
1146           x :: remove_slash_slash l' false
1147       | [] ->
1148           []
1149   in
1150
1151   let rec remove_dot l first =
1152     match l with
1153       | ([ "." ] | ["."; ""]) ->
1154           if first then [] else [ "" ]
1155       | "." :: x :: l' ->
1156           remove_dot (x :: l') false
1157       | x :: l' ->
1158           x :: remove_dot l' false
1159       | [] ->
1160           []
1161   in
1162
1163   let rec remove_dot_dot_once l first =
1164     match l with
1165         x :: ".." :: [] when x <> "" && x <> ".." && not first ->
1166           [ "" ]
1167       | x :: ".." :: l' when x <> "" && x <> ".." ->
1168           l'
1169       | x :: l' ->
1170           x :: remove_dot_dot_once l' false
1171       | [] ->
1172           raise Not_found
1173   in
1174
1175   let rec remove_dot_dot l =
1176     try
1177       let l' = remove_dot_dot_once l true in
1178       remove_dot_dot l'
1179     with
1180         Not_found -> l
1181   in
1182
1183   let l' = remove_dot_dot (remove_dot (remove_slash_slash l true) true) in
1184   match l' with
1185       [".."] -> [".."; ""]
1186     | ["";""] -> [ "" ]
1187     | _      -> l'
1188 ;;
1189
1190
1191 let apply_relative_url baseurl relurl =
1192   if not (baseurl.url_validity) or not (relurl.url_validity) then
1193     failwith "Neturl.apply_relative_url: URL not flagged as valid";
1194
1195   if relurl.url_scheme <> None then
1196     modify_url
1197       ~syntax:baseurl.url_syntax           (* inherit syntax *)
1198       relurl
1199   else
1200     if relurl.url_host <> None then
1201       modify_url
1202         ~syntax:baseurl.url_syntax         (* inherit syntax and scheme *)
1203         ?scheme:baseurl.url_scheme
1204         relurl
1205     else
1206       match relurl.url_path with
1207           "" :: other ->
1208             (* An absolute path *)
1209             modify_url
1210               ~syntax:baseurl.url_syntax   (* inherit syntax, scheme, and *)
1211               ~encoded:true
1212               ?scheme:baseurl.url_scheme   (* login info *)
1213               ?host:baseurl.url_host
1214               ?port:baseurl.url_port
1215               ?user:baseurl.url_user
1216               ?password:baseurl.url_password
1217               relurl
1218         | [] ->
1219             (* Empty: Inherit also path, params, query, and fragment *)
1220             let new_params, new_query, new_fragment =
1221               match relurl.url_param, relurl.url_query, relurl.url_fragment
1222               with
1223                   [], None, None ->
1224                     (* Inherit all three *)
1225                     baseurl.url_param, baseurl.url_query, baseurl.url_fragment
1226                 | [], None, f ->
1227                     (* Inherit params and query *)
1228                     baseurl.url_param, baseurl.url_query, f
1229                 | [], q, f ->
1230                     (* Inherit params *)
1231                     baseurl.url_param, q, f
1232                 | p, q, f ->
1233                     (* Inherit none of them *)
1234                     p, q, f
1235             in
1236             modify_url
1237               ~syntax:baseurl.url_syntax
1238               ~encoded:true
1239               ?scheme:baseurl.url_scheme
1240               ?host:baseurl.url_host
1241               ?port:baseurl.url_port
1242               ?user:baseurl.url_user
1243               ?password:baseurl.url_password
1244               ~path:baseurl.url_path
1245               ~param:new_params
1246               ?query:new_query
1247               ?fragment:new_fragment
1248               relurl
1249         | relpath ->
1250             (* A relative path *)
1251             let rec change_path basepath =
1252               match basepath with
1253                 | [] ->
1254                     relpath
1255                 | [ x ] ->
1256                     relpath
1257                 | x :: basepath' ->
1258                     x :: change_path basepath'
1259             in
1260             let new_path = norm_path (change_path baseurl.url_path) in
1261             modify_url
1262               ~syntax:baseurl.url_syntax   (* inherit syntax, scheme, and *)
1263               ~encoded:true
1264               ?scheme:baseurl.url_scheme   (* login info *)
1265               ?host:baseurl.url_host
1266               ?port:baseurl.url_port
1267               ?user:baseurl.url_user
1268               ?password:baseurl.url_password
1269               ~path:new_path               (* and change path *)
1270               relurl
1271
1272 ;;
1273
1274
1275 let print_url url =
1276   Format.print_string ("<URL:" ^ string_of_url url ^ ">")
1277 ;;
1278
1279
1280 (* ======================================================================
1281  * History:
1282  *
1283  * $Log$
1284  * Revision 1.1  2000/11/17 09:57:28  lpadovan
1285  * Initial revision
1286  *
1287  * Revision 1.4  2000/07/04 21:50:51  gerd
1288  *      Fixed typo.
1289  *
1290  * Revision 1.3  2000/06/26 22:57:49  gerd
1291  *      Change: The record 'url_syntax' has an additional component
1292  * 'url_accepts_8bits'. Setting this option to 'true' causes that
1293  * the bytes >= 0x80 are no longer rejected.
1294  *
1295  * Revision 1.2  2000/06/25 19:39:48  gerd
1296  *      Lots of Bugfixes.
1297  *
1298  * Revision 1.1  2000/06/24 20:19:59  gerd
1299  *      Initial revision.
1300  *
1301  *
1302  *)