diff --git a/src/plugins/server/main.ml b/src/plugins/server/main.ml index cb05bfcbba2d085502aa3310cde0a256a7839f63..bd818b73dc8dcb990c9839ed524bc2fdd642843b 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 4437c2bb0ccf863d7152cab567029a464669565a..9a34b14a7f046a5ef2c3064f13280439cdbcd9ac 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 098043231a9e94a104993aa63e7b7e7d79457565..ad7f6ec50c6f2a561704bc1a1262dcd84fa444bd 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 e394c7a0dce4aff444eca05f0091c8f11a41a5d0..14e1a565476e15fe020f6c87b3f86463d10d8576 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)].