renamed tcp_server module in http_tcp_server to avoid future

[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
new file mode 100644 (file)
index 0000000..44e4df1
--- /dev/null
+++ b/helm/DEVEL/ocaml-http/http_tcp_server.ml
@@ -0,0 +1,54 @@
+
+  (** raised when a client timeouts *)
+exception Timeout;;
+
+  (** 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
+  timeout is None, callback is returned unchanged. *)
+let wrap_callback_w_timeout ~callback ~timeout ~timeout_callback =
+  match timeout with
+  | None -> callback
+  | Some timeout -> (* wrap callback setting an handler for ALRM signal and an
+                    alarm that ring after timeout seconds *)
+      (fun inchan outchan ->
+        ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle ~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 timeout_callback signo =
+    if signo = Sys.sigalrm then
+      exit 2
+  in
+  Unix.establish_server
+    (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 =
+  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;
+  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 (suck, _) = Unix.accept suck in
+      (* client is now connected *)
+    let (inchan, outchan) =
+      (Unix.in_channel_of_descr suck, Unix.out_channel_of_descr suck)
+    in
+    (try
+      callback inchan outchan;
+      ignore (Unix.alarm 0)
+    with Timeout -> ());
+    close_out outchan (* this close also inchan, because socket is the same *)
+  done
+