helm/DEVEL/ocaml-http/http_tcp_server.ml

   1
   2   (** raised when a client timeouts *)
   3 exception Timeout;;
   4
   5 let backlog = 10;;
   6
   7   (** if timeout is given (Some _) @return a new callback which establish
   8   timeout_callback as callback for signal Sys.sigalrm and register an alarm
   9   (expiring after timeout seconds) before invoking the real callback given. If
  10   timeout is None, callback is returned unchanged. *)
  11 let wrap_callback_w_timeout ~callback ~timeout ~timeout_callback =
  12   match timeout with
  13   | None -> callback
  14   | Some timeout -> (* wrap callback setting an handler for ALRM signal and an
  15                     alarm that ring after timeout seconds *)
  16       (fun inchan outchan ->
  17         ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle ~timeout_callback));
  18         ignore (Unix.alarm timeout);
  19         callback inchan outchan)
  20
  21   (** tcp_server which doesn't fork, requests are server sequentially and in the
  22   same address space of the calling process *)
  23 let simple ~sockaddr ~timeout callback =
  24   let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
  25   Unix.setsockopt suck Unix.SO_REUSEADDR true;
  26   Unix.bind suck sockaddr;
  27   Unix.listen suck backlog;
  28   let timeout_callback signo =
  29     if signo = Sys.sigalrm then
  30       raise Timeout
  31   in
  32   let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in
  33   while true do
  34     let (client, _) = Unix.accept suck in
  35       (* client is now connected *)
  36     let (inchan, outchan) =
  37       (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
  38     in
  39     (try
  40       callback inchan outchan;
  41       ignore (Unix.alarm 0) (* reset alarm *)
  42     with Timeout -> ());
  43     close_out outchan (* this close also inchan, because socket is the same *)
  44   done
  45
  46   (** tcp_server which use Unix.establish_server which in turn forks a child for
  47   each request *)
  48 let ocaml_builtin ~sockaddr ~timeout callback =
  49   let timeout_callback signo =
  50     if signo = Sys.sigalrm then
  51       exit 2
  52   in
  53   Unix.establish_server
  54     (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
  55     sockaddr
  56
  57   (* TODO this is a cut-and-paste from 'simple' *)
  58   (** tcp_server which creates a new thread for each request to be served *)
  59 let thread ~sockaddr ~timeout callback =
  60   let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
  61   Unix.setsockopt suck Unix.SO_REUSEADDR true;
  62   Unix.bind suck sockaddr;
  63   Unix.listen suck backlog;
  64   let timeout_callback signo =
  65     if signo = Sys.sigalrm then
  66       raise Timeout
  67   in
  68   let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in
  69   let callback (i, o) =
  70     try
  71       callback i o;
  72       close_out o
  73     with
  74     | Timeout -> close_out o
  75     | e ->
  76         close_out o;
  77         raise e
  78   in
  79   while true do
  80     let (client, _) = Unix.accept suck in
  81       (* client is now connected *)
  82     let (inchan, outchan) =
  83       (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
  84     in
  85     ignore (Thread.create callback (inchan, outchan));
  86   done
  87