diff --git a/src/plugins/server/main.ml b/src/plugins/server/main.ml index 30f6d86398396038e9833d9ef9c14da8f747a0a3..cb05bfcbba2d085502aa3310cde0a256a7839f63 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 a524000e97241ddd119657f72cab4929daf2c432..4437c2bb0ccf863d7152cab567029a464669565a 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 ba522a19fec051169c772e9d0c66043f4a18972e..098043231a9e94a104993aa63e7b7e7d79457565 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 2c4347f76a9a564d6f42031d1dd506f016f6a92f..e394c7a0dce4aff444eca05f0091c8f11a41a5d0 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)].