From 4c5cd893d37da110876f53baad71826bfabafaea Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Fri, 23 May 2014 11:08:34 +0200 Subject: [PATCH 1/2] Add stop parameters in main-loop of server --- lib/lwt_unix_conduit.ml | 9 +++++---- lib/lwt_unix_conduit.mli | 1 + lib/lwt_unix_net.ml | 8 ++++---- lib/lwt_unix_net.mli | 1 + lib/lwt_unix_net_ssl.ml | 7 ++++--- lib/lwt_unix_net_ssl.mli | 1 + 6 files changed, 16 insertions(+), 11 deletions(-) diff --git a/lib/lwt_unix_conduit.ml b/lib/lwt_unix_conduit.ml index 488d34b7..ef68ac8f 100644 --- a/lib/lwt_unix_conduit.ml +++ b/lib/lwt_unix_conduit.ml @@ -41,15 +41,16 @@ ELSE | `TCP -> LUN.Tcp_client.connect sa END -let serve ~mode ~sockaddr ?timeout callback = +let serve ~mode ~sockaddr ?stop ?timeout callback = IFDEF HAVE_LWT_SSL THEN match mode with - | `TCP -> LUN.Tcp_server.init ~sockaddr ?timeout callback + | `TCP -> LUN.Tcp_server.init ~sockaddr ?stop ?timeout callback | `SSL (`Crt_file_path certfile, `Key_file_path keyfile) -> - Lwt_unix_net_ssl.Server.init ~certfile ~keyfile ?timeout sockaddr callback + Lwt_unix_net_ssl.Server.init ~certfile ~keyfile + ?stop ?timeout sockaddr callback ELSE match mode with - | `TCP -> LUN.Tcp_server.init ~sockaddr ?timeout callback + | `TCP -> LUN.Tcp_server.init ~sockaddr ?stop ?timeout callback | `SSL (`Crt_file_path certfile, `Key_file_path keyfile) -> fail (Failure "No SSL support compiled into Conduit") END diff --git a/lib/lwt_unix_conduit.mli b/lib/lwt_unix_conduit.mli index d8dd0086..4a021db1 100644 --- a/lib/lwt_unix_conduit.mli +++ b/lib/lwt_unix_conduit.mli @@ -31,6 +31,7 @@ val connect : val serve : mode:server_mode -> sockaddr:Lwt_unix.sockaddr -> + ?stop:(unit -> bool) -> ?timeout:int -> (ic -> oc -> unit io) -> unit io val close_in : 'a Lwt_io.channel -> unit diff --git a/lib/lwt_unix_net.ml b/lib/lwt_unix_net.ml index 731fe11a..8807e9b5 100644 --- a/lib/lwt_unix_net.ml +++ b/lib/lwt_unix_net.ml @@ -58,17 +58,17 @@ module Tcp_server = struct Lwt_unix.setsockopt client Lwt_unix.TCP_NODELAY true; let ic = Lwt_io.of_fd ~mode:Lwt_io.input client in let oc = Lwt_io.of_fd ~mode:Lwt_io.output client in - + let c = callback ic oc in let events = match timeout with |None -> [c] |Some t -> [c; (Lwt_unix.sleep (float_of_int t)) ] in let _ = Lwt.pick events >>= fun () -> close (ic,oc) in return () - - let init ~sockaddr ?timeout callback = + + let init ~sockaddr ?(stop = (fun () -> true)) ?timeout callback = let s = init_socket sockaddr in - while_lwt true do + while_lwt (stop ()) do Lwt_unix.accept s >>= process_accept ?timeout callback done diff --git a/lib/lwt_unix_net.mli b/lib/lwt_unix_net.mli index af528f30..4d4846a2 100644 --- a/lib/lwt_unix_net.mli +++ b/lib/lwt_unix_net.mli @@ -32,6 +32,7 @@ module Tcp_server : sig val init : sockaddr:Lwt_unix.sockaddr -> + ?stop:(unit -> bool) -> ?timeout:int -> (input channel -> output channel -> unit Lwt.t) -> unit Lwt.t diff --git a/lib/lwt_unix_net_ssl.ml b/lib/lwt_unix_net_ssl.ml index 09dd160a..b1e6fec4 100644 --- a/lib/lwt_unix_net_ssl.ml +++ b/lib/lwt_unix_net_ssl.ml @@ -67,13 +67,14 @@ module Server = struct let _ = Lwt.pick events >>= fun () -> close (ic,oc) in return () - let init ?(nconn=20) ?password ~certfile ~keyfile ?timeout sa callback = + let init ?(nconn=20) ?password ~certfile ~keyfile + ?(stop = (fun () -> true)) ?timeout sa callback = let s = listen ~nconn ?password ~certfile ~keyfile sa in let cont = ref true in - while_lwt !cont do + while_lwt !cont && (stop ()) do try_lwt begin accept s >>= process_accept ~timeout callback - end with + end with | Lwt.Canceled -> cont := false; return () | _ -> return () done diff --git a/lib/lwt_unix_net_ssl.mli b/lib/lwt_unix_net_ssl.mli index 0d88e61f..3cdfa81e 100644 --- a/lib/lwt_unix_net_ssl.mli +++ b/lib/lwt_unix_net_ssl.mli @@ -38,6 +38,7 @@ module Server : sig ?password:(bool -> string) -> certfile:string -> keyfile:string -> + ?stop:(unit -> bool) -> ?timeout:int -> Lwt_unix.sockaddr -> (Lwt_io.input_channel -> Lwt_io.output_channel -> unit Lwt.t) -> From 944960ae9a7698fe90474b0c9d686f0b6f0d8baf Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Tue, 27 May 2014 16:23:02 +0200 Subject: [PATCH 2/2] Stop action is deferred in new thread --- lib/lwt_unix_conduit.mli | 2 +- lib/lwt_unix_net.ml | 7 +++++-- lib/lwt_unix_net.mli | 2 +- lib/lwt_unix_net_ssl.ml | 6 ++++-- lib/lwt_unix_net_ssl.mli | 2 +- 5 files changed, 12 insertions(+), 7 deletions(-) diff --git a/lib/lwt_unix_conduit.mli b/lib/lwt_unix_conduit.mli index 4a021db1..eebf436c 100644 --- a/lib/lwt_unix_conduit.mli +++ b/lib/lwt_unix_conduit.mli @@ -31,7 +31,7 @@ val connect : val serve : mode:server_mode -> sockaddr:Lwt_unix.sockaddr -> - ?stop:(unit -> bool) -> + ?stop:(unit Lwt.t) -> ?timeout:int -> (ic -> oc -> unit io) -> unit io val close_in : 'a Lwt_io.channel -> unit diff --git a/lib/lwt_unix_net.ml b/lib/lwt_unix_net.ml index 8807e9b5..7ea55b8f 100644 --- a/lib/lwt_unix_net.ml +++ b/lib/lwt_unix_net.ml @@ -66,9 +66,12 @@ module Tcp_server = struct let _ = Lwt.pick events >>= fun () -> close (ic,oc) in return () - let init ~sockaddr ?(stop = (fun () -> true)) ?timeout callback = + let init ~sockaddr ?(stop = fst (Lwt.wait ())) ?timeout callback = + let cont = ref true in let s = init_socket sockaddr in - while_lwt (stop ()) do + + Lwt.async (fun () -> stop >>= fun () -> cont := false; Lwt.return ()); + while_lwt !cont do Lwt_unix.accept s >>= process_accept ?timeout callback done diff --git a/lib/lwt_unix_net.mli b/lib/lwt_unix_net.mli index 4d4846a2..4b7eab0c 100644 --- a/lib/lwt_unix_net.mli +++ b/lib/lwt_unix_net.mli @@ -32,7 +32,7 @@ module Tcp_server : sig val init : sockaddr:Lwt_unix.sockaddr -> - ?stop:(unit -> bool) -> + ?stop:(unit Lwt.t) -> ?timeout:int -> (input channel -> output channel -> unit Lwt.t) -> unit Lwt.t diff --git a/lib/lwt_unix_net_ssl.ml b/lib/lwt_unix_net_ssl.ml index b1e6fec4..18274c76 100644 --- a/lib/lwt_unix_net_ssl.ml +++ b/lib/lwt_unix_net_ssl.ml @@ -68,10 +68,12 @@ module Server = struct return () let init ?(nconn=20) ?password ~certfile ~keyfile - ?(stop = (fun () -> true)) ?timeout sa callback = + ?(stop = fst (Lwt.wait ())) ?timeout sa callback = let s = listen ~nconn ?password ~certfile ~keyfile sa in let cont = ref true in - while_lwt !cont && (stop ()) do + + Lwt.async (fun () -> stop >>= fun () -> cont := false; Lwt.return ()); + while_lwt !cont do try_lwt begin accept s >>= process_accept ~timeout callback end with diff --git a/lib/lwt_unix_net_ssl.mli b/lib/lwt_unix_net_ssl.mli index 3cdfa81e..b54930b2 100644 --- a/lib/lwt_unix_net_ssl.mli +++ b/lib/lwt_unix_net_ssl.mli @@ -38,7 +38,7 @@ module Server : sig ?password:(bool -> string) -> certfile:string -> keyfile:string -> - ?stop:(unit -> bool) -> + ?stop:(unit Lwt.t) -> ?timeout:int -> Lwt_unix.sockaddr -> (Lwt_io.input_channel -> Lwt_io.output_channel -> unit Lwt.t) ->