+
+ (** raised when a client timeouts *)
+exception Timeout;;
+
+ (** 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)
+
+ (** 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 timeout_callback signo =
+ if signo = Sys.sigalrm then
+ exit 2
+ in
+ Unix.establish_server
+ (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;
+ let timeout_callback signo =
+ if signo = Sys.sigalrm then
+ raise Timeout
+ in
+ let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in
+ while true do
+ let (suck, _) = Unix.accept suck in
+ (* client is now connected *)
+ let (inchan, outchan) =
+ (Unix.in_channel_of_descr suck, Unix.out_channel_of_descr suck)
+ in
+ (try
+ callback inchan outchan;
+ ignore (Unix.alarm 0)
+ with Timeout -> ());
+ close_out outchan (* this close also inchan, because socket is the same *)
+ done
+