- added support for multithreaded daemons

[helm.git] / helm / DEVEL / ocaml-http / http_tcp_server.ml

diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.ml b/helm/DEVEL/ocaml-http/http_tcp_server.ml
index 44e4df1d57586f1010821e084f2015f8342daa68..29cf3931eba84f1a79277002001d2c908ef4f52a 100644 (file)
--- a/helm/DEVEL/ocaml-http/http_tcp_server.ml
+++ b/helm/DEVEL/ocaml-http/http_tcp_server.ml
@@ -2,6 +2,8 @@
   (** raised when a client timeouts *)
 exception Timeout;;
 
+let backlog = 10;;
+
   (** if timeout is given (Some _) @return a new callback which establish
   timeout_callback as callback for signal Sys.sigalrm and register an alarm
   (expiring after timeout seconds) before invoking the real callback given. If
@@ -16,8 +18,33 @@ let wrap_callback_w_timeout ~callback ~timeout ~timeout_callback =
         ignore (Unix.alarm timeout);
         callback inchan outchan)
 
-  (** Http_daemon.start function low level which use Unix.establish_server which
-  in turn forks a child for each request *)
+  (** tcp_server which doesn't fork, requests are server sequentially and in the
+  same address space of the calling process *)
+let simple ~sockaddr ~timeout callback =
+  let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+  Unix.setsockopt suck Unix.SO_REUSEADDR true;
+  Unix.bind suck sockaddr;
+  Unix.listen suck backlog;
+  let timeout_callback signo =
+    if signo = Sys.sigalrm then
+      raise Timeout
+  in
+  let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in
+  while true do
+    let (client, _) = Unix.accept suck in
+      (* client is now connected *)
+    let (inchan, outchan) =
+      (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
+    in
+    (try
+      callback inchan outchan;
+      ignore (Unix.alarm 0) (* reset alarm *)
+    with Timeout -> ());
+    close_out outchan (* this close also inchan, because socket is the same *)
+  done
+
+  (** tcp_server which use Unix.establish_server which in turn forks a child for
+  each request *)
 let ocaml_builtin ~sockaddr ~timeout callback =
   let timeout_callback signo =
     if signo = Sys.sigalrm then
@@ -27,28 +54,34 @@ let ocaml_builtin ~sockaddr ~timeout callback =
     (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
     sockaddr
 
-  (** Http_daemon.start function low level which doesn't fork, requests are
-  server sequentially and in the same address space of the calling process *)
-let simple ~sockaddr ~timeout callback =
+  (* TODO this is a cut-and-paste from 'simple' *)
+  (** tcp_server which creates a new thread for each request to be served *)
+let thread ~sockaddr ~timeout callback =
   let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
   Unix.setsockopt suck Unix.SO_REUSEADDR true;
   Unix.bind suck sockaddr;
-  Unix.listen suck 10;
+  Unix.listen suck backlog;
   let timeout_callback signo =
     if signo = Sys.sigalrm then
       raise Timeout
   in
   let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in
+  let callback (i, o) =
+    try
+      callback i o;
+      close_out o
+    with
+    | Timeout -> close_out o
+    | e ->
+        close_out o;
+        raise e
+  in
   while true do
-    let (suck, _) = Unix.accept suck in
+    let (client, _) = Unix.accept suck in
       (* client is now connected *)
     let (inchan, outchan) =
-      (Unix.in_channel_of_descr suck, Unix.out_channel_of_descr suck)
+      (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client)
     in
-    (try
-      callback inchan outchan;
-      ignore (Unix.alarm 0)
-    with Timeout -> ());
-    close_out outchan (* this close also inchan, because socket is the same *)
+    ignore (Thread.create callback (inchan, outchan));
   done