Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

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

  • Loading branch information...
commit edb1ac8ddf5e46c1f43833ae1e1a0150271726d1 1 parent 24b904f
Hugo Heuzard authored
View
35 opabsl/mlbsl/bslClientEvent.ml
@@ -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
3  opabsl/mlbsl/bslCps.ml
@@ -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)
View
23 opabsl/mlbsl/bslDispatcher.ml
@@ -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);
View
2  opabsl/mlbsl/bslPingRegister.ml
@@ -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)
View
158 oparuntime/pingRegister.ml
@@ -22,6 +22,7 @@ module RD = Requestdef
module HS = HttpServer
module HSC = HttpServerCore
module HST = HttpServerTypes
+module Hashtbl = BaseHashtbl
type json = JS.json
@@ -52,26 +53,27 @@ let ping_info level fmt =
let ping_error level fmt =
Logger.error ("[PING][%s] "^^fmt^^"%!") level
-let send_txt_response winfo txt =
+let send_txt_response winfo txt code =
winfo.HST.cont (HS.make_response_modified_since
(Time.now ())
winfo.HST.request
- Requestdef.SC_OK
+ code
"text/plain, charset=utf-8"
(Http_common.Result txt))
-let send_json_response winfo json =
+let send_json_response winfo json code =
let txt = Json_utils.to_string json in
#<If>
ping_debug "SEND" "Sending json (%s)" txt;
#<End>;
- send_txt_response winfo txt
+ send_txt_response winfo txt code
let send_unmodified winfo txt =
winfo.HST.cont (HS.make_response ~req:winfo.HST.request Requestdef.SC_NotModified
"text/plain" (Http_common.Result txt))
-let disconnection_state_delay = 120 * 1000
+let disconnection_state_delay = ref (120 * 1000)
+let inactive_state_delay = ref None
let ping_delay_client_msecond_rush = 3 * 1000
let ping_delay_client_msecond_normal = 30 * 1000
@@ -83,6 +85,7 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
type event =
| Connect
| Disconnect
+ | Inactive
(** Type of a ping(/pang) loop response. *)
type response =
@@ -95,6 +98,7 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
let event_to_string = function
| Connect -> "Connect"
| Disconnect -> "Disconnect"
+ | Inactive -> "Inactive"
(** Make a json response which may be interpreted by client ping
loop. *)
@@ -107,7 +111,10 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
("id", JS.Int id);]
let send_response winfo response =
- send_json_response winfo (response_to_json response)
+ send_json_response winfo (response_to_json response) Requestdef.SC_OK
+
+ let send_error winfo reason =
+ send_txt_response winfo reason Requestdef.SC_ResetContent
(** Manage communications with clients *)
module Entry : sig
@@ -154,6 +161,8 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
(** Return a result of a pang. *)
val return : C.key -> int -> string -> unit
+ val send_error : C.key -> string -> unit
+
end = struct
type t =
@@ -287,7 +296,8 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
send_with_winfo key winfo q;
if (Queue.is_empty q) then remove key
)
- with Not_found -> add key (Ajax_call (winfo, nb, sleep_pong ()))
+ with Not_found ->
+ add key (Ajax_call (winfo, nb, sleep_pong ()))
in
if Hashtbl.mem pang_tbl key then
let map = Hashtbl.find pang_tbl key in
@@ -334,6 +344,16 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
| _ -> add_to_pang_tbl ()
with Not_found -> add_to_pang_tbl ()
+ let send_error key msg =
+ try
+ match find key with
+ | Ajax_call (winfo, _, sk) ->
+ S.abort sk;
+ remove key;
+ send_error winfo msg
+ | _ -> remove key
+ with Not_found -> ()
+
end
(** Manage the status of connection with client *)
@@ -371,7 +391,7 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
val ping : C.key -> HST.web_info -> int -> unit
(** Like ping but allows to reply with [Entry.return] *)
- val pang : C.key -> HST.web_info -> int -> unit
+ val pang : C.key -> HST.web_info -> int -> bool -> unit
(** Broadcast the json message. *)
val broadcast : C.msg -> unit
@@ -379,6 +399,18 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
(** Returns the number of connections. *)
val size : unit -> int
+ (** Sending the json message on the given client connection
+ identifier. *)
+ val send : C.msg -> C.key -> unit
+
+ (** Return a result of a pang. *)
+ val return : C.key -> int -> string -> unit
+
+ val update_activity : ?nb:int -> ?is_ping:bool -> ?is_active:bool ->
+ ?winfo:HST.web_info -> C.key -> bool
+
+ val set_inactive_delay : C.key option -> Time.t option -> unit
+
end = struct
type event_key = (C.key option * event * int)
@@ -390,7 +422,10 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
end)
(* Client identifier to last ping number. *)
- let state_tbl : (C.key, (int * S.async_key * int (* delay *))) Hashtbl.t =
+ let state_tbl : (C.key,(int *
+ S.async_key * int * (* Disconnection key and delay *)
+ S.async_key option * int option (* Inactivity key and delay *)
+ )) Hashtbl.t =
Hashtbl.create 512
(* Client identifier to event map that contains list of
@@ -461,32 +496,58 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
ping_debug "PING" "Remove the client %s" (C.key_to_string key);
#<End>;
raise_event key Disconnect;
- Entry.remove key;
- Hashtbl.remove state_tbl key;
+ Entry.send_error key "You've been disconnected by the server";
+ (* remove key; *)
+ (try
+ let (_, old_s, _,old_s2,_) = Hashtbl.find state_tbl key in
+ S.abort old_s;
+ Option.iter S.abort old_s2;
+ Hashtbl.remove state_tbl key;
+ with
+ | Not_found -> ());
remove_events key
- let update key (nb:int) =
- let s =
- S.sleep disconnection_state_delay
+ let update_activity ?(nb=0) ?(is_ping=false) ?(is_active=false) ?winfo key=
+ let will_disconnect t nb key =
+ S.sleep t
(fun () ->
- try
- let (n, _, _) = Hashtbl.find state_tbl key in
- if n=nb then delete key
- with Not_found -> delete key
+ try
+ let (n, _, _, _, _) = Hashtbl.find state_tbl key in
+ if n=nb then delete key
+ with Not_found -> delete key
) in
- try
- let (_, old_s, d) = Hashtbl.find state_tbl key in
- S.abort old_s; (* Abort the previous sleep *)
- Hashtbl.replace state_tbl key (nb, s, d)
- with
- | Not_found ->
- Hashtbl.add state_tbl key (nb, s, ping_delay_client_msecond_rush)
-
- let create key = update key 0
+ let will_raise_timeout t key =
+ S.sleep t (fun () -> raise_event key Inactive ) in
+ match Hashtbl.find_opt state_tbl key with
+ Some((_, old_s, d, old_s2, d2)) ->
+ let s =
+ if is_ping
+ then (S.abort old_s; will_disconnect !disconnection_state_delay nb key)
+ else old_s in
+ let s2 =
+ if is_active
+ then (Option.iter S.abort old_s2;
+ match Option.default (Option.default 0 !inactive_state_delay) d2 with
+ | 0 -> None
+ | n -> Some(will_raise_timeout n key))
+ else old_s2 in
+ Hashtbl.replace state_tbl key (nb, s, d, s2, d2);
+ true
+ | None ->
+ ignore(winfo);
+ let s = will_disconnect !disconnection_state_delay nb key in
+ let s2 =
+ match Option.default 0 !inactive_state_delay with
+ | 0 -> None
+ | n -> Some(will_raise_timeout n key) in
+ Hashtbl.add state_tbl key (nb, s, ping_delay_client_msecond_rush, s2, None);
+ true
+
+ let create key = ignore(update_activity ~is_ping:true ~nb:1 key)
let find_delay key =
try
- let (_, _, d) = Hashtbl.find state_tbl key in d
+ let (_, _, d, _, _) = Hashtbl.find state_tbl key in d
with
| Not_found ->
#<If>
@@ -494,10 +555,23 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
#<End>;
ping_delay_client_msecond_normal
+ let set_inactive_delay key_opt time_opt =
+ match key_opt with
+ | None -> inactive_state_delay:=Option.map Time.in_milliseconds time_opt
+ | Some key ->
+ let will_raise_timeout t key =
+ S.sleep t (fun () -> raise_event key Inactive ) in
+ try
+ let (n,s,d,s2,_) = Hashtbl.find state_tbl key in
+ let time = Option.map Time.in_milliseconds time_opt in
+ Option.iter S.abort s2;
+ Hashtbl.replace state_tbl key (n, s, d, Option.map (fun t -> will_raise_timeout t key) time, time)
+ with Not_found -> ()
+
let end_of_rush_delay key =
try
- let (n, s, _) = Hashtbl.find state_tbl key in
- Hashtbl.replace state_tbl key (n, s, ping_delay_client_msecond_normal)
+ let (n, s, _, s2, d2) = Hashtbl.find state_tbl key in
+ Hashtbl.replace state_tbl key (n, s, ping_delay_client_msecond_normal, s2, d2)
with
| Not_found ->
#<If>
@@ -521,17 +595,16 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
ping_debug "PING"
"PING(%d) received from %s" nb (C.key_to_string key);
#<End>;
- update key nb;
- Entry.ping ~crush:(nb = 1) ~find_delay:find_delay ~pong_callback:end_of_rush_delay key winfo nb
+ if update_activity ~is_ping:true ~nb key ~winfo
+ then Entry.ping ~crush:(nb=1) ~find_delay:find_delay ~pong_callback:end_of_rush_delay key winfo nb
-
- let pang key winfo nb =
+ let pang key winfo nb is_active =
#<If>
ping_debug "PING"
"PANG (%d) received from %s" nb (C.key_to_string key);
#<End>;
- update key nb;
- Entry.pang key winfo nb
+ if update_activity ~is_ping:true ~nb ~is_active key ~winfo
+ then Entry.pang key winfo nb
let broadcast mess =
#<If>
@@ -541,6 +614,13 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
let size () = Hashtbl.length state_tbl
+ let send msg key =
+ ignore(update_activity ~is_active:true key);
+ Entry.send msg key
+
+ let return key nb result =
+ ignore(update_activity ~is_active:true key);
+ Entry.return key nb result
end
type event_key = Connection.event_key
@@ -551,7 +631,7 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
let remove_event = Connection.remove_event
- let send = Entry.send
+ let send = Connection.send
let broadcast = Connection.broadcast
@@ -569,4 +649,8 @@ module Make (S : SCHEDULER) (C : CLIENT) = struct
let size = Connection.size
+ let update_activity = Connection.update_activity
+
+ let set_inactive_delay = Connection.set_inactive_delay
+
end
View
8 oparuntime/pingRegister.mli
@@ -52,6 +52,7 @@ module Make (S : SCHEDULER) (C : CLIENT) : sig
type event =
| Connect (** Launched when a client connects to ping register. *)
| Disconnect (** Launched when a client is disconnected to ping register. *)
+ | Inactive (** Launched when a client is inactive for a while *)
(** Type of key binded to an event handler (see section Events). *)
type event_key
@@ -73,7 +74,7 @@ module Make (S : SCHEDULER) (C : CLIENT) : sig
(** [pang id winfo nb] Like as [ping id winfo nb] but you can reply
to this specific [pang] with [return id nb response]. *)
- val pang : C.key -> HttpServerTypes.web_info -> int -> unit
+ val pang : C.key -> HttpServerTypes.web_info -> int -> bool -> unit
(** Returns a [pang]. *)
val return : C.key -> int -> string -> unit
@@ -89,6 +90,9 @@ module Make (S : SCHEDULER) (C : CLIENT) : sig
(** Remove callback event registered associated with [event_key]. *)
val remove_event : event_key -> unit
+ (** Set delay before raising an Inactive even. *)
+ val set_inactive_delay : C.key option -> Time.t option -> unit
+
(** {6 Utils} *)
(** Check if the client is already connected to the ping
@@ -104,4 +108,6 @@ module Make (S : SCHEDULER) (C : CLIENT) : sig
(** Return the number of connections. *)
val size : unit -> int
+ val update_activity : ?nb:int -> ?is_ping:bool -> ?is_active:bool -> ?winfo:HttpServerTypes.web_info -> C.key -> bool
+
end
View
68 stdlib/core/rpc/core/client_event.opa
@@ -19,6 +19,8 @@
@author Francois Pessaux
*/
+import stdlib.core.date
+
/**
* This file provides the primitives to bind client events to callbacks.
* This is especially important in order to keep trace of clients
@@ -47,7 +49,10 @@ ClientEvent = {{
*/
disconnect = %% BslClientEvent.disconnect %% : ClientEvent.t
-
+ /**
+ * Event value representing a client inactivity.
+ */
+ inactive = %% BslClientEvent.inactive %% : ClientEvent.t
/**
* Register (binds) a function (callback) to call when an event occurs for a
@@ -116,4 +121,65 @@ ClientEvent = {{
set_on_disconnect_client(callback : (ThreadContext.client -> void))
: ClientEventKey.t =
register_client_event(disconnect, callback)
+
+ /**
+ * Register (binds) a function (callback) to call when the client of the
+ * current thread context is inactive. If the current thread context has
+ * no client, an error is raised.
+ * Returns the id of the event registration in order to be able to remove the
+ * binding of the inativity event to this function if needed.
+ * An inactive event is raised if there is no communication between client and server for a while.
+ * In this case the ping loop isn't considered as a communication.
+ *
+ * @param callback The function called when the inactive event arises.
+ * @return The id of the binding event/callback registration.
+ */
+ set_on_inactive_client(callback : (ThreadContext.client -> void))
+ : ClientEventKey.t =
+ register_client_event(inactive, callback)
+
+ /**
+ * Set the duration before raising an "inactive" event.
+ *
+ * @param opt_client The id of the client affected by this setting or {!none} if global setting.
+ * @param delay The duration before raising an "inactive" event.
+ * @return void.
+ */
+ set_inactivity_delay(ctx : option(ThreadContext.client), delay : Duration.duration) : void =
+ time = Duration.in_milliseconds(delay)
+ (%% BslClientEvent.set_inactive_delay %%)(ctx,some(time))
+
+ /**
+ * Remove the duration before raising an "inactive" event.
+ *
+ * @param opt_client The id of the client affected by this setting or {!none} if global setting.
+ * @return void.
+ */
+ remove_inactivity_delay(ctx : option(ThreadContext.client)) : void =
+ (%% BslClientEvent.set_inactive_delay %%)(ctx,none)
+
+ // Commented because we miss some more feature to handle disconnection client side
+
+ // /**
+ // * Disconnect the client corresponding to the ThreadContext.client
+ // *
+ // * @param ctx The id of the client to disconnect.
+ // * @return void.
+ // */
+ // disconnect_client(ctx : ThreadContext.client) : void =
+ // (%%BslPingRegister.client_stop%%)(ctx)
+
+ // /**
+ // * Disconnect the current client. If the current thread context
+ // * has no client, an error is raised.
+ // *
+ // * @return void.
+ // */
+ // disconnect_current() : void =
+ // match ThreadContext.get({current}).key with
+ // | { client = thread_ctxt_client } ->
+ // disconnect_client(thread_ctxt_client)
+ // | _ ->
+ // @fail("disconnect_current: no client in the current context.")
+
}}
Please sign in to comment.
Something went wrong with that request. Please try again.