X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_tcp_server.ml;fp=helm%2FDEVEL%2Focaml-http%2Fhttp_tcp_server.ml;h=0000000000000000000000000000000000000000;hp=23fbc66de65b27dbfa1187da596458c319874ab8;hb=3ef089a4c58fbe429dd539af6215991ecbe11ee2;hpb=1c7fb836e2af4f2f3d18afd0396701f2094265ff diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.ml b/helm/DEVEL/ocaml-http/http_tcp_server.ml deleted file mode 100644 index 23fbc66de..000000000 --- a/helm/DEVEL/ocaml-http/http_tcp_server.ml +++ /dev/null @@ -1,169 +0,0 @@ - -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002> 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 - timeout is None, callback is returned unchanged. *) -let wrap_callback_w_timeout ~callback ~timeout ~timeout_callback = - match timeout with - | None -> 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 (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; - 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 - exit 2 - in - Unix.establish_server - (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback) - sockaddr - - (** 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 - 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 - while true do - 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) - in - Http_threaded_tcp_server.serve callback (inchan, outchan) - done -