[server] registered & documented signals

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

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
-
 (* -------------------------------------------------------------------------- *)

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                                           --- *)
 (* -------------------------------------------------------------------------- *)

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)].