(* Ocsigen
 * http://www.ocsigen.org
 * Module Eliom_mkreg
 * Copyright (C) 2007 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.
 *)

module S = Eliom_service
let (>>=) = Lwt.(>>=)

let suffix_redir_uri_key = Polytables.make_key ()

type ('options,'page,'result) param =
    { send :
        ?options:'options ->
        ?charset:string ->
        ?code: int ->
        ?content_type:string ->
        ?headers: Ocsigen_header.t ->
        'page ->
        Ocsigen_response.t Lwt.t;

      send_appl_content : S.send_appl_content;
      (** Whether the service is capable to send application content when
          required. This field is usually [Eliom_service.XNever]. This
          value is recorded inside each service just after
          registration.  *)

      result_of_http_result : Ocsigen_response.t -> 'result; }


(* If it is an xmlHTTPrequest who asked for an internal application
   service but the current service
   does not belong to the same application,
   we ask the browser to stop the program and do a redirection.
   This can happen for example after an action,
   when the fallback service does not belong to the application.
   We can not do a regular redirection because
   it is an XHR. We use our own redirections.
*)
(*VVV
  An alternative, to avoid the redirection with rc,
  would be to answer the full page and to detect on client side
  that it is not the answer of an XRH (using content-type)
  and ask the browser to act as if it were a regular request.
  Is it possible to do that?
  Drawback: The URL will be wrong

  Other solution: send the page and ask the browser to put it in the cache
  during a few seconds. Then redirect. But can we trust the browser cache?
*)

(* the test to know before page generation if the page can contain
   application data. This test is not exhaustif: services declared as
   XAlways can contain classical content, but we can't know it at this
   point: we must wait for the page to be generated and then see if it
   is effectively application content. *)
let check_before name service =
  match S.send_appl_content service
  (* the appl name of the service *)
  with
    | S.XSame_appl (an, _)
        when (an = name)
          -> (* Same appl, it is ok *) false
    | S.XAlways -> (* It is an action *) false
    | _ -> true

(* This test check if there is a header set only by
   Eliom_registration.App. This test is sufficient, but it is better
   to stop page generation as soon as we know that the content won't
   be needed: hence we test what we can before page generation. *)
let check_after name result =
  match
    Ocsigen_response.header result
      (Ocsigen_header.Name.of_string
         Eliom_common_base.appl_name_header_name)
  with
  | Some appl_name ->
    not (appl_name = name)
  | None ->
    (* not an application content *)
    true

let check_process_redir sp f param =
  let redir =
    if Eliom_request_info.expecting_process_page ()
    then
      match sp.Eliom_common.sp_client_appl_name with
        (* the appl name as sent by browser *)
        | None -> false (* should not happen *)
        | Some anr -> f anr param
          (* the browser asked application eliom data
             (content only) for application anr *)
    else false
  in
  if redir
  then
    let ri = Eliom_request_info.get_ri_sp sp in
    Lwt.fail
      (* we answer to the xhr
         by asking an HTTP redirection *)
      (Eliom_common.Eliom_do_half_xhr_redirection
         ("/"^
             Eliom_lib.String.may_concat
                  (Ocsigen_request.original_full_path_string ri)
                  ~sep:"?"
                  (Eliom_parameter.construct_params_string
                     (Ocsigen_request.get_params_flat ri))
                  ))
  (* We do not put hostname and port.
     It is ok with half or full xhr redirections. *)
  (* If an action occurred before,
     it may have removed some get params form ri *)
  else Lwt.return_unit

let send_with_cookies
    sp
    pages
    ?options
    ?charset
    ?code
    ?content_type
    ?headers
    content =
  let%lwt result =
    pages.send
      ?options
      ?charset
      ?code
      ?content_type
      ?headers
      content
  in
  let%lwt () = check_process_redir sp check_after result in
  let%lwt tab_cookies =
    Eliommod_cookies.compute_cookies_to_send
      sp.Eliom_common.sp_sitedata
      sp.Eliom_common.sp_tab_cookie_info
      sp.Eliom_common.sp_user_tab_cookies
  in
  (* TODO: do not add header when no cookies *)
  let response =
    let response, _ = Ocsigen_response.to_cohttp result in
    let headers =
      Cohttp.Header.add
        (Cohttp.Response.headers response)
        Eliom_common_base.set_tab_cookies_header_name
        (Eliommod_cookies.cookieset_to_json tab_cookies)
    in
    { response with Cohttp.Response.headers }
  and cookies =
    Ocsigen_cookie_map.add_multi
      (Eliom_request_info.get_user_cookies ())
      (Ocsigen_response.cookies result)
  in
  Lwt.return (Ocsigen_response.update result ~cookies ~response)

let register_aux pages
      ?options
      ?charset
      ?code
      ?content_type
      ?headers
      table
      (type a)
      ~(service : (_, _, _, a, _, _, _, _, _, _, _) S.t)
      ?(error_handler = fun l -> raise (Eliom_common.Eliom_Typing_Error l))
      page_generator =
    S.set_send_appl_content service (pages.send_appl_content);
    begin
      match S.info service with
        | S.Attached attser ->
          let key_meth = S.which_meth_untyped service in
          let attserget = S.get_name attser in
          let attserpost = S.post_name attser in
          let suffix_with_redirect = S.redirect_suffix attser in
          let priority = S.priority attser in
          let sgpt = S.get_params_type service
          and sppt = S.post_params_type service in
          let s_id =
            if
              attserget = Eliom_common.SAtt_no
              || attserpost = Eliom_common.SAtt_no
            then
              Eliom_parameter.(
                anonymise_params_type sgpt,
                anonymise_params_type sppt
              )
            else
              (0, 0)
          and s_max_use = S.max_use service
          and s_expire =
            match S.timeout service with
            | None -> None
            | Some t -> Some (t, ref (t +. Unix.time ()))
          in
          let f table ((_attserget, _attserpost) as attsernames) =
            Eliom_route.add_service
              priority
              table
              (S.sub_path attser)
              {Eliom_common.key_state = attsernames;
               Eliom_common.key_meth = (key_meth :> Eliom_common.meth)}
              { s_id ; s_max_use ; s_expire ;
                s_f = (fun nosuffixversion sp ->
                  Lwt.with_value Eliom_common.sp_key (Some sp)
                    (fun () ->
                      let ri = Eliom_request_info.get_ri_sp sp
                      and suff = Eliom_request_info.get_suffix_sp sp in
                      (Lwt.catch (fun () ->
                         Eliom_parameter.reconstruct_params
                          ~sp
                          sgpt
                          (Some (Lwt.return
                                   (Ocsigen_request.get_params_flat ri)))
                          (Some (Lwt.return []))
                          nosuffixversion
                          suff
                        >>= fun g ->
                        let post_params =
                          Eliom_request_info.get_post_params_sp sp
                        in
                        let files =
                          Eliom_request_info.get_files_sp sp
                        in
                        Eliom_parameter.reconstruct_params
                          ~sp
                          sppt
                          post_params
                          files
                          false
                          None
                        >>= fun p ->
                        (* GRGR TODO: avoid
                           Eliom_uri.make_string_uri_. But we need to
                           "downcast" the type of service to the
                           correct "get service". *)
                        (if Eliom_request_info.get_http_method () = `GET
                         && nosuffixversion && suffix_with_redirect
                         then
                            (* it is a suffix service in version
                               without suffix. We redirect. *)
                            if not (Eliom_request_info.expecting_process_page ())
                            then
                              let redir_uri =
                                Eliom_uri.make_string_uri_
                                  ~absolute:true
                                  ~service:
                                  (service :
                                     ('a, 'b, _, _, _,
                                      S.non_ext, S.reg, _,
                                      'c, 'd, 'return)
                                       S.t :>
                                     ('a, 'b, _, _, _, _, _, _,
                                      'c, 'd, 'return)
                                     S.t)
                                  g
                              in
                              Lwt.fail
                                (Eliom_common.Eliom_do_redirection redir_uri)
                            else begin
                            (* It is an internal application form.
                               We don't redirect but we set this
                               special information for url to be displayed
                               by the browser
                               (see Eliom_request_info.rebuild_uri_without_iternal_form_info_)
                            *)
                              let redir_uri =
                                Eliom_uri.make_string_uri_ ~service g in
                              let rc = Eliom_request_info.get_request_cache_sp sp in
                              Polytables.set ~table:rc ~key:suffix_redir_uri_key ~value:redir_uri;
                              Lwt.return_unit
                            end
                         else Lwt.return_unit)
                        >>= fun () ->
                        check_process_redir sp check_before service >>= fun () ->
                        page_generator g p)
                         (function
                           | Eliom_common.Eliom_Typing_Error l ->
                             error_handler l
                           | e -> Lwt.fail e)
                       >>= fun content ->
                       send_with_cookies sp pages
                         ?options
                         ?charset
                         ?code
                         ?content_type
                         ?headers
                         content)))}
          in
          (match (key_meth, attserget, attserpost) with
            | (`Post | `Put | `Delete), _,
               Eliom_common.SAtt_csrf_safe (id, scope, secure_session) ->
              let tablereg, forsession =
                match table with
                  | Eliom_lib.Left globtbl -> globtbl, false
                  | Eliom_lib.Right (sp, ct, sec) ->
                    if secure_session <> sec || scope <> ct
                    then raise
                      S.Wrong_session_table_for_CSRF_safe_coservice;
                    !(Eliom_state.get_session_service_table
                        ?secure:secure_session ~scope ~sp ()),
                      true
              in
              S.set_delayed_post_registration_function
                tablereg
                id
                (fun ~sp attserget ->
                  let n = S.new_state () in
                  let attserpost = Eliom_common.SAtt_anon n in
                  let table =
                    if forsession
                    then tablereg
                    else
                      (* we do not register in global table,
                         but in the table specified while creating
                         the csrf safe service *)
                      !(Eliom_state.get_session_service_table
                          ?secure:secure_session
                          ~scope ~sp ())
                  in
                  f table (attserget, attserpost);
                  n)
            | `Get,
              Eliom_common.SAtt_csrf_safe (id, scope, secure_session),
              _ ->
              let tablereg, forsession =
                match table with
                  | Left globtbl -> globtbl, false
                  | Right (sp, ct, sec) ->
                    if secure_session <> sec || ct <> scope
                    then raise
                      S.Wrong_session_table_for_CSRF_safe_coservice;
                    !(Eliom_state.get_session_service_table
                        ?secure:secure_session ~scope ~sp ()), true
              in
              S.set_delayed_get_or_na_registration_function
                tablereg
                id
                (fun ~sp ->
                  let n = S.new_state () in
                  let attserget = Eliom_common.SAtt_anon n in
                  let table =
                    if forsession
                    then tablereg
                    else
                      (* we do not register in global table,
                         but in the table specified while creating
                         the csrf safe service *)
                      !(Eliom_state.get_session_service_table
                          ?secure:secure_session ~scope ~sp ())
                  in
                  f table (attserget, attserpost);
                  n)
            | _ ->
              let tablereg =
                match table with
                  | Left globtbl -> globtbl
                  | Right (sp, scope, secure_session) ->
                    !(Eliom_state.get_session_service_table
                        ?secure:secure_session ~scope ~sp ())
              in
              f tablereg (attserget, attserpost))
        | S.Nonattached naser ->
          let na_name = S.na_name naser in
          let f table na_name =
            Eliom_route.add_naservice
              table
              na_name
              ((match S.max_use service with
                | None -> None
                | Some i -> Some (ref i)),
               (match S.timeout service with
                 | None -> None
                 | Some t -> Some (t, ref (t +. Unix.time ()))),
               (fun sp ->
                 Lwt.with_value Eliom_common.sp_key (Some sp)
                   (fun () ->
                     let ri = Eliom_request_info.get_ri_sp sp in
                     Lwt.catch
                       (fun () ->
                         Eliom_parameter.reconstruct_params
                           ~sp
                           (S.get_params_type service)
                           (Some (Lwt.return
                                    (Ocsigen_request.get_params_flat ri)))
                           (Some (Lwt.return []))
                           false
                           None
                         >>= fun g ->
                         let post_params =
                           Eliom_request_info.get_post_params_sp sp
                         in
                         let files = Eliom_request_info.get_files_sp sp in
                         Eliom_parameter.reconstruct_params
                           ~sp
                           (S.post_params_type service)
                           post_params
                           files
                           false
                           None
                         >>= fun p ->
                         check_process_redir sp check_before service >>= fun () ->
                         page_generator g p)
                       (function
                         | Eliom_common.Eliom_Typing_Error l ->
                           error_handler l
                         | e -> Lwt.fail e) >>= fun content ->
                     send_with_cookies sp pages
                       ?options
                       ?charset
                       ?code
                       ?content_type
                       ?headers
                       content)
               ))
          in
          match na_name with
            | Eliom_common.SNa_get_csrf_safe (id, scope, secure_session) ->
              (* CSRF safe coservice: we'll do the registration later *)
              let tablereg, forsession =
                match table with
                  | Left globtbl -> globtbl, false
                  | Right (sp, ct, sec) ->
                    if secure_session <> sec || ct <> scope
                    then raise
                      S.Wrong_session_table_for_CSRF_safe_coservice;
                    !(Eliom_state.get_session_service_table
                        ?secure:secure_session ~scope ~sp ()), true
              in
              S.set_delayed_get_or_na_registration_function
                tablereg
                id
                (fun ~sp ->
                  let n = S.new_state () in
                  let na_name = Eliom_common.SNa_get' n in
                  let table =
                    if forsession
                    then tablereg
                    else
                      (* we do not register in global table,
                         but in the table specified while creating
                         the csrf safe service *)
                      !(Eliom_state.get_session_service_table
                          ?secure:secure_session ~scope ~sp ())
                  in
                  f table na_name;
                  n)
            | Eliom_common.SNa_post_csrf_safe (id, scope, secure_session) ->
              (* CSRF safe coservice: we'll do the registration later *)
              let tablereg, forsession =
                match table with
                  | Left globtbl -> globtbl, false
                  | Right (sp, ct, sec) ->
                    if secure_session <> sec || ct <> scope
                    then raise
                      S.Wrong_session_table_for_CSRF_safe_coservice;
                    !(Eliom_state.get_session_service_table
                        ?secure:secure_session ~scope ~sp ()), true
              in
              S.set_delayed_get_or_na_registration_function
                tablereg
                id
                (fun ~sp ->
                  let n = S.new_state () in
                  let na_name = Eliom_common.SNa_post' n in
                  let table =
                    if forsession
                    then tablereg
                    else
                      (* we do not register in global table,
                         but in the table specified while creating
                         the csrf safe service *)
                      !(Eliom_state.get_session_service_table
                          ?secure:secure_session ~scope ~sp ())
                  in
                  f table na_name;
                  n)
            | _ ->
              let tablereg =
                match table with
                  | Left globtbl -> globtbl
                  | Right (sp, scope, secure_session) ->
                    !(Eliom_state.get_session_service_table
                        ?secure:secure_session ~scope ~sp ())
              in
              f tablereg na_name
    end

let send pages
    ?options
    ?charset
    ?code
    ?content_type
    ?headers
    content =
  let%lwt result =
    pages.send
      ?options
      ?charset
      ?code
      ?content_type
      ?headers
      content
  in
  Lwt.return (pages.result_of_http_result result)

let register pages
    ?app:_
    ?scope
    ?options
    ?charset
    ?code
    ?content_type
    ?headers
    ?secure_session
    (type a)
    ~(service :
        (_, _, _, a, _, _, S.reg, _, _, _, _) S.t)
    ?error_handler
    page_gen =
  let sp = Eliom_common.get_sp_option () in
  match scope, sp with
    | None, None
    | Some `Site, None ->
      (match Eliom_common.global_register_allowed () with
        | Some get_current_sitedata ->
          let sitedata = get_current_sitedata () in
          (match S.info service with
            | S.Attached attser ->
              Eliom_common.remove_unregistered
                sitedata (S.sub_path attser)
            | S.Nonattached naser ->
              Eliom_common.remove_unregistered_na
                sitedata (S.na_name naser));
          register_aux pages
            ?options
            ?charset
            ?code
            ?content_type
            ?headers
            (Left sitedata.Eliom_common.global_services)
            ~service ?error_handler page_gen
        | _ -> raise
          (Eliom_common.Eliom_site_information_not_available
             "register"))
    | None, Some _
    | Some `Site, Some _ ->
      register_aux pages
        ?options
        ?charset
        ?code
        ?content_type
        ?headers
        ?error_handler
        (Eliom_lib.Left (Eliom_state.get_global_table ()))
        ~service
        page_gen
    | _, None ->
      raise (failwith "Missing sp while registering service")
    | Some (#Eliom_common.user_scope as scope), Some sp ->
      register_aux pages
        ?options
        ?charset
        ?code
        ?content_type
        ?headers
        ?error_handler
        (Right (sp, scope, secure_session))
        ~service page_gen

  (* WARNING: if we create a new service without registering it,
     we can have a link towards a page that does not exist!!! :-(
     That's why I impose to register all service during init.
     The only other way I see to avoid this is to impose a syntax extension
     like "let rec" for service...
  *)

let create pages
    ?scope
    ?app
    ?options
    ?charset
    ?code
    ?content_type
    ?headers
    ?secure_session
    ?https
    ?name
    ?csrf_safe
    ?csrf_scope
    ?csrf_secure
    ?max_use
    ?timeout
    ~meth
    ~path
    ?error_handler
    page =
  let service =
    S.create_unsafe
      ?name
      ?csrf_safe
      ?csrf_scope:(csrf_scope :> Eliom_common.user_scope option)
      ?csrf_secure
      ?max_use ?timeout ?https ~meth ~path ()
  in
  register pages
    ?scope
    ?app
    ?options
    ?charset
    ?code
    ?content_type
    ?headers
    ?secure_session
    ~service ?error_handler page;
  service

let create_attached_get pages
    ?scope
    ?app
    ?options
    ?charset
    ?code
    ?content_type
    ?headers
    ?secure_session
    ?https
    ?name
    ?csrf_safe
    ?csrf_scope
    ?csrf_secure
    ?max_use
    ?timeout
    ~fallback
    ~get_params
    ?error_handler
    page =
  let service =
    S.create_attached_get_unsafe
      ?name
      ?csrf_safe
      ?csrf_scope:(csrf_scope :> Eliom_common.user_scope option)
      ?csrf_secure
      ?max_use ?timeout ?https ~fallback ~get_params ()
  in
  register pages
    ?scope
    ?app
    ?options
    ?charset
    ?code
    ?content_type
    ?headers
    ?secure_session
    ~service ?error_handler page;
  service

let create_attached_post pages
    ?scope
    ?app
    ?options
    ?charset
    ?code
    ?content_type
    ?headers
    ?secure_session
    ?https
    ?name
    ?csrf_safe
    ?csrf_scope
    ?csrf_secure
    ?max_use
    ?timeout
    ~fallback
    ~post_params
    ?error_handler
    page =
  let service =
    S.create_attached_post_unsafe
      ?name
      ?csrf_safe
      ?csrf_scope:(csrf_scope :> Eliom_common.user_scope option)
      ?csrf_secure
      ?max_use ?timeout ?https ~fallback ~post_params ()
  in
  register pages
    ?scope
    ?app
    ?options
    ?charset
    ?code
    ?content_type
    ?headers
    ?secure_session
    ~service ?error_handler page;
  service

module Make
    (Pages : Eliom_registration_sigs.PARAM
     with type frame := Ocsigen_response.t) =
struct

  type page = Pages.page
  type options = Pages.options
  type return = Eliom_service.non_ocaml
  type result = Pages.result

  let pages =
    { send = Pages.send;
      send_appl_content = Pages.send_appl_content;
      result_of_http_result = Pages.result_of_http_result; }

  let send ?options = send pages ?options

  let register ?app = register pages ?app

  let create ?app = create pages ?app

  let create_attached_get ?app = create_attached_get pages ?app

  let create_attached_post ?app = create_attached_post pages ?app

end

module Make_poly
    (Pages : Eliom_registration_sigs.PARAM_POLY
     with type frame := Ocsigen_response.t) =
struct

  type 'a page = 'a Pages.page
  type options = Pages.options
  type 'a return = 'a Pages.return

  let pages = {
    send                  = Pages.send;
    send_appl_content     = Pages.send_appl_content;
    result_of_http_result = (fun x -> x)
  }

  let register ?app = register pages ?app

  let create ?app = create pages ?app

  let create_attached_get ?app = create_attached_get pages ?app

  let create_attached_post ?app = create_attached_post pages ?app

end
