(* Ocsigen
 * http://www.ocsigen.org
 * Copyright (C) 2010 Vincent Balat
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)

open Js_of_ocaml
open Eliom_lib

exception Looping_redirection
exception Failed_request of int
exception Program_terminated
exception Non_xml_content

module XmlHttpRequest = Js_of_ocaml_lwt.XmlHttpRequest

let section = Lwt_log.Section.make "eliom:request"
(* == ... *)

let max_redirection_level = 12

let short_url_re =
  new%js Js.regExp (Js.bytestring "^([^\\?]*)(\\?(.*))?$")

let get_cookie_info_for_uri_js uri_js =
  match Url.url_of_string (Js.to_string uri_js) with
    | None -> (* Decoding failed *)
      (Js.Opt.case (short_url_re##(exec uri_js))
         (fun () -> assert false)
         (fun res ->
            let match_result = Js.match_result res in
            let path =
              Url.path_of_path_string
                (Js.to_string
                   (Js.Optdef.get (Js.array_get match_result 1)
                      (fun () -> assert false)))
            in
            let path = match path with
              | ""::_ -> path (* absolute *)
              | _ -> Eliom_common_base.make_actual_path
                       (Eliom_request_info.get_csp_original_full_path () @ path)
            in
            (Eliom_request_info.get_csp_ssl (), path)
         )
      )
    | Some (Url.Https { Url.hu_path = path }) -> (true,  path)
    | Some (Url.Http  { Url.hu_path = path }) -> (false, path)
    | Some (Url.File  { Url.fu_path = path }) -> (false, path)

let get_cookie_info_for_uri uri =
  let uri_js = Js.bytestring uri in
  get_cookie_info_for_uri_js uri_js


type 'a result = XmlHttpRequest.http_frame -> 'a

let xml_result x =
  match x.XmlHttpRequest.content_xml () with
    | None -> raise Non_xml_content
    | Some v -> v

let string_result x = x.XmlHttpRequest.content

(*TODO: use Url.Current.set *)
let redirect_get ?window_name ?window_features url =
  match window_name with
  | None ->
    Dom_html.window##.location##.href := Js.string url
  | Some window_name ->
    ignore (Dom_html.window##(
      open_ (Js.string url) (Js.string window_name)
        (Js.Opt.map (Js.Opt.option window_features) Js.string)
    ))

let redirect_post ?window_name url params =
  let f = Dom_html.createForm Dom_html.document in
  f##.action := Js.string url;
  f##._method := Js.string "post";
  (match window_name with None -> () | Some wn -> f##.target := Js.string wn);
  List.iter
    (fun (n, v) ->
      match v with
        | `String v ->
          let i = Dom_html.createTextarea ~name:(Js.string n) Dom_html.document
          in
          i##.value := v;
          Dom.appendChild f i
        | `File _ ->
          Lwt_log.raise_error ~section "redirect_post not implemented for files")
    params;
  f##.style##.display := (Js.string "none");
  Dom.appendChild (Dom_html.document##.body) f;
  (* firefox accepts submit only on forms in the document *)
  f##submit

(* Forms cannot use PUT http method: do not redirect *)
let redirect_put ?window_name:_ _url _params =
  Lwt_log.raise_error ~section "redirect_put not implemented"

(* Forms cannot use DELETE http method: do not redirect *)
let redirect_delete ?window_name:_ _url _params =
  Lwt_log.raise_error ~section "redirect_delete not implemented"

let nl_template =
  Eliom_parameter.make_non_localized_parameters
    ~prefix:"eliom" ~name:"template"
    (Eliom_parameter.string "name")
(* Warning: it must correspond to [nl_template]. *)
let nl_template_string = "__nl_n_eliom-template.name"

module Additional_headers = struct
  module Headers = Map.Make (String)
  let headers = ref Headers.empty
  let add header value =
    headers :=
    Headers.update (String.lowercase_ascii header) (fun _ -> Some value) !headers
  let remove header = headers := Headers.remove header !headers
  let to_list () = Headers.bindings !headers
end

let locked, set_locked = React.S.create false

let lock () = set_locked true
let unlock () = set_locked false

(** Same as XmlHttpRequest.perform_raw_url, but:
    - sends tab cookies in an HTTP header
    - does half and full XHR redirections according to headers

    The optional parameter [~cookies_info] is a pair
    containing the information (secure, path)
    that is taken into account for finding tab cookies to send.
    If not present, the path and protocol are taken from the URL.
*)
let send
    ?with_credentials
    ?(expecting_process_page = false) ?cookies_info
    ?get_args ?post_args
    ?progress ?upload_progress ?override_mime_type
    url result =
  let rec aux i ?cookies_info ?(get_args=[]) ?post_args url =
    let (https, path) = match cookies_info with
      | Some c -> c
      (* CCC Is it really necessary to allow to specify cookie_info here?
         hence, is it necessary to send it with the links? (attribute data-eliom-cookie-info) *)
      | None -> get_cookie_info_for_uri url
    in
    let host = match Url.url_of_string url with
      | Some (Url.Http url)
      | Some (Url.Https url) -> Some url.Url.hu_host
      | Some (Url.File _) -> None
      | None -> (* decoding failed: it is a relative link *)
        Some Url.Current.host
    in
    let host =
      match host with
      | Some host when host = Url.Current.host ->
        Some (Eliom_process.get_info ()).Eliom_common.cpi_hostname
      | _ ->
        host
    in
    let cookies = Eliommod_cookies.get_cookies_to_send host https path in
    let headers = match cookies with
      | [] -> []
      | _ -> [ Eliom_common.tab_cookies_header_name,
               encode_header_value cookies ] in
    let headers =
      if Js.Optdef.test Js.Unsafe.global##.___eliom_use_cookie_substitutes_ then
        (* Cookie substitutes are for iOS WKWebView *)
        let cookies =
          Eliommod_cookies.get_cookies_to_send
            ~in_local_storage:true host https path in
        ( Eliom_common.cookie_substitutes_header_name,
          encode_header_value cookies )
        :: headers
      else
        headers
    in
    let headers = Additional_headers.to_list () @ headers in
    (* CCC *
       For now we assume that an eliom application is not distributed
       among different server with different hostnames:
       to do that It is needed to change that part a bit to be able to
       send the process name to every host serving eliom pages.
       Do not send it to everybody: when doing a cross domain request
       with additional headers like thoose, an OPTION request is done
       before to check if the request is authorized. Some server does
       not support it ( like google ones for instance ) *)
    let headers =
      match host with
        | Some host when host = Url.Current.host ->
          ( Eliom_common.tab_cpi_header_name,
            encode_header_value (Eliom_process.get_info ())) :: headers
        | _ -> headers in
    let headers = if expecting_process_page
      then
        let content_type =
          if Dom_html.onIE &&
            not (Js.Optdef.test ((Js.Unsafe.coerce Dom_html.document)##.adoptNode))
          then
            (* ie < 9 does not know xhtml+xml content type, but ie 9
               can use it and need it to use adoptNode *)
            "application/xml"
          else "application/xhtml+xml"
        in
        ("Accept",content_type)::
          (Eliom_common.expecting_process_page_name,
           encode_header_value true)::
          headers
      else headers
    in
    let get_args =
      if expecting_process_page
      (* we add this parameter to ensure that the xhr request is
         different from the normal ones: we can't ensure that the
         browser won't cache the content of the page ( for instance
         when clicking the back button ). That way we are sure that an
         xhr answer won't be used in place of a normal answer. *)
      then (Eliom_common.nl_get_appl_parameter, "true")::get_args
      else get_args
    in
    let check_headers code headers =
      if expecting_process_page
      then
        if code = 204
        then true
        else
          headers Eliom_common.appl_name_header_name
          = Some (Eliom_process.get_application_name ())
      else true
    in
    try%lwt
      let%lwt r =
        let contents =
          match post_args with
          | Some post_args ->
            Some (`POST_form post_args)
          | None ->
            None
        in
        XmlHttpRequest.perform_raw_url
          ?with_credentials
          ?headers:(Some headers) ?content_type:None
          ?contents ~get_args ~check_headers
          ?progress ?upload_progress ?override_mime_type url
      in
      let wait_for_unlock, unlock = Lwt.wait () in
      if not @@ React.S.value locked then Lwt.wakeup unlock ()
      else begin
        let unlock_event = React.E.once @@ React.S.changes locked in
        ignore @@ React.E.map (fun _ -> Lwt.wakeup unlock ()) unlock_event
      end;
      let%lwt () = wait_for_unlock in
      (if Js.Optdef.test Js.Unsafe.global##.___eliom_use_cookie_substitutes_
       then
         match (* Cookie substitutes are for iOS WKWebView *)
           r.XmlHttpRequest.headers
             Eliom_common.set_cookie_substitutes_header_name
         with
         | None | Some "" -> ()
         | Some cookie_substitutes ->
           Eliommod_cookies.update_cookie_table ~in_local_storage:true
             host
             (Eliommod_cookies.cookieset_of_json cookie_substitutes));
      (match r.XmlHttpRequest.headers Eliom_common.set_tab_cookies_header_name
       with
         | None | Some "" -> () (* Empty tab_cookies for IE compat *)
         | Some tab_cookies ->
           let tab_cookies = Eliommod_cookies.cookieset_of_json tab_cookies in
           Eliommod_cookies.update_cookie_table host tab_cookies; );
      if r.XmlHttpRequest.code = 204
      then
        match r.XmlHttpRequest.headers Eliom_common.full_xhr_redir_header with
          | None | Some "" ->
            (match r.XmlHttpRequest.headers Eliom_common.half_xhr_redir_header
             with
               | None | Some "" -> Lwt.return (r.XmlHttpRequest.url, None)
               | Some _uri ->
                 redirect_post url
                   (match post_args with
                    | Some post_args -> post_args
                    | None -> []);
                 Lwt.fail Program_terminated)
          | Some uri ->
            if i < max_redirection_level
            then aux (i+1) (Url.resolve uri)
            else Lwt.fail Looping_redirection
      else
        if expecting_process_page
        then
          let url =
            match
              r.XmlHttpRequest.headers Eliom_common.response_url_header
            with
            | None | Some "" -> Url.add_get_args url (List.tl get_args)
            | Some url       -> Url.resolve url
          in
          Lwt.return (url, Some (result r))
        else
          if r.XmlHttpRequest.code = 200
             || XmlHttpRequest.(r.code = 0 && r.content <> "")
                (* HACK for file access within Cordova which yields code 0 *)
                (* Code 0 might mean a network error, but then we have no
                   content. *)
          then Lwt.return (r.XmlHttpRequest.url, Some (result r))
          else Lwt.fail (Failed_request r.XmlHttpRequest.code)
    with
      | XmlHttpRequest.Wrong_headers (code, headers) ->
        (* We are requesting application content and the headers tels
           us that the answer is not application content *)
        match headers Eliom_common.appl_name_header_name with
          | None | Some "" -> (* Empty appl_name for IE compat. *)
            (match post_args with
              | None -> redirect_get url
              | _ -> Lwt_log.raise_error ~section  "can't silently redirect a Post request to non application content");
            Lwt.fail Program_terminated
          | Some appl_name ->
            let current_appl_name = Eliom_process.get_application_name () in
            if appl_name = current_appl_name
            then assert false (* we can't go here:
                                     this case is already handled before *)
            else
              begin
                Lwt_log.ign_warning_f ~section
                  "received content for application %S when running application %s"
                  appl_name current_appl_name;
                Lwt.fail (Failed_request code)
              end
  in
  let%lwt (url, content) = aux 0 ?cookies_info ?get_args ?post_args url in
  let filter_url url =
    { url with Url.hu_arguments =
        List.filter (fun (e,_) -> e <> nl_template_string) url.Url.hu_arguments } in
  Lwt.return (
    (match Url.url_of_string url with
      | Some (Url.Http url) ->
        Url.string_of_url (Url.Http (filter_url url))
      | Some (Url.Https url) ->
        Url.string_of_url (Url.Https (filter_url url))
      | _ -> url),
    content)


(* BEGIN FORMDATA HACK *)
let add_button_arg inj args form =
  let button = Js.Unsafe.global##.eliomLastButton in
  Js.Unsafe.global##.eliomLastButton := None;
  match button with
    | None -> args
    | Some b ->
        let name, value, b_form =
          match Dom_html.tagged b with
            | Dom_html.Button b -> b##.name, b##.value, b##.form
            | Dom_html.Input b -> b##.name, b##.value, b##.form
            | _ -> assert false
        in
        let name = Js.to_string name in
        if name <> "" && b_form = Js.some form
        then
          match args with
            | None -> Some [name, inj value]
            | Some l -> Some ((name, inj value)::l)
        else args
(* END FORMDATA HACK *)

(** Send a GET form with tab cookies and half/full XHR.
    If [~post_params] is present, the HTTP method will be POST,
    with form data in the URL.
    If [~get_params] is present, it will be appended to the form fields.
*)
let send_get_form
    ?with_credentials
    ?expecting_process_page ?cookies_info ?(get_args=[]) ?post_args
    ?progress ?upload_progress ?override_mime_type
    form url =
  let get_args = get_args@(Form.get_form_contents form) in
  (* BEGIN FORMDATA HACK *)
  let get_args = add_button_arg Js.to_string (Some get_args) form in
  (* END FORMDATA HACK *)
  send ?with_credentials
    ?expecting_process_page ?cookies_info ?get_args ?post_args
    ?progress ?upload_progress ?override_mime_type
    url

(** Send a POST form with tab cookies and half/full XHR. *)
let send_post_form
    ?with_credentials
    ?expecting_process_page ?cookies_info ?get_args ?post_args
    ?progress ?upload_progress ?override_mime_type
    form url =
  (* BEGIN FORMDATA HACK *)
  let post_args =
    match
      add_button_arg (fun x -> `String x)
        (Some (Form.form_elements form))
        form,
      post_args
    with
    | Some l, Some l' ->
      Some (l @ l')
    | Some l, _
    | _, Some l ->
      Some l
    | None, None ->
      None
  in
  (* END FORMDATA HACK *)
  send ?with_credentials
    ?expecting_process_page ?cookies_info ?get_args ?post_args
    ?progress ?upload_progress ?override_mime_type
    url

let http_get ?with_credentials ?expecting_process_page ?cookies_info
    ?progress ?upload_progress ?override_mime_type
    url get_args =
  send ?with_credentials ?expecting_process_page ?cookies_info
    ?progress ?upload_progress ?override_mime_type
    ~get_args url

let http_post ?with_credentials ?expecting_process_page ?cookies_info
    ?progress ?upload_progress ?override_mime_type
    url post_args =
  send ?with_credentials ?expecting_process_page ?cookies_info ~post_args
    ?progress ?upload_progress ?override_mime_type
    url

let http_put ?with_credentials ?expecting_process_page ?cookies_info
    ?progress ?upload_progress ?override_mime_type
    url post_args =
  send ?with_credentials ?expecting_process_page ?cookies_info ~post_args
    ?progress ?upload_progress ?override_mime_type
    url

let http_delete ?with_credentials ?expecting_process_page ?cookies_info
    ?progress ?upload_progress ?override_mime_type
    url post_args =

  send ?with_credentials ?expecting_process_page ?cookies_info ~post_args
    ?progress ?upload_progress ?override_mime_type
    url
