X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_tcp_server.ml;h=699e8cfdce5abcbb5a03898ca4887f640fb5405c;hb=a864255e782859e2b3b7da08297f5d3fe2ee710d;hp=44e4df1d57586f1010821e084f2015f8342daa68;hpb=dfc2157c1067b9958c182b25df103744cc8feb27;p=helm.git diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.ml b/helm/DEVEL/ocaml-http/http_tcp_server.ml index 44e4df1d5..699e8cfdc 100644 --- a/helm/DEVEL/ocaml-http/http_tcp_server.ml +++ b/helm/DEVEL/ocaml-http/http_tcp_server.ml @@ -1,7 +1,30 @@ +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002-2004> 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. + + 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;; +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 (expiring after timeout seconds) before invoking the real callback given. If @@ -12,12 +35,45 @@ 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) - (** Http_daemon.start function low level which use Unix.establish_server which - in turn forks a child for each request *) + (* 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; + suck + +let init_callback callback timeout = + let timeout_callback signo = + if signo = Sys.sigalrm then + raise 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 @@ -27,28 +83,87 @@ let ocaml_builtin ~sockaddr ~timeout callback = (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback) sockaddr - (** Http_daemon.start function low level 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 = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - Unix.setsockopt suck Unix.SO_REUSEADDR true; - Unix.bind suck sockaddr; - Unix.listen suck 10; + (** 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 - raise Timeout + exit 2 + in + 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 = init_socket sockaddr in + let callback = init_callback callback timeout in + 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 = init_socket sockaddr in + let callback = init_callback callback timeout in + let callback (i, o) = + try + callback i o; + close_out o + with + | Timeout -> close_out o + | e -> + close_out o; + raise e in - let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in while true do - let (suck, _) = Unix.accept suck in + let (client, _) = nice_unix_accept suck in (* client is now connected *) let (inchan, outchan) = - (Unix.in_channel_of_descr suck, Unix.out_channel_of_descr suck) + (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client) in - (try - callback inchan outchan; - ignore (Unix.alarm 0) - with Timeout -> ()); - close_out outchan (* this close also inchan, because socket is the same *) + Http_threaded_tcp_server.serve callback (inchan, outchan) done