more cleanup

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

diff --git a/DEVEL/ocaml-http/http_daemon.ml b/DEVEL/ocaml-http/http_daemon.ml
index 629d1286cfd7ea97be793e28bb01b8b891591455..f7c8495de2c5d747cb0872d19a18524333ce6255 100644 (file)
--- a/DEVEL/ocaml-http/http_daemon.ml
+++ b/DEVEL/ocaml-http/http_daemon.ml
@@ -36,6 +36,7 @@ let send_raw ~data outchan =
 let send_CRLF = send_raw ~data:crlf
 
 let send_header ~header ~value =
+  let header = String.lowercase header in
   Http_parser_sanity.heal_header (header, value);
   send_raw ~data:(header ^ ": " ^ value ^ crlf)
 
@@ -297,68 +298,37 @@ let server_of_mode = function
   callbacks keep on living until the end or are them all killed immediatly?
   The right semantics should obviously be the first one *)
 
-let handle_manual_auth outchan f =
-  try
-    f ()
-  with
-  | Unauthorized realm -> respond_unauthorized ~realm outchan
-  | Again -> ()
-
-let handle_auth req spec outchan =
+  (** - handle HTTP authentication
+   *  - handle automatic closures of client connections *)
+let invoke_callback req spec outchan =
+  let callback req outchan =
+    if spec.auto_close then
+      Http_misc.finally
+        (fun () ->
+          (* XXX the pair flush + shutdown is a temporary solution since double
+           * close on a socket make ocaml 3.09.2 segfault (see
+           * http://caml.inria.fr/mantis/view.php?id=4059). The right thing to
+           * do is probably invoke try_close outchan here *)
+          flush outchan;
+          try
+            Unix.shutdown (Unix.descr_of_out_channel outchan) Unix.SHUTDOWN_ALL
+          with Unix.Unix_error(_, "shutdown", "") -> ())
+        (fun () -> spec.callback req outchan) ()
+    else
+      spec.callback req outchan in
   try
     (match (spec.auth, req#authorization) with
-    | None, _ -> spec.callback req outchan  (* no auth required *)
+    | None, _ -> callback req outchan  (* no auth required *)
     | Some (realm, `Basic (spec_username, spec_password)),
       Some (`Basic (username, password))
       when (username = spec_username) && (password = spec_password) ->
         (* auth ok *)
-        spec.callback req outchan
+        callback req outchan
     | Some (realm, _), _ -> raise (Unauthorized realm)) (* auth failure *)
   with
   | Unauthorized realm -> respond_unauthorized ~realm outchan
   | Again -> ()
 
-  (* TODO support also chroot to 'root', not only chdir *)
-  (* TODO deprecated: remove from future versions *)
-  (* curried request *)
-let start
-  ?(addr = default_addr) ?(port = default_port)
-  ?(timeout = default_timeout) ?(mode = default_mode) ?root callback
-  =
-  Http_misc.warn
-    "Http_daemon.start is deprecated in favour of Http_daemon.main and will be removed in future versions of the library";
-  chdir_to_document_root root;
-  let sockaddr = Http_misc.build_sockaddr (addr, port) in
-  let daemon_callback inchan outchan =
-    handle_manual_auth outchan (fun () ->
-      let (path, parameters) = safe_parse_request inchan outchan in
-      callback path parameters outchan;
-      flush outchan);
-  in
-  try
-    (server_of_mode mode) ~sockaddr ~timeout daemon_callback 
-  with Quit -> ()
-
-  (* OO request *)
-  (* TODO deprecated: remove from future versions *)
-let start'
-  ?(addr = default_addr) ?(port = default_port)
-  ?(timeout = default_timeout) ?(mode = default_mode) ?root callback
-=
-  Http_misc.warn
-    "Http_daemon.start' is deprecated in favour of Http_daemon.main and will be removed in future versions of the library";
-  chdir_to_document_root root;
-  let sockaddr = Http_misc.build_sockaddr (addr, port) in
-  let daemon_callback inchan outchan =
-    handle_manual_auth outchan (fun () ->
-      let req = safe_parse_request' inchan outchan in
-      callback req outchan;
-      flush outchan)
-  in
-  try
-    (server_of_mode mode) ~sockaddr ~timeout daemon_callback 
-  with Quit -> ()
-
 let main spec =
   chdir_to_document_root spec.root_dir;
   let sockaddr = Http_misc.build_sockaddr (spec.address, spec.port) in
@@ -371,7 +341,7 @@ let main spec =
       match next_req () with
       | Some req ->
           debug_print (sprintf "request #%d" n);
-          handle_auth req spec outchan;
+          invoke_callback req spec outchan;
           flush outchan;
           loop (n + 1)
       | None ->
@@ -473,6 +443,7 @@ open Http_constants
 let default_spec = {
   address = default_addr;
   auth = default_auth;
+  auto_close = default_auto_close;
   callback = default_callback;
   mode = default_mode;
   port = default_port;
@@ -483,6 +454,7 @@ let default_spec = {
 
 let daemon_spec
   ?(address = default_addr) ?(auth = default_auth)
+  ?(auto_close = default_auto_close)
   ?(callback = default_callback) ?(mode = default_mode) ?(port = default_port)
   ?(root_dir = default_root_dir) ?(exn_handler = default_exn_handler)
   ?(timeout = default_timeout)
@@ -491,6 +463,7 @@ let daemon_spec
   { default_spec with
       address = address;
       auth = auth;
+      auto_close = auto_close;
       callback = callback;
       mode = mode;
       port = port;