(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_uri.ml

  Copyright (c) 2003-2006, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*)

open Cf_flow.Op
open Cf_parser.Op
open Cf_lex.Op

let ch_is_up_alpha_ = function 'A'..'Z' -> true | _ -> false
let ch_is_dn_alpha_ = function 'a'..'z' -> true | _ -> false
let ch_is_digit_ = function '0'..'9' -> true | _ -> false
let ch_is_hex_ = function ('0'..'9' | 'A'..'F' | 'a'..'f') -> true | _ -> false

let ch_is_reserved_ = function
    | (';' | '/' | '?' | ':' | '@' | '&' | '=' | '+' | '$' | ',') -> true
    | _ -> false

let ch_is_reserved_no_slash_ = function
    | '/' -> false
    | c -> ch_is_reserved_ c

let ch_is_reserved_in_rel_segment_ = function
    | ('/' | '?' | ':') -> false
    | c -> ch_is_reserved_ c

let ch_is_reserved_in_rel_segment_no_semi_ = function
    | ';' -> false
    | c -> ch_is_reserved_in_rel_segment_ c

let ch_is_reserved_in_pchar_ = function
    | ('/' | '?' | ';') -> false
    | c -> ch_is_reserved_ c

let ch_is_reserved_in_userinfo_ = function
    | ('/' | '?') -> false
    | c -> ch_is_reserved_ c

let ch_is_mark_ = function
    | ('-' | '_' | '.' | '!' | '~' | '*' | '\'' | '(' | ')') -> true
    | _ -> false

let ch_is_unreserved_ = function
    | 'A'..'Z'
    | 'a'..'z'
    | '0'..'9' ->
        true
    | ch ->
        ch_is_mark_ ch

let x_up_alpha_ = !^ch_is_up_alpha_
let x_dn_alpha_ = !^ch_is_dn_alpha_
let x_digit_ = !^ch_is_digit_
let x_hex_ = !^ch_is_hex_
let x_alpha_ = x_up_alpha_ $| x_dn_alpha_
let x_alphanum_ = x_alpha_ $| x_digit_

let x_plus_ = !:'+'
let x_hyphen_ = !:'-'
let x_dot_ = !:'.'
let x_percent_ = !:'%'

let x_escaped_ = x_percent_ $& x_hex_ $& x_hex_
let x_unreserved_ = x_alphanum_ $| !^ch_is_mark_
let x_reserved_ = !^ch_is_reserved_

let x_uric_ = x_reserved_ $| x_unreserved_ $| x_escaped_
let x_uric_no_slash_ =
    !^ch_is_reserved_no_slash_ $| x_unreserved_ $| x_escaped_

let x_pchar_ = !^ch_is_reserved_in_pchar_ $| x_unreserved_ $| x_escaped_

(*
let x_semicolon_ = !:';'
let x_query_ = !:'?'
let x_colon_ = !:':'
let x_at_ = !:'@'
let x_ampersand_ = !:'&'
let x_equal_ = !:'='
let x_dollar_ = !:'$'
let x_comma_ = !:','
let x_bang_ = !:'!'
let x_tilde_ = !:'~'
let x_star_ = !:'*'
let x_tick_ = !:'\''
let x_underscore_ = !:'_'
let x_lparen_ = !:'('
let x_rparen_ = !:')'
*)

let int_of_A_ = (int_of_char 'A') - 10
let int_of_a_ = (int_of_char 'a') - 10
let int_of_0_ = int_of_char '0'

let int_of_hex_char_ c =
    let n0 =
        match c with
        | 'A'..'F' -> int_of_A_
        | 'a'..'f' -> int_of_a_
        | '0'..'9' -> int_of_0_ 
        | _ -> assert (not true); 0
    in
    (int_of_char c) - n0

let hex_char_of_int_ n =
    assert (n >= 0 && n < 16);
    char_of_int (n + (if n > 9 then int_of_a_ else int_of_0_))

let rec w_escape_ =
    let rec loop f c =
        let self = w_escape_ f in
        if (ch_is_unreserved_ c) or (f c) then
            Cf_flow.P (c, self)
        else begin
            let n = int_of_char c in
            let c1 = hex_char_of_int_ (n land 0xF) in
            let z1 = Lazy.lazy_from_val (Cf_flow.P (c1, self)) in
            let c0 = hex_char_of_int_ ((n land 0xF0) lsr 4) in
            let z0 = Lazy.lazy_from_val (Cf_flow.P (c0, z1)) in
            Cf_flow.P ('%', z0)
        end
    in
    fun f ->
        Lazy.lazy_from_val (Cf_flow.Q (loop f))

let rec w_unescape_ =
    let rec loop c =
        let self = w_unescape_ () in
        match c with
        | '%' ->
            Cf_flow.Q begin fun c ->
                let n0 = int_of_hex_char_ c in
                Cf_flow.Q begin fun c ->
                    let n1 = int_of_hex_char_ c in
                    Cf_flow.P (char_of_int (n0 * 16 + n1), self)
                end
            end
        | x ->
            Cf_flow.P (x, self)
    in
    fun () ->
        Lazy.lazy_from_val (Cf_flow.Q loop)

let escape ?(allow = (fun _ -> false)) =
    let w = w_escape_ allow in
    fun s -> Cf_seq.to_string (Cf_flow.commute w (Cf_seq.of_string s))

let unescape s =
    Cf_seq.to_string (Cf_flow.commute (w_unescape_ ()) (Cf_seq.of_string s))

let p_colon_ s = ?.':' s
let p_semicolon_ s = ?.';' s
let p_slash_ s = ?.'/' s
let p_dot_ s = ?.'.' s
let p_at_ s = ?.'@' s

let p_slashslash_ s =
    let m =
        ?.'/' >>= fun _ ->
        ?.'/' >>= fun _ ->
        ~:()
    in
    m s

let p_scheme_ = Cf_lex.create begin
    x_alpha_ $& !*(x_alpha_ $| x_digit_ $| x_plus_ $| x_hyphen_ $| x_dot_) $>
    String.lowercase
end

let p_opaque_part_ =
    Cf_lex.create (x_uric_ $& !*x_uric_no_slash_ $> unescape)

let p_uric_string_ =
    Cf_lex.create (!*x_uric_ $> (fun x -> (x : string)))

let p_hostname_ =
    let x_label_suffix_ = !*(x_alphanum_ $| x_hyphen_) $& x_alphanum_ in
    let x_toplabel_ = x_alpha_ $| (x_alpha_ $& x_label_suffix_) in
    let x_domainlabel_ = x_alphanum_ $| (x_alphanum_ $& x_label_suffix_) in
    let x_hostname_ =
        !*(x_domainlabel_ $& x_dot_) $& x_toplabel_ $& !?x_dot_
    in
    Cf_lex.create (x_hostname_ $> String.lowercase)

let p_ipv4_addr_ =
    let x_num = !+ !^ch_is_digit_ in
    let x_ip4_addr = x_num $& x_num $& x_num $& x_num in
    let action lim s =
        let s1 = Cf_seq.limit lim s in
        match Cf_ip4_addr.pton (Cf_seq.to_string s1) with
        | Some addr -> Some (addr, Cf_seq.shift lim s)
        | None -> None
        
    in    
    Cf_lex.create (x_ip4_addr $@ action)

type host =
    | H_hostname of string
    | H_ip4_addr of Cf_ip4_addr.opaque Cf_ip4_addr.t

let p_userinfo_ =
    Cf_lex.create begin
        x_unreserved_ $| x_escaped_ $| !^ch_is_reserved_in_userinfo_ $>
        unescape
    end

type server = {
    srv_user: string option;
    srv_host: host;
    srv_port: int option;
}

type authority =
    | A_server of server option
    | A_reg_name of string

let p_port_ = Cf_lex.create ((!* !^ch_is_digit_) $> int_of_string)

let p_server_ =
    let p_userinfo_at_ =
        p_userinfo_ >>= fun ui ->
        p_at_ >>= fun _ ->
        ~:ui
    in
    let p_userinfo_opt_ = ?/ p_userinfo_at_ in
    let p_host_ = Cf_parser.alt [
        (p_ipv4_addr_ >>= fun addr -> ~:(H_ip4_addr addr));
        (p_hostname_ >>= fun name -> ~:(H_hostname name));
    ] in
    let p_port_opt_ = ?/ (p_colon_ >>= fun _ -> p_port_) in
    ?/ begin
        p_userinfo_opt_ >>= fun user ->
        p_host_ >>= fun host ->
        p_port_opt_ >>= fun port ->
        ~:{
            srv_user = user;
            srv_host = host;
            srv_port = port;
        }
    end

let p_reg_name_ =
    Cf_lex.create begin
        !+(x_unreserved_ $| x_escaped_ $| !^ch_is_reserved_in_userinfo_) $>
        unescape
    end

let p_authority_ = Cf_parser.alt [
    (p_server_ >>= fun srv -> ~:(A_server srv));
    (p_reg_name_ >>= fun rn -> ~:(A_reg_name rn));
]

let p_pchar_star_ = Cf_lex.create (!* x_pchar_ $> unescape)

let p_param_ = p_semicolon_ >>= fun _ -> p_pchar_star_

type segment = {
    seg_name: string;
    seg_params: string list;
}

let p_segment_ =
    p_pchar_star_ >>= fun name ->
    ?*p_param_ >>= fun params ->
    ~:{ seg_name = name; seg_params = params }

let p_path_segments_ =
    let p_list_ = p_slash_ >>= fun _ -> p_segment_ in
    p_segment_ >>= fun hd ->
    ?*p_list_ >>= fun tl ->
    ~:(hd, tl)

let p_abs_path_ = p_slash_ >>= fun _ -> p_path_segments_ 

let p_rel_segment_no_semi_ = Cf_lex.create begin
    let reserved = !^ch_is_reserved_in_rel_segment_no_semi_ in
    !+ (x_unreserved_ $| x_escaped_ $| reserved) $> unescape;
end

let p_rel_segment_nonempty_ =
    p_rel_segment_no_semi_ >>= fun name ->
    ?*p_param_ >>= fun params ->
    ~:{ seg_name = name; seg_params = params }

let p_rel_segment_empty_with_params_ =
    ?+p_param_ >>= fun (param_hd, param_tl) ->
    ~:{ seg_name = ""; seg_params = param_hd :: param_tl }

let p_rel_segment_ = Cf_parser.alt [
    p_rel_segment_nonempty_;
    p_rel_segment_empty_with_params_;
]

let p_rel_path_ =
    p_rel_segment_ >>= fun rseg ->
    ?/ p_abs_path_ >>= fun absopt ->
    ~:begin
        match rseg, absopt with
        | { seg_name = ""; seg_params = [] }, Some (hd, tl) -> hd :: tl
        | hd, None -> hd :: []
        | hd, Some (tl1, tlx) -> hd :: tl1 :: tlx
    end

type net_path = {
    net_authority: authority;
    net_path: segment list;
}

let p_net_path_ =
    p_slashslash_ >>= fun _ ->
    p_authority_ >>= fun a ->
    ?/ p_abs_path_ >>= fun p_opt ->
    let p = match p_opt with None -> [] | Some (hd, tl) -> hd :: tl in
    ~:{ net_authority = a; net_path = p }

type net = [ `Net of net_path ]
type abs = [ `Abs of segment * segment list ]
type rel = [ `Rel of segment list ]

type path = [ net | abs | rel ]

let p_query_ = ?/ (?.'?' >>= fun _ -> p_uric_string_)

let p_fragment_ = ?/ begin
    ?.'#' >>= fun _ ->
    p_uric_string_ >>= fun frag ->
    ~:(unescape frag)
end

type abs_special_hier = {
    abs_hier_path: [ net | abs ];
    abs_hier_query: string option;
}

type abs_special =
    | S_hier of abs_special_hier
    | S_opaque of string

type absolute = {
    abs_scheme: string;
    abs_special: abs_special;
}

let p_hier_part_ =
    let p_path_ = Cf_parser.alt [
        (p_net_path_ >>= fun p -> ~:(`Net p));
        (p_abs_path_ >>= fun p -> ~:(`Abs p));
    ] in
    p_path_ >>= fun path ->
    p_query_ >>= fun query ->
    ~:{ abs_hier_path = path; abs_hier_query = query }

let p_absolute_uri_ =
    let p_abs_special_ = Cf_parser.alt [
        (p_hier_part_ >>= fun x -> ~:(S_hier x));
        (p_opaque_part_ >>= fun x -> ~:(S_opaque x));
    ] in
    p_scheme_ >>= fun scheme ->
    p_colon_ >>= fun _ ->
    p_abs_special_ >>= fun special ->
    ~:{ abs_scheme = scheme; abs_special = special }

type relative = {
    rel_path: [ net | abs | rel ];
    rel_query: string option;
}

let empty_segment_ = { seg_params = []; seg_name = "" }

let p_relative_uri_ =
    let p_path_ = Cf_parser.alt [
        (p_net_path_ >>= fun x -> ~:(`Net x));
        (p_abs_path_ >>= fun x -> ~:(`Abs x));
        (p_rel_path_ >>= fun x -> ~:(`Rel x));
    ] in
    ?/ p_path_ >>= fun path ->
    p_query_ >>= fun query ->
    let path =
        match path, query with
        | None, Some _ -> `Rel (empty_segment_ :: [])
        | None, None -> `Rel []
        | Some path, _ -> path
    in
    ~:{ rel_path = path; rel_query = query }

type t =
    | A of absolute
    | R of relative

exception Rel_undefined

let normalize_segment_revlist_ =
    let dotdot_ = ".." in
    let rec push_loop acc = function
        | { seg_params = []; seg_name = "." } :: tl ->
            push_loop acc tl
        | { seg_params = []; seg_name = ".." } :: (seg :: tl' as tl) ->
            if seg.seg_params <> [] || seg.seg_name <> dotdot_ then
                push_loop acc tl'
            else
                push_loop (succ acc) tl
        | x ->
            acc, x
    in
    let rec pop_loop acc = function
        | _ :: x when acc > 0 -> pop_loop (pred acc) x
        | x when acc = 0 -> x
        | _ -> raise Rel_undefined
    in
    let rec loop result = function
        | [] -> result
        | x ->
            let n, x = push_loop 0 x in
            match pop_loop n x with
            | [] -> result
            | hd :: tl ->
                loop (hd :: result) tl
    in
    fun x ->
        List.rev (loop [] x)

let refer_relative_to_absolute_path_ base rel =
    let base =
        match base with
        | [] -> []
        | _ :: [] -> base
        | _ :: _ ->
            match List.rev base with
            | [] -> assert (not true); []
            | _ :: x -> x
    in
    let rel =
        match rel with
        | { seg_name = "."; seg_params = [] } :: [] ->
            empty_segment_ :: []
        | { seg_name = ".."; seg_params = [] } as dotdot :: [] ->
            dotdot :: empty_segment_ :: []
        | _ ->
            rel
    in
    let revpath = List.rev_append rel base in
    let revpath = normalize_segment_revlist_ revpath in
    match List.rev revpath with
    | [] -> empty_segment_, []
    | { seg_name = ".." } :: _ -> raise Rel_undefined
    | hd :: tl -> hd, tl

let refer_to_base_abs_path_ ~base:(`Abs abs) ~rel =
    match (rel.rel_path :> path) with
    | `Net net -> `Net net
    | `Abs abs -> `Abs abs
    | `Rel rel ->
        let abs_hd, abs_tl = abs in
        `Abs (refer_relative_to_absolute_path_ (abs_hd :: abs_tl) rel)

let refer_to_base_net_path_ ~base:(`Net net) ~rel =
    match (rel.rel_path :> path) with
    | `Net net -> `Net net
    | `Abs (hd, tl) -> `Net { net with net_path = hd :: tl }
    | `Rel rel ->
        let path_hd, path_tl =
            refer_relative_to_absolute_path_ net.net_path rel
        in
        `Net { net with net_path = path_hd :: path_tl }

let refer_to_base ~base ~rel =
    match base.abs_special with
    | S_opaque _ ->
        invalid_arg "Cf_uri.refer_to_base: base URI is opaque."
    | S_hier abs_hier ->
        let path =
            match abs_hier.abs_hier_path with
            | `Net _ as base -> refer_to_base_net_path_ ~base ~rel
            | `Abs _ as base -> refer_to_base_abs_path_ ~base ~rel
        in
        let hier = { abs_hier_path = path; abs_hier_query = rel.rel_query } in
        { base with abs_special = S_hier hier }

let cursor0_ = new Cf_parser.cursor 0

let p_uri_ = Cf_parser.alt [
    (p_absolute_uri_ >>= fun x -> ~:(A x));
    (p_relative_uri_ >>= fun x -> ~:(R x));
]

let message_to_uri =
    let p =
        p_uri_ >>= fun x ->
        Cf_parser.fin >>= fun _ ->
        ~:x
    in
    fun m ->
        match p (Cf_message.to_seq m) with
        | None -> invalid_arg "Cf_uri.message_to_uri: syntax error"
        | Some (uri, _) -> uri

let message_to_absolute_uri ~base message =
    match message_to_uri message with
    | R rel -> refer_to_base ~base ~rel
    | A abs -> abs

type reference = {
    ref_uri: t;
    ref_fragment: string option;
}

let p_uri_reference_ =
    p_uri_ >>= fun uri ->
    p_fragment_ >>= fun frag ->
    ~:{ ref_uri = uri; ref_fragment = frag }

let message_to_uri_reference =
    let p =
        p_uri_reference_ >>= fun x ->
        Cf_parser.fin >>= fun _ ->
        ~:x
    in
    fun m ->
        match p (Cf_message.to_seq m) with
        | None -> invalid_arg "Cf_uri.message_to_uri_reference: syntax error"
        | Some (uriref, _) -> uriref

let message_to_absolute_uri_reference ~base message =
    let uriref = message_to_uri_reference message in
    match uriref.ref_uri with
    | A _ ->
        uriref
    | R rel->
        let uri =
            match rel.rel_path with
            | `Rel [] when rel.rel_query = None -> base
            | _ -> refer_to_base ~base ~rel
        in
        { uriref with ref_uri = A uri }

let emit_host pp = function
    | H_hostname name -> Format.pp_print_string pp (String.lowercase name)
    | H_ip4_addr addr -> Format.pp_print_string pp (Cf_ip4_addr.ntop addr)

let emit_server =
    let emit_user pp = function
        | None -> ()
        | Some s ->
            Format.pp_print_string pp s;
            Format.pp_print_char pp '@'
    and emit_port pp = function
        | None -> ()
        | Some n ->
            Format.pp_print_int pp n;
            Format.pp_print_char pp ':'
    in
    fun pp srv ->
        emit_user pp srv.srv_user;
        emit_host pp srv.srv_host;
        emit_port pp srv.srv_port

let emit_segment_0_ ~allow =
    let esc_ = escape ~allow in
    let rec loop pp = function
        | [] -> ()
        | hd :: tl ->
            Format.pp_print_char pp ';';
            Format.pp_print_string pp (esc_ hd);
            loop pp tl
    in
    fun pp seg ->
        Format.pp_print_string pp (esc_ seg.seg_name);
        loop pp seg.seg_params    

let emit_segment_ =
    emit_segment_0_ ~allow:ch_is_reserved_in_pchar_

let emit_rel_segment_ =
    emit_segment_0_ ~allow:ch_is_reserved_in_rel_segment_no_semi_

let rec emit_segment_list_ pp = function
    | [] -> ()
    | hd :: tl ->
        Format.pp_print_char pp '/';
        emit_segment_ pp hd;
        emit_segment_list_ pp tl

let emit_authority =
    let esc_ name = escape ~allow:ch_is_reserved_in_userinfo_ name in
    fun pp auth ->
        match auth with
        | A_server None -> ()
        | A_server (Some srv) -> emit_server pp srv
        | A_reg_name name -> Format.pp_print_string pp (esc_ name)

let emit_net_path_ pp net =
    emit_authority pp net.net_authority;
    emit_segment_list_ pp net.net_path

let emit_path pp = function
    | `Net net ->
        Format.pp_print_char pp '/';
        Format.pp_print_char pp '/';
        emit_net_path_ pp net
    | `Abs (hd, tl) ->
        emit_segment_list_  pp (hd :: tl)
    | `Rel x ->
        match x with
        | [] -> ()
        | hd :: tl ->
            emit_rel_segment_ pp hd;
            emit_segment_list_ pp tl

let emit_abs_special_hier_ =
    fun pp abs_hier ->
        emit_path pp abs_hier.abs_hier_path;
        match abs_hier.abs_hier_query with
        | None -> ()
        | Some query ->
            Format.pp_print_char pp '?';
            Format.pp_print_string pp query

let emit_abs_special =
    let slash_ = "%2f" in
    let esc_ s = escape ~allow:ch_is_reserved_ s in
    fun pp abs ->
        match abs with
        | S_hier abs_hier ->
            emit_abs_special_hier_ pp abs_hier
        | S_opaque opaque ->
            let len = String.length opaque in
            if len > 0 then
                if (String.unsafe_get opaque 0) = '/' then begin
                    Format.pp_print_string pp slash_;
                    if len > 1 then
                        let opaque = String.sub opaque 1 (pred len) in
                        Format.pp_print_string pp opaque
                end
                else
                    Format.pp_print_string pp (esc_ opaque)

let emit_absolute_ pp abs =
    Format.pp_print_string pp abs.abs_scheme;
    Format.pp_print_char pp ':';
    emit_abs_special pp abs.abs_special

let emit_relative_ pp rel =
    emit_path pp rel.rel_path;
    match rel.rel_query with
    | None -> ()
    | Some query ->
        Format.pp_print_char pp '?';
        Format.pp_print_string pp query

let emit_uri pp = function
    | A abs -> emit_absolute_ pp abs
    | R rel -> emit_relative_ pp rel

let emit_uri_reference =
    let esc_ fragment = escape ~allow:ch_is_reserved_ fragment in
    fun pp uriref ->
        emit_uri pp uriref.ref_uri;
        match uriref.ref_fragment with
        | None -> ()
        | Some fragment ->
            Format.pp_print_char pp '#';
            Format.pp_print_string pp (esc_ fragment)

let message_of_uri uri =
    let b = Buffer.create 80 in
    let pp = Format.formatter_of_buffer b in
    emit_uri pp uri;
    Format.pp_print_flush pp ();
    let s = Buffer.contents b in
    Cf_message.create s

let message_of_uri_reference uriref =
    let b = Buffer.create 80 in
    let pp = Format.formatter_of_buffer b in
    emit_uri_reference pp uriref;
    Format.pp_print_flush pp ();
    let s = Buffer.contents b in
    Cf_message.create s

;;
Gc.compact ()

(*--- End of File [ cf_uri.ml ] ---*)
