X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_tcp_server.ml;h=69da5c109ebd615364bea4e6b2c423a22e7e96a9;hb=b1fb6b8e1767d775bc452303629e95941d142bea;hp=44e4df1d57586f1010821e084f2015f8342daa68;hpb=dfc2157c1067b9958c182b25df103744cc8feb27;p=helm.git

diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.ml b/helm/DEVEL/ocaml-http/http_tcp_server.ml
index 44e4df1d5..69da5c109 100644
--- 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,39 +18,85 @@ 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 *)
-let ocaml_builtin ~sockaddr ~timeout callback =
+let init_socket sockaddr =
+  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;
+  suck
+
+let init_callback callback timeout =
   let timeout_callback signo =
     if signo = Sys.sigalrm then
-      exit 2
+      raise Timeout
   in
-  Unix.establish_server
-    (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
-    sockaddr
+  wrap_callback_w_timeout ~callback ~timeout ~timeout_callback
 
-  (** 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 =
+(*
+let init_socket_and_callback sockaddr callback timeout =
   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
+  (suck, callback)
+*)
+
+  (** 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
+      exit 2
+  in
+  Unix.establish_server
+    (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback)
+    sockaddr
+
+  (** 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, callback) = init_socket_and_callback sockaddr callback timeout in *)
+  let suck = init_socket sockaddr in
+  let callback = init_callback callback timeout 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)
+      ignore (Unix.alarm 0) (* reset alarm *)
     with Timeout -> ());
     close_out outchan (* this close also inchan, because socket is the same *)
   done
 
+  (** tcp_server which creates a new thread for each request to be served *)
+let thread ~sockaddr ~timeout callback =
+(*   let (suck, callback) = init_socket_and_callback sockaddr callback timeout in *)
+  let suck = init_socket sockaddr in
+  let callback = init_callback callback timeout 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 (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
+    Http_threaded_tcp_server.serve callback (inchan, outchan)
+  done
+