/
bslRPC.ml
111 lines (91 loc) · 3.42 KB
/
bslRPC.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA 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 Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
module Ping = BslPingRegister.M
module Client = BslPingRegister.Client
(** 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].*)
val call : 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 () = 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 call fun_id args k cid =
let id = generate_id () in
#<If:PING_DEBUG>
Logger.debug "[RPC] Try to call rpc %s on client %s"
fun_id (Client.key_to_string cid);
#<End>;
Hashtbl.add rpc_ids id k;
(* TODOK1 : args is a string but it should be a json! *)
let mess = Client.RPC (string_of_int id, fun_id, JsonTypes.String args) in
if Ping.mem cid then (
Ping.send mess cid;
true
) else false
let return id response =
try
let id = int_of_string id in
try
#<If:PING_DEBUG>
Logger.debug "[RPC] Return %d received" id;
#<End>;
let k = Hashtbl.find rpc_ids id in
Hashtbl.remove rpc_ids id;
QmlCpsServerLib.push_cont k response;
true
with Not_found ->
Logger.error "[RPC] Any continuation stored for %d" id;
false
with Failure "int_of_string" ->
Logger.error "[RPC] Identifier %s isn't an int" id;
false
end
(** 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 : string, string, continuation('a), 'ctx -> bool
let call fun_id args k key =
RPC.call 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 =
try
Some (Obj.obj (Hashtbl.find rpctbl name))
with Not_found -> None
##endmodule