+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002-2005> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ 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 Library General Public License for more details.
+
+ 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
| 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)
+ (* 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;
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;
- let timeout_callback signo =
- if signo = Sys.sigalrm then
- raise Timeout
- in
- let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in
- (suck, 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 _ -> ()
- (** 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;
+ 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 =
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 -> ());
+ try_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) =
- 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, _) = 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)
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
+
projects / helm.git / blobdiff