Source file ojs_js.ml

(*********************************************************************************)
(*                Ojs-base                                                       *)
(*                                                                               *)
(*    Copyright (C) 2014-2021 INRIA. All rights reserved.                        *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    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 Library General Public License for more details.                       *)
(*                                                                               *)
(*    You should have received a copy of the GNU 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                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** *)

open Js_of_ocaml

module SMap = Map.Make(String)
let (+=) map (key, v) = map := SMap.add key v !map
let (-=) map key = map := SMap.remove key !map
type id = string

let log s = Firebug.console##log (Js.string s);;

let mk_msg_of_wsdata server_msg_of_yojson =
  fun s ->
    try
      match server_msg_of_yojson (Yojson.Safe.from_string s) with
        Error s -> failwith (s ^ "\n" ^ s)
      | Ok msg -> Some msg
    with
      e ->
        log (Printexc.to_string e);
        None

let class_ s = "ojs-"^s

let setup_ws url msg_of_data ~onopen ~onmessage =
    let on_message ws _ event =
      try
      log "message received on ws";
      match msg_of_data (Js.to_string event##.data) with
        None -> Js._false
      | Some msg ->
          onmessage ws msg;
          Js._false
    with
      e ->
        log (Printexc.to_string e);
        Js._false
    in
    try
      log ("connecting with websocket to "^url);
      let ws = new%js WebSockets.webSocket(Js.string url) in
      ws##.onmessage := Dom.full_handler (on_message ws) ;
      ws##.onclose := Dom.handler (fun _ -> log "WS now CLOSED"; Js._false);
      ws##.onopen := Dom.handler (fun _ -> onopen ws; Js._false) ;
      Some ws
    with e ->
        log ("Could not connect to "^url);
        log (Printexc.to_string e);
        None
;;

let send_msg (ws : WebSockets.webSocket Js.t) data = ws##send (Js.string data)

let clear_children node =
  let children = node##.childNodes in
  for i = 0 to children##.length - 1 do
    Js.Opt.iter node##.firstChild (fun n -> Dom.removeChild node n)
  done

let node_by_id id =
  let node = Dom_html.document##getElementById (Js.string id) in
  Js.Opt.case node (fun _ -> failwith ("No node with id = "^id)) (fun x -> x)

let gen_id = let n = ref 0 in fun () -> incr n; Printf.sprintf "ojsid%d" !n

let set_onclick node f =
  ignore(Dom_html.addEventListener node
   Dom_html.Event.click
     (Dom.handler (fun e -> f e; Js.bool true))
     (Js.bool true))


(*c==v=[String.split_string]=1.2====*)
let split_string ?(keep_empty=false) s chars =
  let len = String.length s in
  let rec iter acc pos =
    if pos >= len then
      match acc with
        "" -> if keep_empty then [""] else []
      | _ -> [acc]
    else
      if List.mem s.[pos] chars then
        match acc with
          "" ->
            if keep_empty then
              "" :: iter "" (pos + 1)
            else
              iter "" (pos + 1)
        | _ -> acc :: (iter "" (pos + 1))
      else
        iter (Printf.sprintf "%s%c" acc s.[pos]) (pos + 1)
  in
  iter "" 0
(*/c==v=[String.split_string]=1.2====*)

let get_classes node =
  let s =Js.to_string node##.className in
  split_string s [' ']

let node_unset_class node cl =
  node##.classList##remove (Js.string cl)

let node_set_class node cl =
  node##.classList##add (Js.string cl)

let unset_class ~id cl =
  try
    let node = node_by_id id in
    node_unset_class node cl
  with
    Failure msg -> log msg

let set_class ~id cl =
  try
    let node = node_by_id id in
    node_set_class node cl
  with
    Failure msg -> log msg

let msg_base_class = class_"msg"
let msg_class_ s = Printf.sprintf "%s-%s" msg_base_class s

let display_message ?(timeout=3000.0) ?(cl=msg_class_"info") id msg_nodes =
  let doc = Dom_html.document in
  let node = node_by_id id in
  let div = doc##createElement (Js.string "div") in
  node_set_class div cl ;
  node_set_class div msg_base_class ;

  if timeout > 0. then
    ignore(Dom_html.window##setTimeout
     (Js.wrap_callback (fun () -> Dom.removeChild node div)) timeout
    )
  else
    (
     let b = doc##createElement (Js.string "span") in
     node_set_class b (msg_class_"close") ;
     let t = doc##createTextNode (Js.string "✘") in
     set_onclick b (fun _ -> Dom.removeChild node div);
     Dom.appendChild div b ;
     Dom.appendChild b t
    );

  Dom.appendChild node div ;
  List.iter (Dom.appendChild div) msg_nodes

let display_error id nodes = display_message ~timeout: 0. ~cl: (msg_class_"error") id nodes

let display_text_message ?timeout ?cl id text =
  let t = Dom_html.document##createTextNode (Js.string text) in
  display_message ?timeout ?cl id [t]

let display_text_error id text =
  let t = Dom_html.document##createTextNode (Js.string text) in
  display_error id [t]