- added sigpipe handling to avoid processes get killed by unhandled

[helm.git] / helm / DEVEL / ocaml-http / http_tcp_server.ml

diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.ml b/helm/DEVEL/ocaml-http/http_tcp_server.ml
index 699e8cfdce5abcbb5a03898ca4887f640fb5405c..a4aaf924771177c147cd13e289d5a644b45725b0 100644 (file)
--- a/helm/DEVEL/ocaml-http/http_tcp_server.ml
+++ b/helm/DEVEL/ocaml-http/http_tcp_server.ml
@@ -21,9 +21,9 @@
 
 
   (** 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
@@ -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 *)
@@ -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
+