Source file eliom_lib.ml

# 1 "src/lib/eliom_lib.client.ml"
(* Ocsigen
 * Copyright (C) 2005-2008 Vincent Balat, Stéphane Glondu
 *
 * 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
include Ocsigen_lib_base

include (
  Eliom_lib_base :
    module type of Eliom_lib_base
    with type 'a Int64_map.t = 'a Eliom_lib_base.Int64_map.t
    with type 'a String_map.t = 'a Eliom_lib_base.String_map.t
    with type 'a Int_map.t = 'a Eliom_lib_base.Int_map.t)

(*****************************************************************************)

module Url = struct
  include Url
  include Url_base

  let decode = Url.urldecode
  let encode ?plus s = Url.urlencode ?with_plus:plus s
  let make_encoded_parameters = Url.encode_arguments
  let split_path = Url.path_of_path_string
  let ssl_re = Regexp.regexp "^(https?):\\/\\/"

  let get_ssl s =
    Option.map
      (fun r -> Regexp.matched_group r 1 = Some "https")
      (Regexp.string_match ssl_re s 0)

  let resolve s =
    let a = Dom_html.createA Dom_html.document in
    a##.href := Js.string s;
    Js.to_string a##.href

  let has_get_args url =
    try
      ignore (String.index url '?');
      true
    with Not_found -> false

  let add_get_args url get_args =
    if get_args = []
    then url
    else
      url ^ (if has_get_args url then "&" else "?") ^ encode_arguments get_args

  let string_of_url_path ~encode l =
    if encode
    then print_endline "Warning: Eliom_lib.string_of_url_path ignores ~encode";
    String.concat "/" l

  let path_of_url = function
    | Url.Http {Url.hu_path = path; _}
    | Url.Https {Url.hu_path = path; _}
    | Url.File {Url.fu_path = path; _} ->
        path

  let path_of_url_string s =
    match Url.url_of_string s with
    | Some path -> path_of_url path
    | _ ->
        (* assuming relative URL and improvising *)
        split_path (try String.(sub s 0 (index s '?')) with Not_found -> s)
end

module Lwt_log = struct
  include Lwt_log_js

  let raise_error ?inspect ?exn ?section ?location ?logger msg =
    Lwt.ignore_result
      (log ?inspect ?exn ?section ?location ?logger ~level:Error msg);
    match exn with Some exn -> raise exn | None -> failwith msg

  let raise_error_f ?inspect ?exn ?section ?location ?logger fmt =
    Printf.ksprintf (raise_error ?inspect ?exn ?section ?location ?logger) fmt

  let eliom = Section.make "eliom"
end

let _ =
  Lwt_log.default := Lwt_log.console;
  Lwt.async_exception_hook :=
    fun exn ->
      Firebug.console##error_3 (Js.string "Lwt.async:")
        (Js.string (Printexc.to_string exn))
        exn

(* Deprecated ON *)
let debug_exn fmt exn = Lwt_log.ign_info_f ~exn fmt
let debug fmt = Lwt_log.ign_info_f fmt
let error fmt = Lwt_log.raise_error_f fmt
let error_any any fmt = Lwt_log.raise_error_f ~inspect:any fmt
let jsdebug a = Lwt_log.ign_info ~inspect:a "Jsdebug"
(* Deprecated OFF *)

let trace fmt =
  if Eliom_config.get_tracing ()
  then Lwt_log.ign_info_f (">> " ^^ fmt)
  else Printf.ksprintf ignore fmt

let lwt_ignore ?(message = "") t =
  Lwt.on_failure t (fun exn -> Lwt_log.ign_info_f ~exn "%s" message)

(* Debbuging *)
let jsalert a = Dom_html.window ## (alert a)
let alert fmt = Printf.ksprintf (fun s -> jsalert (Js.string s)) fmt

let confirm =
  let f s =
    let s = Js.string s in
    Dom_html.window ## (confirm s) |> Js.to_bool
  in
  fun fmt -> Printf.ksprintf f fmt

let debug_var s v = Js.Unsafe.set Dom_html.window (Js.string s) v

module String = struct
  include String_base

  let eol_re = Regexp.regexp "[\r\n]"
  let remove_eols s = Regexp.global_replace eol_re s ""
end

(*****************************************************************************)

(* let () =
  (Js.Unsafe.coerce Dom_html.window)##set_tracing <-
    Js.wrap_callback (fun v -> set_tracing (Js.to_bool v)) *)

(* We do not use the deriving (un)marshaling even if typ is available
   because direct jsn (un)marshaling is very fast client side
*)
let to_json ?typ s =
  match Sys.backend_type with
  | Other "js_of_ocaml" -> Js.to_string (Json.output s)
  | _ -> (
    match typ with
    | Some typ -> Deriving_Json.to_string typ s
    | None -> Js.to_string (Json.output s))

let of_json ?typ v =
  match Sys.backend_type with
  | Other "js_of_ocaml" -> Json.unsafe_input (Js.string v)
  | _ -> (
    match typ with
    | Some typ -> Deriving_Json.from_string typ v
    | None -> assert false)

(* Url.urlencode ~with_plus:true (Marshal.to_string x [])
    (* I encode the data because it seems that multipart does not
       like \0 character ... *)
*)
let encode_header_value ~typ x =
  (* We remove end of lines *)
  String.remove_eols (to_json ~typ x)

let unmarshal_js var = Marshal.from_string (Js.to_bytestring var) 0

type file_info = File.file Js.t

let make_cryptographic_safe_string ?len:_ () =
  failwith "make_cryptographic_safe_string not implemented client-side"

module Dom_reference = struct
  class type ['a, 'b] map = object
    method set : 'a -> 'b -> unit Js.meth
    method get : 'a -> 'b Js.Optdef.t Js.meth
    method delete : 'a -> unit Js.meth
  end

  let create_map () : (_, _) map Js.t =
    let map = Js.Unsafe.global##._Map in
    new%js map

  let create_weak_map () : (_, _) map Js.t =
    let weakMap = Js.Unsafe.global##._WeakMap in
    new%js weakMap

  type key = unit ref

  let retain_map : (Obj.t, (key, Obj.t) map Js.t) map Js.t = create_weak_map ()
  let new_key () = ref ()

  let retain ?(key = new_key ()) node ~keep =
    let node = Obj.repr node in
    let m =
      Js.Optdef.get
        (retain_map##get node)
        (fun () ->
           let m = create_map () in
           retain_map##set node m;
           m)
    in
    m##set key (Obj.repr keep)

  let retain_generic = retain

  let release ~key node =
    let node = Obj.repr node in
    Js.Optdef.iter (retain_map##get node) (fun m -> m##delete key)

  let transfer ~key ~src ~dst =
    let src = Obj.repr src in
    Js.Optdef.iter
      (retain_map##get src)
      (fun m ->
         Js.Optdef.iter (m##get key) (fun keep -> retain dst ~key ~keep);
         m##delete key)
end