Source file eliom_runtime.ml

# 1 "src/lib/eliom_runtime.shared.ml"
(* Ocsigen
 * http://www.ocsigen.org
 * Copyright (C) CNRS Univ Paris Diderot
 *
 * 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

module Client_value_server_repr = struct
  type u =
    { mutable loc : Eliom_lib_base.pos option
    ; instance_id : int
    ; unwrapper : Eliom_wrap.unwrapper }

  type 'a t = u

  let create ?loc ~instance_id ~unwrapper = {instance_id; loc; unwrapper}
  let instance_id cv = cv.instance_id
  let loc cv = cv.loc
  let clear_loc cv = cv.loc <- None
  let to_poly v = v
end

type escaped_value = Ocsigen_lib_base.poly

module RawXML = struct
  type separator = Space | Comma

  let separator_to_string = function Space -> " " | Comma -> ", "

  type cookie_info = bool * string list [@@deriving json]

  type caml_event_handler =
    | CE_registered_closure of string * Ocsigen_lib_base.poly (* 'a Js.t -> unit) client_value *)
    | CE_client_closure of (Dom_html.event Js.t -> unit) (* Client side-only *)
    | CE_client_closure_mouse of (Dom_html.mouseEvent Js.t -> unit) (* Client side-only *)
    | CE_client_closure_keyboard of (Dom_html.keyboardEvent Js.t -> unit) (* Client side-only *)
    | CE_client_closure_touch of (Dom_html.touchEvent Js.t -> unit) (* Client side-only *)
    | CE_call_service of
        ([`A | `Form_get | `Form_post]
        * cookie_info option
        * string option
        * Ocsigen_lib_base.poly)
        (* (event -> bool) client_value *)
        option
        Eliom_lazy.request

  type internal_event_handler = Raw of string | Caml of caml_event_handler
  type uri = string Eliom_lazy.request

  let string_of_uri = Eliom_lazy.force
  let uri_of_string = Eliom_lazy.from_val
  let uri_of_fun = Eliom_lazy.from_fun
  let internal_event_handler_of_service info = Caml (CE_call_service info)
  let ce_registered_closure_class = "caml_c" (*"caml_closure"*)

  let ce_registered_attr_class = "caml_attr"
  let ce_call_service_class = "caml_link"
  let process_node_class = "caml_p" (*"caml_process_node"*)

  let request_node_class = "caml_r" (*"caml_request_node"*)

  let ce_call_service_attrib = "data-eliom-cookies-info"
  let ce_template_attrib = "data-eliom-template"
  let node_id_attrib = "data-eliom-id" (*"data-eliom-node-id"*)

  let closure_attr_prefix = "" (*"caml_closure_id"*)

  let closure_name_prefix = "data-eliom-c-"
  (*!!! This prefix has to be different from any other prefix *)

  let client_attr_prefix = "eliom_attrib"
  let client_name_prefix = "data-eliom-"

  type aname = string

  type acontent =
    | AFloat of float
    | AInt of int
    | AStr of string
    | AStrL of separator * string list

  type racontent =
    | RA of acontent
    | RAReact of acontent option React.signal
    | RACamlEventHandler of caml_event_handler
    | RALazyStr of string Eliom_lazy.request
    | RALazyStrL of separator * string Eliom_lazy.request list
    | RAClient of string * attrib option * Ocsigen_lib_base.poly
  (*attrib client_value *)

  and attrib = aname * racontent

  let aname = function
    | name, RACamlEventHandler (CE_registered_closure (_crypto, _)) ->
        closure_name_prefix ^ name
    | _, RAClient (_, Some (name, _), _) | name, RAClient (_, None, _) ->
        client_name_prefix ^ name
    | name, _ -> name

  let acontent = function
    | _, RAReact s -> (
      match React.S.value s with None -> AStr "" | Some x -> x)
    | _, RA a -> a
    | _, RACamlEventHandler (CE_registered_closure (crypto, _)) ->
        AStr (closure_attr_prefix ^ crypto)
    | _, RACamlEventHandler _ -> AStr ""
    | _, RALazyStr str -> AStr (Eliom_lazy.force str)
    | _, RALazyStrL (sep, str) -> AStrL (sep, List.map Eliom_lazy.force str)
    | _, RAClient (crypto, _, _) -> AStr (client_attr_prefix ^ crypto)

  let racontent (_, a) = a

  let react_float_attrib name s =
    name, RAReact (React.S.map (fun f -> Some (AFloat f)) s)

  let react_int_attrib name s =
    name, RAReact (React.S.map (fun f -> Some (AInt f)) s)

  let react_string_attrib name s =
    name, RAReact (React.S.map (fun f -> Some (AStr f)) s)

  let react_space_sep_attrib name s =
    name, RAReact (React.S.map (fun f -> Some (AStrL (Space, f))) s)

  let react_comma_sep_attrib name s =
    name, RAReact (React.S.map (fun f -> Some (AStrL (Comma, f))) s)

  let react_poly_attrib name v s =
    ( name
    , RAReact (React.S.map (function false -> None | true -> Some (AStr v)) s) )

  let float_attrib name value = name, RA (AFloat value)
  let int_attrib name value = name, RA (AInt value)
  let string_attrib name value = name, RA (AStr value)
  let space_sep_attrib name values = name, RA (AStrL (Space, values))
  let comma_sep_attrib name values = name, RA (AStrL (Comma, values))

  let internal_event_handler_attrib name value =
    match value with
    | Raw value -> name, RA (AStr value)
    | Caml v -> name, RACamlEventHandler v

  let uri_attrib name value = name, RALazyStr value
  let uris_attrib name value = name, RALazyStrL (Space, value)

  type ename = string
  type node_id = NoId | ProcessId of string | RequestId of string

  module ClosureMap = Map.Make (struct
    type t = string

    let compare = compare
  end)

  type event_handler_table =
    Ocsigen_lib_base.poly
    (* (biggest_event Js.t -> unit) client_value *)
    ClosureMap.t

  type client_attrib_table =
    Ocsigen_lib_base.poly (* attrib client_value *) ClosureMap.t

  let filter_class_value acc = function
    | AStr v -> v :: acc
    | AStrL (_space, v) -> v @ acc
    | _ -> failwith "attribute class is not a string"

  let filter_class (freepos, acc_class, acc_attr) = function
    | "class", RA value -> freepos, filter_class_value acc_class value, acc_attr
    | (_, RACamlEventHandler (CE_registered_closure _)) as attr ->
        freepos, ce_registered_closure_class :: acc_class, attr :: acc_attr
    | _, RACamlEventHandler (CE_call_service link_info) -> (
      match Eliom_lazy.force link_info with
      | None -> freepos, acc_class, acc_attr
      | Some (_kind, cookie_info, tmpl, _) ->
          let acc_class = ce_call_service_class :: acc_class in
          let acc_attr =
            match cookie_info with
            | None -> acc_attr
            | Some v ->
                (ce_call_service_attrib, RA (AStr ([%json_of: cookie_info] v)))
                :: acc_attr
          in
          let acc_attr =
            match tmpl with
            | None -> acc_attr
            | Some tmpl -> (ce_template_attrib, RA (AStr tmpl)) :: acc_attr
          in
          freepos, acc_class, acc_attr)
    | "", RAClient (crypt, Some ("class", RA v), cv) ->
        let acc_class = filter_class_value acc_class v in
        let acc_class = ce_registered_attr_class :: acc_class
        and acc_attr = ("class", RAClient (crypt, None, cv)) :: acc_attr in
        freepos, acc_class, acc_attr
    | "", RAClient (crypt, init, cv) ->
        let freepos, acc_attr =
          match init with
          | Some ((an, _) as a) ->
              freepos, (an, RAClient (crypt, None, cv)) :: a :: acc_attr
          | None ->
              let name = Printf.sprintf "anonym%d" freepos in
              let freepos = succ freepos in
              freepos, (name, RAClient (crypt, None, cv)) :: acc_attr
        in
        freepos, ce_registered_attr_class :: acc_class, acc_attr
    | _, RAClient _ -> assert false
    | attr -> freepos, acc_class, attr :: acc_attr

  let filter_class_attribs node_id attribs =
    let nid_classes, nid_attribs =
      match node_id with
      | NoId -> [], []
      | ProcessId i -> [process_node_class], [node_id_attrib, RA (AStr i)]
      | RequestId i -> [request_node_class], [node_id_attrib, RA (AStr i)]
    in
    let _, classes, attribs =
      List.fold_left filter_class (0, nid_classes, nid_attribs) attribs
    in
    match classes with
    | [] -> attribs
    | _ -> ("class", RA (AStrL (Space, classes))) :: attribs
end

let tyxml_unwrap_id_int = 1
let client_value_unwrap_id_int = 7

type client_value_datum =
  { closure_id : string
  ; args : Ocsigen_lib_base.poly
  ; value : Ocsigen_lib_base.poly Client_value_server_repr.t }

type injection_datum =
  { injection_dbg : (Eliom_lib_base.pos * string option) option
  ; injection_id : int
  ; injection_value : Ocsigen_lib_base.poly }

type compilation_unit_global_data =
  { server_sections_data : client_value_datum array array
  ; client_sections_data : injection_datum array array }

type global_data = compilation_unit_global_data Eliom_lib.String_map.t
type request_data = client_value_datum array

let global_data_unwrap_id_int = 8

type 'a eliom_caml_service_data =
  {ecs_request_data : request_data; ecs_data : 'a}

(* the data sent on channels *)
type 'a eliom_comet_data_type = 'a Eliom_wrap.wrapped_value