Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

148 lines (124 sloc) 4.814 kb
Copyright © 2011 MLstate
This file is part of OPA.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
See the License for the specific language governing permissions and
limitations under the License.
module Ping = BslPingRegister.M
module Client = BslPingRegister.Client
module PingScheduler = BslPingRegister.PingScheduler
A delay for a specific RPC call.
A client may be still connected, and continue to ping, but an error occurred
and this client will never respond to a rpc_call.
This timeout is meant to abort the rpc_call, and to raise an exception on the server side.
It is also used as timeout of distant cellules calls.
Keep consistent with values defined in []
##register rpc_response_delay : int
let rpc_response_delay = 45 * 1000
(** Primitive for make rpc call to the client. *)
module RPC : sig
(** Call an rpc on the client identified by [cid] and send an
identifier. Register the cps continuation, this continuation
will be called on [return].
When the boolean is true, the call should be synchronous *)
val call : bool -> string -> string -> string QmlCpsServerLib.continuation -> Client.key
-> bool
(** [return id response] Call the continuation corresponding to
the given identifier. This identifier has been sent to the
client... *)
val return : string -> string -> bool
end = struct
let random_int () = 1073741823 (* 2^30 -1 *)
let generate_without_conflicts exists =
let rec aux () =
let id = random_int () in
if exists id then
aux ()
else id
in aux ()
(** Store the rpc continuation while waiting the response. *)
let rpc_ids = Hashtbl.create 512
let generate_id () =
generate_without_conflicts (fun id -> Hashtbl.mem rpc_ids id)
let set_rpc_timeout (cid : Client.key) fun_id id =
let abort () =
(* if the id is still in the rpc table, then remove it, and abort *)
let k = Hashtbl.find rpc_ids id in
Hashtbl.remove rpc_ids id ;
let exc = BslNativeLib.OpaExc.OpaRPC.timeout cid fun_id in
let k_exc = QmlCpsServerLib.handler_cont k in
QmlCpsServerLib.push_cont k_exc exc
| Not_found -> ()
let _async_key = PingScheduler.sleep rpc_response_delay abort in
let call sync fun_id args k cid =
Logger.debug "[RPC] Try to call rpc %s on client %s"
fun_id (Client.key_to_string cid);
let mess, id_opt =
if sync then
let id = generate_id () in
Hashtbl.add rpc_ids id k;
(* TODOK1 : args is a string but it should be a json! *)
Client.RPC (string_of_int id, fun_id, JsonTypes.String args), Some id
Client.AsyncRPC (fun_id, JsonTypes.String args), None in
if Ping.mem cid then (
Ping.send mess cid ;
(match id_opt with
| None -> ()
| Some id -> set_rpc_timeout cid fun_id id);
) else false
let return id response =
let id = int_of_string id in
Logger.debug "[RPC] Return %d received" id;
let k = Hashtbl.find rpc_ids id in
Hashtbl.remove rpc_ids id;
QmlCpsServerLib.push_cont k response;
with Not_found ->
Logger.error "[RPC] No continuation stored for %d" id;
with Failure "int_of_string" ->
Logger.error "[RPC] Identifier %s isn't an int" id;
(** Given continuation must be a string continuation. That works
because OPA string and ML string have the same representation,
but it's back end dependent. We should use a ServerLib
function for translate ML string to OPA string... coming
soon? *)
##register call : bool, string, string, continuation('a), 'ctx -> bool
let call sync fun_id args k key = sync fun_id args (Obj.magic k) (Obj.magic key)
(** This module is very dangerous, don't use it directly. It's a
module for RPC.*)
##module Dispatcher
let rpctbl : (string, Obj.t) Hashtbl.t = Hashtbl.create 1024
##register register : string, 'a -> void
let register name rpc_fun =
Hashtbl.add rpctbl name (Obj.repr rpc_fun)
##register get : string -> option('a)
let get name =
Some (Obj.obj (Hashtbl.find rpctbl name))
with Not_found -> None
Jump to Line
Something went wrong with that request. Please try again.