From 266e9339d03758e0029d1650f8bce36196136655 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Sun, 16 Feb 2020 14:42:59 +0100
Subject: [PATCH] [server] signal activity notification
---
src/plugins/server/main.ml | 67 +++++++++++++++++++++++-----------
src/plugins/server/main.mli | 7 ++++
src/plugins/server/request.ml | 1 +
src/plugins/server/request.mli | 6 +++
4 files changed, 59 insertions(+), 22 deletions(-)
diff --git a/src/plugins/server/main.ml b/src/plugins/server/main.ml
index cb05bfcbba2..bd818b73dc8 100644
--- a/src/plugins/server/main.ml
+++ b/src/plugins/server/main.ml
@@ -175,6 +175,33 @@ let execute server ?yield proc =
Senv.debug "%a" (pp_response server.pretty) resp ;
Stack.push resp server.q_out
+(* -------------------------------------------------------------------------- *)
+(* --- Signals --- *)
+(* -------------------------------------------------------------------------- *)
+
+type signal = string
+let signals = Hashtbl.create 32
+let signal s =
+ if Hashtbl.mem signals s then
+ ( Server_parameters.failure "Signal '%s' already registered" s ; "" )
+ else
+ ( Hashtbl.add signals s [] ; s )
+
+let () = Hashtbl.add signals "" []
+
+let on_signal s callback =
+ let ds = Hashtbl.find signals s in
+ Hashtbl.replace signals s (callback :: ds)
+
+let notify s a =
+ match Hashtbl.find signals s with
+ | ds -> List.iter (fun f -> f a) ds
+ | exception Not_found -> ()
+
+let nop _s = ()
+let emitter = ref nop
+let emit s = !emitter s
+
(* -------------------------------------------------------------------------- *)
(* --- Processing Requests --- *)
(* -------------------------------------------------------------------------- *)
@@ -195,8 +222,16 @@ let process_request (server : 'a server) (request : 'a request) : unit =
Stack.clear server.q_out ;
server.shutdown <- true ;
end
- | `SigOn sg -> server.s_active <- Sigs.add sg server.s_active
- | `SigOff sg -> server.s_active <- Sigs.remove sg server.s_active
+ | `SigOn sg ->
+ begin
+ server.s_active <- Sigs.add sg server.s_active ;
+ notify sg true ;
+ end
+ | `SigOff sg ->
+ begin
+ server.s_active <- Sigs.remove sg server.s_active ;
+ notify sg false ;
+ end
| `Kill id ->
begin
let set_killed = kill_request server.equal id in
@@ -257,31 +292,19 @@ let do_signal server s =
end
(* -------------------------------------------------------------------------- *)
-(* --- Signals --- *)
+(* --- One Step Process --- *)
(* -------------------------------------------------------------------------- *)
-type signal = string
-let signals = Hashtbl.create 32
-let signal s =
- if Hashtbl.mem signals s then
- ( Server_parameters.failure "Signal '%s' already registered" s ; "" )
+let rec fetch_exec q =
+ if Queue.is_empty q then None
else
- ( Hashtbl.add signals s () ; s )
-
-let () = Hashtbl.add signals "" ()
-let nop _s = ()
-let emitter : (string -> unit) ref = ref nop
-let signal s = !emitter s
-
-(* -------------------------------------------------------------------------- *)
-(* --- One Step Process --- *)
-(* -------------------------------------------------------------------------- *)
+ let e = Queue.pop q in
+ if e.killed then fetch_exec q else Some e
let process server =
- if Queue.is_empty server.q_in then
- communicate server
- else
- let proc = Queue.pop server.q_in in
+ match fetch_exec server.q_in with
+ | None -> communicate server
+ | Some proc ->
server.running <- Some proc ;
try
execute server ~yield:(do_yield server) proc ;
diff --git a/src/plugins/server/main.mli b/src/plugins/server/main.mli
index 4437c2bb0cc..9a34b14a7f0 100644
--- a/src/plugins/server/main.mli
+++ b/src/plugins/server/main.mli
@@ -113,6 +113,13 @@ val kill : unit -> 'a
(** Emits the server signal to the client. *)
val emit : signal -> unit
+(** Register a callback on signal listening.
+
+ The callback is invoked with [true] on [SIGON] command
+ and [false] on [SIGOFF].
+*)
+val on_signal : signal -> (bool -> unit) -> unit
+
(** Register a callback to listen for server activity.
All callbacks would be executed in their order of registration.
They shall {i never} raise any exception. *)
diff --git a/src/plugins/server/request.ml b/src/plugins/server/request.ml
index 098043231a9..ad7f6ec50c6 100644
--- a/src/plugins/server/request.ml
+++ b/src/plugins/server/request.ml
@@ -99,6 +99,7 @@ let signal ~page ~name ~descr ?(details=[]) () =
in Main.signal name
let emit = Main.emit
+let on_signal = Main.on_signal
(* -------------------------------------------------------------------------- *)
(* --- Multiple Fields Requests --- *)
diff --git a/src/plugins/server/request.mli b/src/plugins/server/request.mli
index e394c7a0dce..14e1a565476 100644
--- a/src/plugins/server/request.mli
+++ b/src/plugins/server/request.mli
@@ -48,6 +48,7 @@ type 'b output = (module Output with type t = 'b)
type signal
+(** Register a server signal. The signal [name] must be unique. *)
val signal :
page:Doc.page ->
name:string ->
@@ -55,8 +56,13 @@ val signal :
?details:Markdown.block ->
unit -> signal
+(** Emit the signal to the client. *)
val emit : signal -> unit
+(** Callback invoked each time the client is starting or stopping
+ to listen to the given signal. *)
+val on_signal : signal -> (bool -> unit) -> unit
+
(** {2 Simple Requests Registration} *)
(** Register a simple request of type [(a -> b)].
--
GitLab