]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/ocaml-http/http_tcp_server.ml
Added universes handling. The PRE_UNIVERSES tag may help ;)
[helm.git] / helm / DEVEL / ocaml-http / http_tcp_server.ml
1
2 (*
3   OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
4
5   Copyright (C) <2002-2004> Stefano Zacchiroli <zack@cs.unibo.it>
6
7   This program is free software; you can redistribute it and/or modify
8   it under the terms of the GNU General Public License as published by
9   the Free Software Foundation; either version 2 of the License, or
10   (at your option) any later version.
11
12   This program is distributed in the hope that it will be useful,
13   but WITHOUT ANY WARRANTY; without even the implied warranty of
14   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15   GNU General Public License for more details.
16
17   You should have received a copy of the GNU General Public License
18   along with this program; if not, write to the Free Software
19   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
20 *)
21
22
23   (** raised when a client timeouts *)
24 exception Timeout;;
25
26 let backlog = 10;;
27
28   (** if timeout is given (Some _) @return a new callback which establish
29   timeout_callback as callback for signal Sys.sigalrm and register an alarm
30   (expiring after timeout seconds) before invoking the real callback given. If
31   timeout is None, callback is returned unchanged. *)
32 let wrap_callback_w_timeout ~callback ~timeout ~timeout_callback =
33   match timeout with
34   | None -> callback
35   | Some timeout -> (* wrap callback setting an handler for ALRM signal and an
36                     alarm that ring after timeout seconds *)
37       (fun inchan outchan ->
38         ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_callback));
39         ignore (Unix.alarm timeout);
40         callback inchan outchan)
41
42   (* try to close nicely a socket *)
43 let shutdown_socket suck =
44   try
45     Unix.shutdown suck Unix.SHUTDOWN_ALL
46   with Unix.Unix_error(_, "shutdown", "") -> ()
47
48 let nice_unix_accept suck =
49   try
50     Unix.accept suck
51   with e -> (* clean up socket before exit *)
52     shutdown_socket suck;
53     raise e
54
55 let init_socket sockaddr =
56   let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
57     (* shutdown socket on SIGTERM *)
58   ignore (Sys.signal Sys.sigterm
59     (Sys.Signal_handle
60       (fun _ -> shutdown_socket suck; exit 17)));
61   Unix.setsockopt suck Unix.SO_REUSEADDR true;
62   Unix.bind suck sockaddr;
63   Unix.listen suck backlog;
64   suck
65
66 let init_callback callback timeout =
67   let timeout_callback signo =
68     if signo = Sys.sigalrm then
69       raise Timeout
70   in
71   wrap_callback_w_timeout ~callback ~timeout ~timeout_callback
72
73   (** DEPRECATED and no longer visibile in .mli interface, this server has been
74   replaced by 'fork'!
75   tcp_server which use Unix.establish_server which in turn forks a child for
76   each request *)
77 let ocaml_builtin ~sockaddr ~timeout callback =
78   let timeout_callback signo =
79     if signo = Sys.sigalrm then
80       exit 2
81   in
82   Unix.establish_server
83     (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
84     sockaddr
85
86   (** like Unix.establish_server, but shutdown sockets when receiving SIGTERM
87   and before exiting for an uncaught exception *)
88 let my_establish_server server_fun sockaddr =
89   let suck = init_socket sockaddr in
90   while true do
91     let (s, caller) = nice_unix_accept suck in
92       (* "double fork" trick, see Unix.establish_server implementation *)
93     match Unix.fork() with
94     | 0 ->  (* parent *)
95         (try
96           if Unix.fork () <> 0 then
97             exit 0;  (* The son exits, the grandson works *)
98           let inchan = Unix.in_channel_of_descr s in
99           let outchan = Unix.out_channel_of_descr s in
100           server_fun inchan outchan;
101           close_out outchan;
102              (* The file descriptor was already closed by close_out.  close_in
103              inchan; *)
104           exit 0
105         with e ->
106           shutdown_socket suck; (* clean up socket before exit *)
107           raise e)
108     | child when (child > 0) -> (* child *)
109         Unix.close s;
110         ignore (Unix.waitpid [] child) (* Reclaim the son *)
111     | _ (* < 0 *) ->
112         failwith "Can't fork"
113   done
114
115 let fork ~sockaddr ~timeout callback =
116   let timeout_callback signo =
117     if signo = Sys.sigalrm then
118       exit 2
119   in
120   my_establish_server
121     (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
122     sockaddr
123
124
125   (** tcp_server which doesn't fork, requests are server sequentially and in the
126   same address space of the calling process *)
127 let simple ~sockaddr ~timeout callback =
128   let suck = init_socket sockaddr in
129   let callback = init_callback callback timeout in
130   try
131     while true do
132       let (client, _) = Unix.accept suck in
133         (* client is now connected *)
134       let (inchan, outchan) =
135         (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
136       in
137       (try
138         callback inchan outchan;
139         ignore (Unix.alarm 0) (* reset alarm *)
140       with Timeout -> ());
141       close_out outchan (* this close also inchan: socket is the same *)
142     done
143   with e -> (* clean up socket before exit *)
144     shutdown_socket suck;
145     raise e
146
147   (** tcp_server which creates a new thread for each request to be served *)
148 let thread ~sockaddr ~timeout callback =
149   let suck = init_socket sockaddr in
150   let callback = init_callback callback timeout in
151   let callback (i, o) =
152     try
153       callback i o;
154       close_out o
155     with
156     | Timeout -> close_out o
157     | e ->
158         close_out o;
159         raise e
160   in
161   while true do
162     let (client, _) = nice_unix_accept suck in
163       (* client is now connected *)
164     let (inchan, outchan) =
165       (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
166     in
167     Http_threaded_tcp_server.serve callback (inchan, outchan)
168   done
169