Source file eliom_service.ml

# 1 "src/lib/eliom_service.server.ml"
(* Ocsigen
 * http://www.ocsigen.org
 * 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.
 *)

include Eliom_service_base

let plain_service (type m gp gn pp pn gp') ?(https = false) ~path
    ?keep_nl_params ?priority ~(meth : (m, gp, gn, pp, pn, _, gp') meth) ()
  =
  let get_params, post_params = params_of_meth meth
  and meth = which_meth_internal meth in
  let redirect_suffix = Eliom_parameter.contains_suffix get_params in
  let path =
    (match redirect_suffix with
      | None -> path
      | Some _ -> path @ [Eliom_common.eliom_suffix_internal_name])
    |> Url.remove_slash_at_beginning |> Url.change_empty_list
    |> Url.remove_internal_slash
  in
  (if Eliom_common.get_sp_option () = None
   then
     match Eliom_common.global_register_allowed () with
     | Some current_site_data ->
         Eliom_common.add_unregistered (current_site_data ()) path
     | None ->
         raise (Eliom_common.Eliom_site_information_not_available "service"));
  let reload_fun = Rf_client_fun in
  main_service ~https ~prefix:"" ~path ~kind:`Service ~meth ?redirect_suffix
    ?keep_nl_params ?priority ~get_params ~post_params ~reload_fun ()

let create_attached ?name ?(csrf_safe = false) ?csrf_scope ?csrf_secure ?max_use
    ?timeout ?(https = false) ?keep_nl_params ~fallback ~get_params ~post_params
    ~meth ()
  =
  let is_post = is_post' meth in
  let csrf_scope = default_csrf_scope csrf_scope
  and get_params_type, post_params_type =
    if is_post
    then
      ( get_params
      , Eliom_parameter.add_pref_params Eliom_common.co_param_prefix post_params
      )
    else
      ( Eliom_parameter.add_pref_params Eliom_common.co_param_prefix get_params
      , post_params )
  and k = attached_info fallback in
  { pre_applied_parameters = fallback.pre_applied_parameters
  ; get_params_type
  ; post_params_type
  ; send_appl_content = fallback.send_appl_content
  ; service_mark = service_mark ()
  ; max_use
  ; timeout
  ; meth
  ; kind = `AttachedCoservice
  ; info =
      (let att_name =
         if csrf_safe
         then
           Eliom_common.SAtt_csrf_safe
             (uniqueid (), (csrf_scope :> Eliom_common.user_scope), csrf_secure)
         else
           match name with
           | None -> Eliom_common.SAtt_anon (new_state ())
           | Some name -> Eliom_common.SAtt_named name
       in
       Attached
         { k with
           get_name = (if is_post then k.get_name else att_name)
         ; post_name = (if not is_post then k.post_name else att_name) })
  ; https = https || fallback.https
  ; keep_nl_params =
      (match keep_nl_params with
      | None -> fallback.keep_nl_params
      | Some k -> k)
  ; client_fun = no_client_fun ()
  ; reload_fun = Rf_client_fun }

let create_attached_get =
  create_attached ~meth:Get' ~post_params:Eliom_parameter.unit

let create_attached_post ?name ?csrf_safe ?csrf_scope ?csrf_secure ?max_use
    ?timeout ?https ?keep_nl_params ~fallback ~post_params ()
  =
  let get_params = get_params_type fallback in
  create_attached ~meth:Post' ?name ?csrf_safe ?csrf_scope ?csrf_secure ?max_use
    ?timeout ?https ?keep_nl_params ~fallback ~post_params ~get_params ()

let create_attached_get_unsafe = create_attached_get
let create_attached_post_unsafe = create_attached_post

let coservice' (type m gp gn pp pn) ?name ?(csrf_safe = false) ?csrf_scope
    ?csrf_secure ?max_use ?timeout ?(https = false)
    ?(keep_nl_params = `Persistent) ~(meth : (m, gp, gn, pp, pn, _, unit) meth)
    ()
  =
  let get_params, post_params = params_of_meth meth in
  let meth = which_meth_internal meth and is_post = is_post meth in
  let csrf_scope = default_csrf_scope csrf_scope in
  { max_use
  ; timeout
  ; pre_applied_parameters = Eliom_lib.String.Table.empty, []
  ; get_params_type =
      Eliom_parameter.add_pref_params Eliom_common.na_co_param_prefix get_params
  ; post_params_type = post_params
  ; meth
  ; kind = `NonattachedCoservice
  ; info =
      Nonattached
        { na_name =
            (if csrf_safe
             then
               if is_post
               then
                 Eliom_common.SNa_post_csrf_safe
                   ( uniqueid ()
                   , (csrf_scope :> Eliom_common.user_scope)
                   , csrf_secure )
               else
                 Eliom_common.SNa_get_csrf_safe
                   ( uniqueid ()
                   , (csrf_scope :> Eliom_common.user_scope)
                   , csrf_secure )
             else
               match name, is_post with
               | None, true -> Eliom_common.SNa_post' (new_state ())
               | None, false -> Eliom_common.SNa_get' (new_state ())
               | Some name, true -> Eliom_common.SNa_post_ name
               | Some name, false -> Eliom_common.SNa_get_ name)
        ; keep_get_na_params = true }
  ; https
  ; keep_nl_params
  ; send_appl_content = XNever
  ; service_mark = service_mark ()
  ; client_fun = no_client_fun ()
  ; reload_fun = Rf_client_fun }

let create ?name ?(csrf_safe = false) ?csrf_scope ?csrf_secure ?max_use ?timeout
    ?(https = false) ?(keep_nl_params = `Persistent) ?priority
    (type m gp gn pp pn gp' att_ co_ ext_ reg_ rr)
    ~(meth : (m, gp, gn, pp, pn, _, gp') meth)
    ~(path : (att_, co_, gp') path_option) () :
    (gp, pp, m, att_, co_, ext_, reg_, _, gn, pn, rr) t
  =
  match path with
  | Path path -> plain_service ~https ~keep_nl_params ?priority ~path ~meth ()
  | No_path ->
      coservice' ?name ~csrf_safe ?csrf_scope ?csrf_secure ?max_use ?timeout
        ~https ~keep_nl_params ~meth ()

let create_unsafe = create
let create_ocaml = create

let attach :
     fallback:
       ( unit
         , unit
         , get
         , att
         , _
         , non_ext
         , 'rg1
         , [< suff]
         , unit
         , unit
         , 'return1 )
         t
    -> service:
         ( 'get
           , 'post
           , 'gp
           , non_att
           , co
           , non_ext
           , 'rg2
           , ([< `WithoutSuffix] as 'sf)
           , 'gn
           , 'pn
           , 'return )
           t
    -> unit
    -> ('get, 'post, 'gp, att, co, non_ext, non_reg, 'sf, 'gn, 'pn, 'return) t
  =
 fun ~fallback ~service () ->
  let {na_name; _} = non_attached_info service in
  let fallbackkind = attached_info fallback in
  let open Eliom_common in
  let error_msg =
    "attach' is not implemented for this kind ofservice. Please report a bug if you need this."
  in
  let get_name =
    match na_name with
    | SNa_get_ s -> SAtt_na_named s
    | SNa_get' s -> SAtt_na_anon s
    | SNa_get_csrf_safe a -> SAtt_na_csrf_safe a
    | SNa_post_ _ -> fallbackkind.get_name (*VVV check *)
    | SNa_post' _ -> fallbackkind.get_name (*VVV check *)
    | SNa_post_csrf_safe _ -> fallbackkind.get_name (*VVV check *)
    | _ -> failwith error_msg
  (*VVV Do we want to make possible to attach POST na coservices
          on GET attached coservices? *)
  and post_name =
    match na_name with
    | SNa_get_ _ -> SAtt_no
    | SNa_get' _ -> SAtt_no
    | SNa_get_csrf_safe _ -> SAtt_no
    | SNa_post_ s -> SAtt_na_named s
    | SNa_post' s -> SAtt_na_anon s
    | SNa_post_csrf_safe a -> SAtt_na_csrf_safe a
    | _ -> failwith error_msg
  in
  { service with
    service_mark = service_mark ()
  ; kind = `AttachedCoservice
  ; pre_applied_parameters = fallback.pre_applied_parameters
  ; info = Attached {fallbackkind with get_name; post_name} }

exception Wrong_session_table_for_CSRF_safe_coservice

let eliom_appl_answer_content_type = "application/x-eliom"

(* If there is a client side process, we do an XHR with tab cookies *)
let xhr_with_cookies s =
  if is_external s
  then None
  else
    match s.send_appl_content with
    | XAlways -> Some None
    | XNever ->
        None
        (* actually this will be tested again later in
              get_onload_form_creators *)
    | XSame_appl (_, tmpl) -> Some tmpl

(* Some an = current_page_appl_name *)
(* for now we do not know the current_page_appl_name.  We will know it
   only after calling send.  In case it is not the same name, we will
   not send the onload_form_creator_info. *)

let register_eliom_module name f =
  Ocsigen_loader.set_module_init_function name f

exception Unregistered_CSRF_safe_coservice

let register_delayed_get_or_na_coservice ~sp (k, scope, secure) =
  let f =
    try
      let table =
        !(Eliom_state.get_session_service_table_if_exists ~sp
            ~scope:(scope :> Eliom_common.user_scope)
            ?secure ())
      in
      Eliom_lib.Int.Table.find k
        table.Eliom_common.csrf_get_or_na_registration_functions
    with Not_found -> (
      let table = Eliom_state.get_global_table () in
      try
        Eliom_lib.Int.Table.find k
          table.Eliom_common.csrf_get_or_na_registration_functions
      with Not_found -> raise Unregistered_CSRF_safe_coservice)
  in
  f ~sp

let register_delayed_post_coservice ~sp (k, scope, secure) getname =
  let f =
    try
      let table =
        !(Eliom_state.get_session_service_table_if_exists ~sp
            ~scope:(scope :> Eliom_common.user_scope)
            ?secure ())
      in
      Eliom_lib.Int.Table.find k
        table.Eliom_common.csrf_post_registration_functions
    with Not_found -> (
      let table = Eliom_state.get_global_table () in
      try
        Eliom_lib.Int.Table.find k
          table.Eliom_common.csrf_post_registration_functions
      with Not_found -> raise Unregistered_CSRF_safe_coservice)
  in
  f ~sp getname

let set_delayed_get_or_na_registration_function tables k f =
  tables.Eliom_common.csrf_get_or_na_registration_functions <-
    Eliom_lib.Int.Table.add k f
      tables.Eliom_common.csrf_get_or_na_registration_functions

let set_delayed_post_registration_function tables k f =
  tables.Eliom_common.csrf_post_registration_functions <-
    Eliom_lib.Int.Table.add k f
      tables.Eliom_common.csrf_post_registration_functions

let remove_service table (type m a)
    (service : (_, _, m, a, _, _, _, _, _, _, _) t)
  =
  match info service with
  | Attached attser ->
      let key_kind = which_meth_untyped service in
      let attserget = get_name attser in
      let attserpost = post_name attser in
      let sgpt = get_params_type service in
      let sppt = post_params_type service in
      Eliom_route.remove_service table (sub_path attser)
        { Eliom_common.key_state = attserget, attserpost
        ; Eliom_common.key_meth = key_kind }
        (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)
  | Nonattached naser ->
      let na_name = na_name naser in
      Eliom_route.remove_naservice table na_name

let unregister ?scope ?secure (type m)
    (service : (_, _, m, _, _, _, _, _, _, _, _) t)
  =
  let sp = Eliom_common.get_sp_option () in
  match scope with
  | None | Some `Site ->
      let table =
        match sp with
        | None -> (
          match Eliom_common.global_register_allowed () with
          | Some get_current_sitedata ->
              let sitedata = get_current_sitedata () in
              sitedata.Eliom_common.global_services
          | _ ->
              raise
                (Eliom_common.Eliom_site_information_not_available "unregister")
          )
        | Some _ -> Eliom_state.get_global_table ()
      in
      remove_service table service
  | Some (#Eliom_common.user_scope as scope) -> (
    match sp with
    | None ->
        raise
          (failwith
             "Unregistering service for non global scope must be done during a request")
    | Some sp ->
        let table =
          !(Eliom_state.get_session_service_table ~sp ?secure ~scope ())
        in
        remove_service table service)

let client_fun _ = None
let has_client_fun _ = false