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> 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 General Public License as published by
   9   the Free Software Foundation; either version 2 of the License, or
  10   (at your option) any later version.
  11
  12   This program is distributed in the hope that it will be useful,
  13   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15   GNU General Public License for more details.
  16
  17   You should have received a copy of the GNU General Public License
  18   along with this program; if not, write to the Free Software
  19   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  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   (** DEPRECATED and no longer visibile in .mli interface, this server has been
  74   replaced by 'fork'!
  75   tcp_server which use Unix.establish_server which in turn forks a child for
  76   each request *)
  77 let ocaml_builtin ~sockaddr ~timeout callback =
  78   let timeout_callback signo =
  79     if signo = Sys.sigalrm then
  80       exit 2
  81   in
  82   Unix.establish_server
  83     (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
  84     sockaddr
  85
  86   (** like Unix.establish_server, but shutdown sockets when receiving SIGTERM
  87   and before exiting for an uncaught exception *)
  88 let my_establish_server server_fun sockaddr =
  89   let suck = init_socket sockaddr in
  90   while true do
  91     let (s, caller) = nice_unix_accept suck in
  92       (* "double fork" trick, see Unix.establish_server implementation *)
  93     match Unix.fork() with
  94     | 0 ->  (* parent *)
  95         (try
  96           if Unix.fork () <> 0 then
  97             exit 0;  (* The son exits, the grandson works *)
  98           let inchan = Unix.in_channel_of_descr s in
  99           let outchan = Unix.out_channel_of_descr s in
 100           server_fun inchan outchan;
 101           close_out outchan;
 102              (* The file descriptor was already closed by close_out.  close_in
 103              inchan; *)
 104           exit 0
 105         with e ->
 106           shutdown_socket suck; (* clean up socket before exit *)
 107           raise e)
 108     | child when (child > 0) -> (* child *)
 109         Unix.close s;
 110         ignore (Unix.waitpid [] child) (* Reclaim the son *)
 111     | _ (* < 0 *) ->
 112         failwith "Can't fork"
 113   done
 114
 115 let fork ~sockaddr ~timeout callback =
 116   let timeout_callback signo =
 117     if signo = Sys.sigalrm then
 118       exit 2
 119   in
 120   my_establish_server
 121     (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
 122     sockaddr
 123
 124
 125   (** tcp_server which doesn't fork, requests are server sequentially and in the
 126   same address space of the calling process *)
 127 let simple ~sockaddr ~timeout callback =
 128   let suck = init_socket sockaddr in
 129   let callback = init_callback callback timeout in
 130   try
 131     while true do
 132       let (client, _) = Unix.accept suck in
 133         (* client is now connected *)
 134       let (inchan, outchan) =
 135         (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
 136       in
 137       (try
 138         callback inchan outchan;
 139         ignore (Unix.alarm 0) (* reset alarm *)
 140       with Timeout -> ());
 141       close_out outchan (* this close also inchan: socket is the same *)
 142     done
 143   with e -> (* clean up socket before exit *)
 144     shutdown_socket suck;
 145     raise e
 146
 147   (** tcp_server which creates a new thread for each request to be served *)
 148 let thread ~sockaddr ~timeout callback =
 149   let suck = init_socket sockaddr in
 150   let callback = init_callback callback timeout in
 151   let callback (i, o) =
 152     try
 153       callback i o;
 154       close_out o
 155     with
 156     | Timeout -> close_out o
 157     | e ->
 158         close_out o;
 159         raise e
 160   in
 161   while true do
 162     let (client, _) = nice_unix_accept suck in
 163       (* client is now connected *)
 164     let (inchan, outchan) =
 165       (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
 166     in
 167     Http_threaded_tcp_server.serve callback (inchan, outchan)
 168   done
 169