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 let init_socket sockaddr =
  22   let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
  23   Unix.setsockopt suck Unix.SO_REUSEADDR true;
  24   Unix.bind suck sockaddr;
  25   Unix.listen suck backlog;
  26   suck
  27
  28 let init_callback callback timeout =
  29   let timeout_callback signo =
  30     if signo = Sys.sigalrm then
  31       raise Timeout
  32   in
  33   wrap_callback_w_timeout ~callback ~timeout ~timeout_callback
  34
  35 (*
  36 let init_socket_and_callback sockaddr callback timeout =
  37   let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
  38   Unix.setsockopt suck Unix.SO_REUSEADDR true;
  39   Unix.bind suck sockaddr;
  40   Unix.listen suck backlog;
  41   let timeout_callback signo =
  42     if signo = Sys.sigalrm then
  43       raise Timeout
  44   in
  45   let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in
  46   (suck, callback)
  47 *)
  48
  49   (** tcp_server which use Unix.establish_server which in turn forks a child for
  50   each request *)
  51 let ocaml_builtin ~sockaddr ~timeout callback =
  52   let timeout_callback signo =
  53     if signo = Sys.sigalrm then
  54       exit 2
  55   in
  56   Unix.establish_server
  57     (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
  58     sockaddr
  59
  60   (** tcp_server which doesn't fork, requests are server sequentially and in the
  61   same address space of the calling process *)
  62 let simple ~sockaddr ~timeout callback =
  63 (*   let (suck, callback) = init_socket_and_callback sockaddr callback timeout in *)
  64   let suck = init_socket sockaddr in
  65   let callback = init_callback callback timeout in
  66   while true do
  67     let (client, _) = Unix.accept suck in
  68       (* client is now connected *)
  69     let (inchan, outchan) =
  70       (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
  71     in
  72     (try
  73       callback inchan outchan;
  74       ignore (Unix.alarm 0) (* reset alarm *)
  75     with Timeout -> ());
  76     close_out outchan (* this close also inchan, because socket is the same *)
  77   done
  78
  79   (** tcp_server which creates a new thread for each request to be served *)
  80 let thread ~sockaddr ~timeout callback =
  81 (*   let (suck, callback) = init_socket_and_callback sockaddr callback timeout in *)
  82   let suck = init_socket sockaddr in
  83   let callback = init_callback callback timeout in
  84   let callback (i, o) =
  85     try
  86       callback i o;
  87       close_out o
  88     with
  89     | Timeout -> close_out o
  90     | e ->
  91         close_out o;
  92         raise e
  93   in
  94   while true do
  95     let (client, _) = Unix.accept suck in
  96       (* client is now connected *)
  97     let (inchan, outchan) =
  98       (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
  99     in
 100     Http_threaded_tcp_server.serve callback (inchan, outchan)
 101   done
 102