- 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)

diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.ml b/helm/DEVEL/ocaml-http/http_tcp_server.ml
index 69da5c109ebd615364bea4e6b2c423a22e7e96a9..f457e050a4bbf4bdfbe0270df84c5b089eccbb9d 100644 (file)
--- 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 <zack@cs.unibo.it>
+
+  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 881fb58fa2dcfe520c2498c8bcbf25df7749fb11..b6968254e6810f7c53d44d80f395cee53488ae10 100644 (file)
--- 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 <zack@cs.unibo.it>
+
+  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