+ (* try to close nicely a socket *)
+let shutdown_socket suck =
+ try
+ Unix.shutdown suck Unix.SHUTDOWN_ALL
+ with Unix.Unix_error(_, "shutdown", "") -> ()
+
+let nice_unix_accept suck =
+ try
+ Unix.accept suck
+ with e -> (* clean up socket before exit *)
+ shutdown_socket suck;
+ raise e
+
+let init_socket sockaddr =
+ let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+ (* shutdown socket on SIGTERM *)
+ ignore (Sys.signal Sys.sigterm
+ (Sys.Signal_handle
+ (fun _ -> shutdown_socket suck; exit 17)));
+ Unix.setsockopt suck Unix.SO_REUSEADDR true;
+ Unix.bind suck sockaddr;
+ Unix.listen suck backlog;
+ suck
+
+let init_callback callback timeout =
+ let timeout_callback signo =
+ if signo = Sys.sigalrm then
+ raise Timeout
+ in
+ wrap_callback_w_timeout ~callback ~timeout ~timeout_callback
+
+ (** try to close an outchannel connected to a socket, ignore Sys_error since
+ * this probably means that socket is already closed (e.g. on sigpipe) *)
+let try_close_out ch = try close_out ch with Sys_error _ -> ()
+
+ (** like Unix.establish_server, but shutdown sockets when receiving SIGTERM
+ and before exiting for an uncaught exception *)
+let my_establish_server server_fun sockaddr =
+ let suck = init_socket sockaddr in
+ while true do
+ let (s, caller) = nice_unix_accept suck in
+ (** "double fork" trick, see {!Unix.establish_server} implementation *)
+ match Unix.fork() with
+ | 0 -> (* parent *)
+ (try
+ if Unix.fork () <> 0 then
+ exit 0; (* The son exits, the grandson works *)
+ let inchan = Unix.in_channel_of_descr s in
+ let outchan = Unix.out_channel_of_descr s in
+ server_fun inchan outchan;
+ try_close_out outchan; (* closes also inchan: socket is the same *)
+ exit 0
+ with e ->
+ shutdown_socket suck; (* clean up socket before exit *)
+ raise e)
+ | child when (child > 0) -> (* child *)
+ Unix.close s;
+ ignore (Unix.waitpid [] child) (* Reclaim the son *)
+ | _ (* < 0 *) ->
+ failwith "Can't fork"
+ done
+
+ (** tcp_server which forks a new process for each request *)
+let fork ~sockaddr ~timeout callback =