(** 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
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 *)
-let ocaml_builtin ~sockaddr ~timeout callback =
+let init_socket sockaddr =
+ 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;
+ suck
+
+let init_callback callback timeout =
let timeout_callback signo =
if signo = Sys.sigalrm then
- exit 2
+ raise Timeout
in
- Unix.establish_server
- (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
- sockaddr
+ wrap_callback_w_timeout ~callback ~timeout ~timeout_callback
- (** 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 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 10;
+ Unix.listen suck backlog;
let timeout_callback signo =
if signo = Sys.sigalrm then
raise Timeout
in
let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in
+ (suck, callback)
+*)
+
+ (** 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
+
+ (** 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 (suck, _) = Unix.accept suck in
+ let (client, _) = 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)
+ ignore (Unix.alarm 0) (* reset alarm *)
with Timeout -> ());
close_out outchan (* this close also inchan, because socket is the same *)
done
+ (** 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) =
+ try
+ callback i o;
+ close_out o
+ with
+ | Timeout -> close_out o
+ | e ->
+ close_out o;
+ raise e
+ 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
+ Http_threaded_tcp_server.serve callback (inchan, outchan)
+ done
+