From 18d891e06e68da5e2295c93d8dd85fabea05cac8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Thu, 13 Feb 2020 17:55:59 +0100
Subject: [PATCH] [server] registered & documented signals
---
src/plugins/server/main.ml | 13 +++++++++++++
src/plugins/server/main.mli | 13 ++++++++++---
src/plugins/server/request.ml | 19 +++++++++++++++++++
src/plugins/server/request.mli | 13 +++++++++++++
4 files changed, 55 insertions(+), 3 deletions(-)
diff --git a/src/plugins/server/main.ml b/src/plugins/server/main.ml
index 30f6d863983..cb05bfcbba2 100644
--- a/src/plugins/server/main.ml
+++ b/src/plugins/server/main.ml
@@ -256,6 +256,19 @@ let do_signal server s =
Stack.push (`Signal s) server.q_out ;
end
+(* -------------------------------------------------------------------------- *)
+(* --- 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 nop _s = ()
let emitter : (string -> unit) ref = ref nop
let signal s = !emitter s
diff --git a/src/plugins/server/main.mli b/src/plugins/server/main.mli
index a524000e972..4437c2bb0cc 100644
--- a/src/plugins/server/main.mli
+++ b/src/plugins/server/main.mli
@@ -37,6 +37,13 @@ val register : kind -> string -> (json -> json) -> unit
val find : string -> (kind * (json -> json)) option
val exec : string -> json -> json (** @raises Not_found if not registered *)
+(* -------------------------------------------------------------------------- *)
+(** {2 Signals Registry} *)
+(* -------------------------------------------------------------------------- *)
+
+type signal
+val signal : string -> signal
+
(* -------------------------------------------------------------------------- *)
(** {2 Server Main Process} *)
(* -------------------------------------------------------------------------- *)
@@ -103,12 +110,12 @@ val stop : 'a server -> unit
(** Kills the currently running request. Actually raises an exception. *)
val kill : unit -> 'a
+(** Emits the server signal to the client. *)
+val emit : signal -> 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. *)
val on : (bool -> unit) -> unit
-(** Emits the server signal *)
-val signal : string -> unit
-
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/request.ml b/src/plugins/server/request.ml
index ba522a19fec..098043231a9 100644
--- a/src/plugins/server/request.ml
+++ b/src/plugins/server/request.ml
@@ -81,6 +81,25 @@ let check_page page name =
Senv.warning ~wkey:wkind
"Request '%s' shall not be published in protocol pages" name
+(* -------------------------------------------------------------------------- *)
+(* --- Signals --- *)
+(* -------------------------------------------------------------------------- *)
+
+type signal = Main.signal
+
+let signal ~page ~name ~descr ?(details=[]) () =
+ let open Markdown in
+ check_name name ;
+ check_page page name ;
+ let title = Printf.sprintf "`SIGNAL` %s" name in
+ let index = [ Printf.sprintf "%s (`SIGNAL`)" name ] in
+ let description = [ Block [Text descr] ; Block details] in
+ let _ =
+ Doc.publish ~page ~name ~title ~index description []
+ in Main.signal name
+
+let emit = Main.emit
+
(* -------------------------------------------------------------------------- *)
(* --- Multiple Fields Requests --- *)
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/request.mli b/src/plugins/server/request.mli
index 2c4347f76a9..e394c7a0dce 100644
--- a/src/plugins/server/request.mli
+++ b/src/plugins/server/request.mli
@@ -44,6 +44,19 @@ end
type 'a input = (module Input with type t = 'a)
type 'b output = (module Output with type t = 'b)
+(** {2 Signals} *)
+
+type signal
+
+val signal :
+ page:Doc.page ->
+ name:string ->
+ descr:Markdown.text ->
+ ?details:Markdown.block ->
+ unit -> signal
+
+val emit : signal -> unit
+
(** {2 Simple Requests Registration} *)
(** Register a simple request of type [(a -> b)].
--
GitLab