Permalink
Browse files

[feature] inactivity: of client is detected and raise Inactive event

  • Loading branch information...
1 parent 24b904f commit edb1ac8ddf5e46c1f43833ae1e1a0150271726d1 Hugo Heuzard committed Sep 20, 2011
@@ -31,6 +31,9 @@ let connect = BslPingRegister.M.Connect
##register disconnect : ClientEvent.t
let disconnect = BslPingRegister.M.Disconnect
+##register inactive : ClientEvent.t
+let inactive = BslPingRegister.M.Inactive
+
(* ************************************************************************** *)
(* Magic conversion of a [BslUtils.opa_threadcontext_client] into a
[BslPingRegister.Client.key]. Used by [register_event] below. *)
@@ -47,18 +50,32 @@ external bsl_pr_c_k_2_opa_tc_c :
BslPingRegister.Client.key -> BslUtils.opa_threadcontext_client =
"%identity"
-##register register_event : option(opa[ThreadContext.client]), \
- ClientEvent.t, \
- (opa[ThreadContext.client] -> void) -> \
- ClientEventKey.t
-let register_event opt_tcc ce cb =
+module Ping = BslPingRegister.M
+module Client = BslPingRegister.Client
+
+##register remove_event : ClientEventKey.t -> void
+let remove_event = Ping.remove_event
+
+##register set_inactive_delay : option(opa[ThreadContext.client]), \
+ option(int) -> void
+let set_inactive_delay opt_tcc opt_time =
+ let t = Option.map Time.milliseconds opt_time in
let opt_tcc' =
match opt_tcc with
| None -> None
| Some tcc -> Some (opa_tc_c_2_bsl_pr_c_k tcc) in
- let cb' x = cb (bsl_pr_c_k_2_opa_tc_c x) in
- BslPingRegister.M.register_event opt_tcc' ce cb'
+ Ping.set_inactive_delay opt_tcc' t
-##register remove_event : ClientEventKey.t -> void
-let remove_event = BslPingRegister.M.remove_event
+
+##register [cps-bypass] register_event : option(opa[ThreadContext.client])\
+ ,ClientEvent.t\
+ ,(opa[ThreadContext.client], continuation(opa[void]) -> void)\
+ ,continuation(ClientEventKey.t) -> void
+let register_event opt_tcc evt f k =
+ let opt_tcc' =
+ match opt_tcc with
+ | None -> None
+ | Some tcc -> Some (opa_tc_c_2_bsl_pr_c_k tcc) in
+ let f x = f (bsl_pr_c_k_2_opa_tc_c x) (QmlCpsServerLib.ccont_ml k (fun _ -> ())) in
+ QmlCpsServerLib.return k (Ping.register_event opt_tcc' evt f)
View
@@ -58,7 +58,8 @@ let qml_unit = ServerLib.make_record ServerLib.empty_record_constructor
(* thread_context needs a projection because of the returned option *)
##register [opacapi, no-projection : cps] thread_context \ `QmlCpsServerLib.thread_context` : continuation('a) -> option(opa['thread_context])
-##register [opacapi, no-projection, restricted : cps] with_thread_context \ `QmlCpsServerLib.with_thread_context` : opa['b], continuation('a) -> continuation('a)
+##register [opacapi, no-projection, restricted : cps] with_thread_context \ `QmlCpsServerLib.with_thread_context` : opa['b]\
+ ,continuation('a) -> continuation('a)
##register [opacapi, no-projection, restricted : cps] handler_cont \ `QmlCpsServerLib.handler_cont` : continuation('a) -> continuation('c)
##register [opacapi, no-projection : cps, restricted : cps] catch_native \ `QmlCpsServerLib.catch_ml` : \
(opa['c], continuation('a) -> _unit), continuation('a) -> continuation('a)
@@ -132,6 +132,7 @@ let complete_dispatcher_cps base_url dispatcher k =
)
| `internal "chan/send" ->
+ ignore(Ping.update_activity ~is_active:true key);
Option.iter
(fun () -> send_txt_response winfo "")
(need_cpr (fun c p r -> WebChannel.send c p r (Some context)))
@@ -170,7 +171,7 @@ let complete_dispatcher_cps base_url dispatcher k =
| JS.Record [("ping", JS.Int nb);
("uri", JS.String uri);
("body", JS.String body)] ->
- Ping.pang key winfo nb;
+ Ping.pang key winfo nb true;
let winfo = {
winfo with
HttpServerTypes.request = {
@@ -195,13 +196,14 @@ let complete_dispatcher_cps base_url dispatcher k =
} in
aux_complete_dispatcher winfo
| JS.Int nb ->
- Ping.pang key winfo nb
+ Ping.pang key winfo nb false
| _ -> send_error winfo "Bad formatted pang"
)
)
| `internal str ->
+ ignore(Ping.update_activity ~is_active:true key);
let get_id = Str.regexp "rpc_return/\\(.*\\)" in
if ((Str.string_match get_id str 0) && ((Str.matched_string str) = str)) then
let id = Str.matched_group 1 str in
@@ -214,7 +216,9 @@ let complete_dispatcher_cps base_url dispatcher k =
BslScheduler.push (fun () -> dispatcher winfo cont_with_context)
(* User urls *************************)
- | `user -> BslScheduler.push (fun () -> dispatcher winfo cont_with_context)
+ | `user ->
+ ignore(Ping.update_activity ~is_active:true key);
+ BslScheduler.push (fun () -> dispatcher winfo cont_with_context)
in QmlCpsServerLib.return k (QmlCpsServerLib.cont_ml aux_complete_dispatcher)
@@ -228,16 +232,3 @@ let complete_dispatcher base_url dispatcher winfo =
match !r with
| None -> failwith ("dispatcher was not computed - Do you use no cps?")
| Some wcont -> QmlCpsServerLib.execute wcont winfo
-
-##register [cps-bypass] register_event_disconnect_cps : option('ctx), (void, continuation(opa[void]) -> void), continuation(opa[void]) -> void
-let register_event_disconnect_cps ctx f k =
- let f _ = f () (QmlCpsServerLib.cont_ml (fun _ -> ())) in
- ignore (Ping.register_event ((Obj.magic ctx):Client.key option)
- Ping.Disconnect f);
- QmlCpsServerLib.return k (ServerLib.void)
-
-##register register_event_disconnect : option('ctx), (-> void) -> void
-let register_event_disconnect ctx f =
- let f _ = f () in
- ignore(Ping.register_event ((Obj.magic ctx):Client.key option)
- Ping.Disconnect f);
@@ -127,7 +127,7 @@ module M = PingRegister.Make(PingScheduler)(Client)
let client_start ck = M.create (Obj.magic ck)
##register nb_connection : -> int
-let nb_connection = M.size
+let nb_connection = M.size
##register client_stop : opa[ThreadContext.client] -> void
let client_stop ck = M.delete (Obj.magic ck)
Oops, something went wrong.

0 comments on commit edb1ac8

Please sign in to comment.