]> matita.cs.unibo.it Git - helm.git/blob - DEVEL/ocaml-http/http_tcp_server.ml
removed bad guard that was always false (assert false in the line above)
[helm.git] / DEVEL / ocaml-http / http_tcp_server.ml
1
2 (*
3   OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
4
5   Copyright (C) <2002-2005> 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 Library General Public License as
9   published by the Free Software Foundation, version 2.
10
11   This program is distributed in the hope that it will be useful,
12   but WITHOUT ANY WARRANTY; without even the implied warranty of
13   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14   GNU Library General Public License for more details.
15
16   You should have received a copy of the GNU Library General Public
17   License along with this program; if not, write to the Free Software
18   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
19   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   (** try to close an outchannel connected to a socket, ignore Sys_error since
74   * this probably means that socket is already closed (e.g. on sigpipe) *)
75 let try_close_out ch = try close_out ch with Sys_error _ -> ()
76
77   (** like Unix.establish_server, but shutdown sockets when receiving SIGTERM
78   and before exiting for an uncaught exception *)
79 let my_establish_server server_fun sockaddr =
80   let suck = init_socket sockaddr in
81   while true do
82     let (s, caller) = nice_unix_accept suck in
83       (** "double fork" trick, see {!Unix.establish_server} implementation *)
84     match Unix.fork() with
85     | 0 ->  (* parent *)
86         (try
87           if Unix.fork () <> 0 then
88             exit 0;  (* The son exits, the grandson works *)
89           let inchan = Unix.in_channel_of_descr s in
90           let outchan = Unix.out_channel_of_descr s in
91           server_fun inchan outchan;
92           try_close_out outchan;  (* closes also inchan: socket is the same *)
93           exit 0
94         with e ->
95           shutdown_socket suck; (* clean up socket before exit *)
96           raise e)
97     | child when (child > 0) -> (* child *)
98         Unix.close s;
99         ignore (Unix.waitpid [] child) (* Reclaim the son *)
100     | _ (* < 0 *) ->
101         failwith "Can't fork"
102   done
103
104   (** tcp_server which forks a new process for each request *)
105 let fork ~sockaddr ~timeout callback =
106   let timeout_callback signo =
107     if signo = Sys.sigalrm then
108       exit 2
109   in
110   my_establish_server
111     (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
112     sockaddr
113
114   (** tcp_server which doesn't fork, requests are server sequentially and in the
115   same address space of the calling process *)
116 let simple ~sockaddr ~timeout callback =
117   let suck = init_socket sockaddr in
118   let callback = init_callback callback timeout in
119   try
120     while true do
121       let (client, _) = Unix.accept suck in
122         (* client is now connected *)
123       let (inchan, outchan) =
124         (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
125       in
126       (try
127         callback inchan outchan;
128         ignore (Unix.alarm 0) (* reset alarm *)
129       with Timeout -> ());
130       try_close_out outchan (* this close also inchan: socket is the same *)
131     done
132   with e -> (* clean up socket before exit *)
133     shutdown_socket suck;
134     raise e
135
136   (** tcp_server which creates a new thread for each request to be served *)
137 let thread ~sockaddr ~timeout callback =
138   let suck = init_socket sockaddr in
139   let callback = init_callback callback timeout in
140   let callback (i, o) =
141     (try
142       callback i o
143     with
144     | Timeout -> ()
145     | e ->
146         try_close_out o;
147         raise e);
148     try_close_out o
149   in
150   while true do
151     let (client, _) = nice_unix_accept suck in
152       (* client is now connected *)
153     let (inchan, outchan) =
154       (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
155     in
156     Http_threaded_tcp_server.serve callback (inchan, outchan)
157   done
158
159   (** @param server an Http_types.tcp_server
160   * @return an Http_types.tcp_server which takes care of ignoring SIGPIPE during
161   * server execution and restoring previous handler when (if ever) the server
162   * returns *)
163 let handle_sigpipe server =
164   fun ~sockaddr ~timeout callback ->
165     let old_sigpipe_behavior = Sys.signal Sys.sigpipe Sys.Signal_ignore in
166     server ~sockaddr ~timeout callback;
167     ignore (Sys.signal Sys.sigpipe old_sigpipe_behavior)
168
169 let simple = handle_sigpipe simple
170 let thread = handle_sigpipe thread
171 let fork = handle_sigpipe fork
172