helm/DEVEL/ocaml-http/http_tcp_server.ml

   1
   2   (** raised when a client timeouts *)
   3 exception Timeout;;
   4
   5   (** if timeout is given (Some _) @return a new callback which establish
   6   timeout_callback as callback for signal Sys.sigalrm and register an alarm
   7   (expiring after timeout seconds) before invoking the real callback given. If
   8   timeout is None, callback is returned unchanged. *)
   9 let wrap_callback_w_timeout ~callback ~timeout ~timeout_callback =
  10   match timeout with
  11   | None -> callback
  12   | Some timeout -> (* wrap callback setting an handler for ALRM signal and an
  13                     alarm that ring after timeout seconds *)
  14       (fun inchan outchan ->
  15         ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle ~timeout_callback));
  16         ignore (Unix.alarm timeout);
  17         callback inchan outchan)
  18
  19   (** Http_daemon.start function low level which use Unix.establish_server which
  20   in turn forks a child for each request *)
  21 let ocaml_builtin ~sockaddr ~timeout callback =
  22   let timeout_callback signo =
  23     if signo = Sys.sigalrm then
  24       exit 2
  25   in
  26   Unix.establish_server
  27     (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
  28     sockaddr
  29
  30   (** Http_daemon.start function low level which doesn't fork, requests are
  31   server sequentially and in the same address space of the calling process *)
  32 let simple ~sockaddr ~timeout callback =
  33   let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
  34   Unix.setsockopt suck Unix.SO_REUSEADDR true;
  35   Unix.bind suck sockaddr;
  36   Unix.listen suck 10;
  37   let timeout_callback signo =
  38     if signo = Sys.sigalrm then
  39       raise Timeout
  40   in
  41   let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in
  42   while true do
  43     let (suck, _) = Unix.accept suck in
  44       (* client is now connected *)
  45     let (inchan, outchan) =
  46       (Unix.in_channel_of_descr suck, Unix.out_channel_of_descr suck)
  47     in
  48     (try
  49       callback inchan outchan;
  50       ignore (Unix.alarm 0)
  51     with Timeout -> ());
  52     close_out outchan (* this close also inchan, because socket is the same *)
  53   done
  54