From 49b2f18c645a86c950bdfcd241329afe37da4d7e Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Fri, 17 Jan 2003 14:50:05 +0000 Subject: [PATCH] - added support for shutdown of servers' socket on abnormal exits (actually SIGTERM or uncaught exceptions) - deprecated use of 'ocaml_builtin' server (removed from .mli too) --- helm/DEVEL/ocaml-http/http_tcp_server.ml | 125 +++++++++++++++++----- helm/DEVEL/ocaml-http/http_tcp_server.mli | 29 ++++- 2 files changed, 122 insertions(+), 32 deletions(-) diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.ml b/helm/DEVEL/ocaml-http/http_tcp_server.ml index 69da5c109..f457e050a 100644 --- a/helm/DEVEL/ocaml-http/http_tcp_server.ml +++ b/helm/DEVEL/ocaml-http/http_tcp_server.ml @@ -1,4 +1,25 @@ +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> Stefano Zacchiroli + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*) + + (** raised when a client timeouts *) exception Timeout;; @@ -18,8 +39,25 @@ let wrap_callback_w_timeout ~callback ~timeout ~timeout_callback = ignore (Unix.alarm timeout); callback inchan outchan) + (* 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; @@ -32,53 +70,82 @@ let init_callback callback timeout = in wrap_callback_w_timeout ~callback ~timeout ~timeout_callback -(* -let init_socket_and_callback sockaddr callback timeout = - let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - Unix.setsockopt suck Unix.SO_REUSEADDR true; - Unix.bind suck sockaddr; - Unix.listen suck backlog; + (** DEPRECATED and no longer visibile in .mli interface, this server has been + replaced by 'fork'! + tcp_server which use Unix.establish_server which in turn forks a child for + each request *) +let ocaml_builtin ~sockaddr ~timeout callback = let timeout_callback signo = if signo = Sys.sigalrm then - raise Timeout + exit 2 in - let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in - (suck, callback) -*) + Unix.establish_server + (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback) + sockaddr - (** 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 = let timeout_callback signo = if signo = Sys.sigalrm then exit 2 in - Unix.establish_server + my_establish_server (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback) sockaddr + (** tcp_server which doesn't fork, requests are server sequentially and in the same address space of the calling process *) let simple ~sockaddr ~timeout callback = -(* let (suck, callback) = init_socket_and_callback sockaddr callback timeout in *) let suck = init_socket sockaddr in let callback = init_callback callback timeout in - while true do - let (client, _) = Unix.accept suck in - (* client is now connected *) - let (inchan, outchan) = - (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client) - in - (try - callback inchan outchan; - ignore (Unix.alarm 0) (* reset alarm *) - with Timeout -> ()); - close_out outchan (* this close also inchan, because socket is the same *) - done + try + while true do + let (client, _) = Unix.accept suck in + (* client is now connected *) + let (inchan, outchan) = + (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client) + in + (try + callback inchan outchan; + ignore (Unix.alarm 0) (* reset alarm *) + with Timeout -> ()); + close_out outchan (* this close also inchan: socket is the same *) + done + with e -> (* clean up socket before exit *) + shutdown_socket suck; + raise e (** tcp_server which creates a new thread for each request to be served *) let thread ~sockaddr ~timeout callback = -(* let (suck, callback) = init_socket_and_callback sockaddr callback timeout in *) let suck = init_socket sockaddr in let callback = init_callback callback timeout in let callback (i, o) = @@ -92,7 +159,7 @@ let thread ~sockaddr ~timeout callback = raise e in while true do - let (client, _) = Unix.accept suck in + let (client, _) = nice_unix_accept suck in (* client is now connected *) let (inchan, outchan) = (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client) diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.mli b/helm/DEVEL/ocaml-http/http_tcp_server.mli index 881fb58fa..b6968254e 100644 --- a/helm/DEVEL/ocaml-http/http_tcp_server.mli +++ b/helm/DEVEL/ocaml-http/http_tcp_server.mli @@ -1,11 +1,34 @@ - (* servers *) +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + Copyright (C) <2002> Stefano Zacchiroli + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*) + + (** servers *) + + (** single process server *) val simple: Http_types.tcp_server -val ocaml_builtin: Http_types.tcp_server + (** multi threaded server *) val thread: Http_types.tcp_server + (** multi process server *) +val fork: Http_types.tcp_server - (* low level functions *) + (** low level functions *) val init_socket: Unix.sockaddr -> Unix.file_descr -- 2.39.2