- (** tcp_server which use Unix.establish_server which in turn forks a child for
- each request *)
-let ocaml_builtin ~sockaddr ~timeout callback =
+ (** 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;
+ close_out outchan;
+ (* The file descriptor was already closed by close_out. close_in
+ inchan; *)
+ 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
+
+let fork ~sockaddr ~timeout callback =