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=69da5c109ebd615364bea4e6b2c423a22e7e96a9;hpb=d1569b80cc7b9fd2ca7551f2eb74e2dc10b02443;p=helm.git

diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.ml b/helm/DEVEL/ocaml-http/http_tcp_server.ml
index 69da5c109..cbe01add1 100644
--- a/helm/DEVEL/ocaml-http/http_tcp_server.ml
+++ b/helm/DEVEL/ocaml-http/http_tcp_server.ml
@@ -1,8 +1,29 @@
 
+(*
+  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
@@ -14,12 +35,29 @@ 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)
 
+  (* 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,67 +70,85 @@ 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;
-  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)
@@ -100,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
+