From 06b8d09156d9afbedb853aadad2d54220dcddf1e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Fri, 24 Jan 2020 18:49:57 +0100
Subject: [PATCH] [server/zmq] background server
---
src/plugins/server/main.ml | 1 +
src/plugins/server/server_zmq.ml | 70 +++++++++++++++++++++-----------
2 files changed, 48 insertions(+), 23 deletions(-)
diff --git a/src/plugins/server/main.ml b/src/plugins/server/main.ml
index d9212a6abdb..77497270548 100644
--- a/src/plugins/server/main.ml
+++ b/src/plugins/server/main.ml
@@ -297,6 +297,7 @@ let stop server =
| Some db ->
begin
server.background <- None ;
+ signal false ;
Db.progress := db ;
end
diff --git a/src/plugins/server/server_zmq.ml b/src/plugins/server/server_zmq.ml
index 3beb162451a..05a2b23d7ec 100644
--- a/src/plugins/server/server_zmq.ml
+++ b/src/plugins/server/server_zmq.ml
@@ -32,12 +32,19 @@ module Senv = Server_parameters
let zmq_group = Senv.add_group "Protocol ZeroMQ"
let () = Parameter_customize.set_group zmq_group
-module Enabled = Senv.String
+module Socket = Senv.String
(struct
let option_name = "-server-zmq"
let arg_name = "url"
let default = ""
- let help = "Establish a ZeroMQ server and listen for connections"
+ let help = "Setup the ZeroMQ server (in background)."
+ end)
+
+let () = Parameter_customize.set_group zmq_group
+module Run = Senv.Action
+ (struct
+ let option_name = "-server-zmq-run"
+ let help = "Launch the ZeroMQ server (until shutdown)."
end)
let _ = Doc.page `Protocol ~title:"ZeroMQ Protocol" ~filename:"server_zmq.md"
@@ -46,7 +53,7 @@ let _ = Doc.page `Protocol ~title:"ZeroMQ Protocol" ~filename:"server_zmq.md"
(* --- ZMQ Context --- *)
(* -------------------------------------------------------------------------- *)
-let context =
+let zmq_context =
let zmq = ref None in
fun () ->
match !zmq with
@@ -117,26 +124,43 @@ let fetch socket () =
(* --- Establish the Server --- *)
(* -------------------------------------------------------------------------- *)
-let establish url =
- if url <> "" then
- begin
- let context = context () in
- let socket = Zmq.Socket.(create context rep) in
- try
- Zmq.Socket.bind socket url ;
- Senv.feedback "ZeroMQ [%s]" url ;
- Main.create ~pretty:Format.pp_print_string ~fetch:(fetch socket) ()
- |> Main.run ;
- Zmq.Socket.close socket ;
- with exn ->
- Zmq.Socket.close socket ;
- raise exn
- end
+let pretty = Format.pp_print_string
+let background = ref None
-(* -------------------------------------------------------------------------- *)
-(* --- Establish the Server from Command line --- *)
-(* -------------------------------------------------------------------------- *)
-
-let () = Db.Main.extend (fun () -> establish (Enabled.get ()))
+let cmdline () =
+ begin
+ match !background with
+ | Some server ->
+ if Run.get () then Main.run server
+ | None ->
+ let url = Socket.get () in
+ if url <> "" then
+ let context = zmq_context () in
+ let socket = Zmq.Socket.(create context rep) in
+ try
+ Zmq.Socket.bind socket url ;
+ let server = Main.create ~pretty ~fetch:(fetch socket) () in
+ background := Some server ;
+ at_exit begin fun () ->
+ Senv.feedback "ZeroMQ [%s] stopped" url ;
+ Zmq.Socket.close socket ;
+ background := None ;
+ end ;
+ if Run.get () then
+ begin
+ Senv.feedback "ZeroMQ [%s] running" url ;
+ Main.run server
+ end
+ else
+ begin
+ Senv.feedback "ZeroMQ [%s] started" url ;
+ Main.start server
+ end
+ with exn ->
+ Zmq.Socket.close socket ;
+ raise exn
+ end
+
+let () = Db.Main.extend cmdline
(* -------------------------------------------------------------------------- *)
--
GitLab