helm/DEVEL/ocaml-http/http_tcp_server.ml

   1
   2 (*
   3   OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
   4
   5   Copyright (C) <2002-2005> Stefano Zacchiroli <zack@cs.unibo.it>
   6
   7   This program is free software; you can redistribute it and/or modify
   8   it under the terms of the GNU Library General Public License as
   9   published by the Free Software Foundation, version 2.
  10
  11   This program is distributed in the hope that it will be useful,
  12   but WITHOUT ANY WARRANTY; without even the implied warranty of
  13   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14   GNU Library General Public License for more details.
  15
  16   You should have received a copy of the GNU Library General Public
  17   License along with this program; if not, write to the Free Software
  18   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  19   USA
  20 *)
  21
  22
  23   (** raised when a client timeouts *)
  24 exception Timeout
  25
  26 let backlog = 10
  27
  28   (** if timeout is given (Some _) @return a new callback which establish
  29   timeout_callback as callback for signal Sys.sigalrm and register an alarm
  30   (expiring after timeout seconds) before invoking the real callback given. If
  31   timeout is None, callback is returned unchanged. *)
  32 let wrap_callback_w_timeout ~callback ~timeout ~timeout_callback =
  33   match timeout with
  34   | None -> callback
  35   | Some timeout -> (* wrap callback setting an handler for ALRM signal and an
  36                     alarm that ring after timeout seconds *)
  37       (fun inchan outchan ->
  38         ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_callback));
  39         ignore (Unix.alarm timeout);
  40         callback inchan outchan)
  41
  42   (* try to close nicely a socket *)
  43 let shutdown_socket suck =
  44   try
  45     Unix.shutdown suck Unix.SHUTDOWN_ALL
  46   with Unix.Unix_error(_, "shutdown", "") -> ()
  47
  48 let nice_unix_accept suck =
  49   try
  50     Unix.accept suck
  51   with e -> (* clean up socket before exit *)
  52     shutdown_socket suck;
  53     raise e
  54
  55 let init_socket sockaddr =
  56   let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
  57     (* shutdown socket on SIGTERM *)
  58   ignore (Sys.signal Sys.sigterm
  59     (Sys.Signal_handle
  60       (fun _ -> shutdown_socket suck; exit 17)));
  61   Unix.setsockopt suck Unix.SO_REUSEADDR true;
  62   Unix.bind suck sockaddr;
  63   Unix.listen suck backlog;
  64   suck
  65
  66 let init_callback callback timeout =
  67   let timeout_callback signo =
  68     if signo = Sys.sigalrm then
  69       raise Timeout
  70   in
  71   wrap_callback_w_timeout ~callback ~timeout ~timeout_callback
  72
  73   (** try to close an outchannel connected to a socket, ignore Sys_error since
  74   * this probably means that socket is already closed (e.g. on sigpipe) *)
  75 let try_close_out ch = try close_out ch with Sys_error _ -> ()
  76
  77   (** like Unix.establish_server, but shutdown sockets when receiving SIGTERM
  78   and before exiting for an uncaught exception *)
  79 let my_establish_server server_fun sockaddr =
  80   let suck = init_socket sockaddr in
  81   while true do
  82     let (s, caller) = nice_unix_accept suck in
  83       (** "double fork" trick, see {!Unix.establish_server} implementation *)
  84     match Unix.fork() with
  85     | 0 ->  (* parent *)
  86         (try
  87           if Unix.fork () <> 0 then
  88             exit 0;  (* The son exits, the grandson works *)
  89           let inchan = Unix.in_channel_of_descr s in
  90           let outchan = Unix.out_channel_of_descr s in
  91           server_fun inchan outchan;
  92           try_close_out outchan;  (* closes also inchan: socket is the same *)
  93           exit 0
  94         with e ->
  95           shutdown_socket suck; (* clean up socket before exit *)
  96           raise e)
  97     | child when (child > 0) -> (* child *)
  98         Unix.close s;
  99         ignore (Unix.waitpid [] child) (* Reclaim the son *)
 100     | _ (* < 0 *) ->
 101         failwith "Can't fork"
 102   done
 103
 104   (** tcp_server which forks a new process for each request *)
 105 let fork ~sockaddr ~timeout callback =
 106   let timeout_callback signo =
 107     if signo = Sys.sigalrm then
 108       exit 2
 109   in
 110   my_establish_server
 111     (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
 112     sockaddr
 113
 114   (** tcp_server which doesn't fork, requests are server sequentially and in the
 115   same address space of the calling process *)
 116 let simple ~sockaddr ~timeout callback =
 117   let suck = init_socket sockaddr in
 118   let callback = init_callback callback timeout in
 119   try
 120     while true do
 121       let (client, _) = Unix.accept suck in
 122         (* client is now connected *)
 123       let (inchan, outchan) =
 124         (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
 125       in
 126       (try
 127         callback inchan outchan;
 128         ignore (Unix.alarm 0) (* reset alarm *)
 129       with Timeout -> ());
 130       try_close_out outchan (* this close also inchan: socket is the same *)
 131     done
 132   with e -> (* clean up socket before exit *)
 133     shutdown_socket suck;
 134     raise e
 135
 136   (** tcp_server which creates a new thread for each request to be served *)
 137 let thread ~sockaddr ~timeout callback =
 138   let suck = init_socket sockaddr in
 139   let callback = init_callback callback timeout in
 140   let callback (i, o) =
 141     (try
 142       callback i o
 143     with
 144     | Timeout -> ()
 145     | e ->
 146         try_close_out o;
 147         raise e);
 148     try_close_out o
 149   in
 150   while true do
 151     let (client, _) = nice_unix_accept suck in
 152       (* client is now connected *)
 153     let (inchan, outchan) =
 154       (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
 155     in
 156     Http_threaded_tcp_server.serve callback (inchan, outchan)
 157   done
 158
 159   (** @param server an Http_types.tcp_server
 160   * @return an Http_types.tcp_server which takes care of ignoring SIGPIPE during
 161   * server execution and restoring previous handler when (if ever) the server
 162   * returns *)
 163 let handle_sigpipe server =
 164   fun ~sockaddr ~timeout callback ->
 165     let old_sigpipe_behavior = Sys.signal Sys.sigpipe Sys.Signal_ignore in
 166     server ~sockaddr ~timeout callback;
 167     ignore (Sys.signal Sys.sigpipe old_sigpipe_behavior)
 168
 169 let simple = handle_sigpipe simple
 170 let thread = handle_sigpipe thread
 171 let fork = handle_sigpipe fork
 172