X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_tcp_server.ml;h=cbe01add1f9d10ec37c9f8d2eda334b937b26083;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=f457e050a4bbf4bdfbe0270df84c5b089eccbb9d;hpb=49b2f18c645a86c950bdfcd241329afe37da4d7e;p=helm.git diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.ml b/helm/DEVEL/ocaml-http/http_tcp_server.ml index f457e050a..cbe01add1 100644 --- a/helm/DEVEL/ocaml-http/http_tcp_server.ml +++ b/helm/DEVEL/ocaml-http/http_tcp_server.ml @@ -2,28 +2,28 @@ (* OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - Copyright (C) <2002> Stefano Zacchiroli + Copyright (C) <2002-2005> 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. + it under the terms of the GNU Library General Public License as + published by the Free Software Foundation, version 2. 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. + GNU Library 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 + You should have received a copy of the GNU Library 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;; +exception Timeout -let backlog = 10;; +let backlog = 10 (** if timeout is given (Some _) @return a new callback which establish timeout_callback as callback for signal Sys.sigalrm and register an alarm @@ -35,7 +35,7 @@ let wrap_callback_w_timeout ~callback ~timeout ~timeout_callback = | Some timeout -> (* wrap callback setting an handler for ALRM signal and an alarm that ring after timeout seconds *) (fun inchan outchan -> - ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle ~timeout_callback)); + ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_callback)); ignore (Unix.alarm timeout); callback inchan outchan) @@ -70,18 +70,9 @@ let init_callback callback timeout = in wrap_callback_w_timeout ~callback ~timeout ~timeout_callback - (** 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 - exit 2 - in - Unix.establish_server - (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback) - sockaddr + (** 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 *) @@ -89,7 +80,7 @@ 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 *) + (** "double fork" trick, see {!Unix.establish_server} implementation *) match Unix.fork() with | 0 -> (* parent *) (try @@ -98,9 +89,7 @@ let my_establish_server server_fun sockaddr = 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; *) + try_close_out outchan; (* closes also inchan: socket is the same *) exit 0 with e -> shutdown_socket suck; (* clean up socket before exit *) @@ -112,6 +101,7 @@ let my_establish_server server_fun sockaddr = failwith "Can't fork" done + (** tcp_server which forks a new process for each request *) let fork ~sockaddr ~timeout callback = let timeout_callback signo = if signo = Sys.sigalrm then @@ -121,7 +111,6 @@ let fork ~sockaddr ~timeout callback = (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 = @@ -138,7 +127,7 @@ let simple ~sockaddr ~timeout callback = callback inchan outchan; ignore (Unix.alarm 0) (* reset alarm *) with Timeout -> ()); - close_out outchan (* this close also inchan: socket is the same *) + try_close_out outchan (* this close also inchan: socket is the same *) done with e -> (* clean up socket before exit *) shutdown_socket suck; @@ -149,14 +138,14 @@ let thread ~sockaddr ~timeout callback = let suck = init_socket sockaddr in let callback = init_callback callback timeout in let callback (i, o) = - try - callback i o; - close_out o + (try + callback i o with - | Timeout -> close_out o + | Timeout -> () | e -> - close_out o; - raise e + try_close_out o; + raise e); + try_close_out o in while true do let (client, _) = nice_unix_accept suck in @@ -167,3 +156,17 @@ let thread ~sockaddr ~timeout callback = Http_threaded_tcp_server.serve callback (inchan, outchan) done + (** @param server an Http_types.tcp_server + * @return an Http_types.tcp_server which takes care of ignoring SIGPIPE during + * server execution and restoring previous handler when (if ever) the server + * returns *) +let handle_sigpipe server = + fun ~sockaddr ~timeout callback -> + let old_sigpipe_behavior = Sys.signal Sys.sigpipe Sys.Signal_ignore in + server ~sockaddr ~timeout callback; + ignore (Sys.signal Sys.sigpipe old_sigpipe_behavior) + +let simple = handle_sigpipe simple +let thread = handle_sigpipe thread +let fork = handle_sigpipe fork +