- added safe_parse_request{,'} which wrap parse_request{,'} catching

  exceptions and sending error messages to client
- added connection class
- added daemon class

diff --git a/helm/DEVEL/ocaml-http/http_daemon.ml b/helm/DEVEL/ocaml-http/http_daemon.ml
index bcf3da81ac51aa725994393c57b3590eb065387d..56596a920d730cd620fbfcd8914cb4d96a344c3a 100644 (file)
--- a/helm/DEVEL/ocaml-http/http_daemon.ml
+++ b/helm/DEVEL/ocaml-http/http_daemon.ml
@@ -110,6 +110,7 @@ let send_foo_body code body = send_raw ~data:(foo_body code body)
 
   (* TODO add the computation of Content-Length header *)
 let respond
+  (* Warning: keep default values in sync with Http_response.response class *)
   ?(body = "") ?(headers = [])
   ?(version = http_version) ?(code = 200) ?status outchan
   =
@@ -274,6 +275,71 @@ let respond_with (res: Http_types.response) outchan =
   res#serialize outchan;
   flush outchan
 
+exception Again;;
+
+  (* given a Http_parser.parse_request like function, wrap it in a function that
+  do the same and additionally catch parsing exception sending HTTP error
+  messages back to client as needed. Returned function raises Again when it
+  encounter a parse error (name 'Again' is intended for future versions that
+  will support http keep alive signaling that a new request has to be parsed
+  from client) *)
+let rec wrap_parse_request_w_safety parse_function inchan outchan =
+(*   try *)
+  (try
+    parse_function inchan
+  with
+  | End_of_file ->
+      respond_error ~code:400 ~body:"Unexpected End Of File" outchan;
+      raise Again
+  | Malformed_request req ->
+      respond_error
+        ~code:400
+        ~body:(
+          "request 1st line format should be: '<method> <url> <version>'" ^
+          "<br />\nwhile received request 1st line was:<br />\n" ^ req)
+        outchan;
+      raise Again
+  | Unsupported_method meth ->
+      respond_error
+        ~code:501
+        ~body:("Method '" ^ meth ^ "' isn't supported (yet)")
+        outchan;
+      raise Again
+  | Malformed_request_URI uri ->
+      respond_error ~code:400 ~body:("Malformed URL: '" ^ uri ^ "'") outchan;
+      raise Again
+  | Unsupported_HTTP_version version ->
+      respond_error
+        ~code:505
+        ~body:("HTTP version '" ^ version ^ "' isn't supported (yet)")
+        outchan;
+      raise Again
+  | Malformed_query query ->
+      respond_error
+        ~code:400 ~body:(sprintf "Malformed query string '%s'" query) outchan;
+      raise Again
+  | Malformed_query_part (binding, query) ->
+      respond_error
+        ~code:400
+        ~body:(
+          sprintf "Malformed query part '%s' in query '%s'" binding query)
+        outchan;
+      raise Again)
+(*  (* preliminary support for HTTP keep alive connections ... *)
+  with Again ->
+    wrap_parse_request_w_safety parse_function inchan outchan
+*)
+
+  (* wrapper around Http_parser.parse_request which catch parsing exceptions and
+  return error messages to client as needed
+  @param inchan in_channel from which read incoming requests
+  @param outchan out_channl on which respond with error messages if needed
+  *)
+let safe_parse_request = wrap_parse_request_w_safety parse_request
+
+  (* as above but for OO version (Http_parser.parse_request') *)
+let safe_parse_request' = wrap_parse_request_w_safety parse_request'
+
   (* TODO support also chroot to 'root', not only chdir *)
   (* curried request *)
 let start
@@ -283,43 +349,13 @@ let start
   (match root with  (* chdir to document root *)
   | Some dir -> Sys.chdir dir
   | None -> ());
-  let sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port) in
+  let sockaddr = Http_misc.build_sockaddr ~addr ~port in
   let daemon_callback inchan outchan =
     try
-      let (path, parameters) = Http_parser.parse_request inchan in
+      let (path, parameters) = safe_parse_request inchan outchan in
       callback path parameters outchan;
       flush outchan
-    with
-    | End_of_file ->
-        respond_error ~code:400 ~body:"Unexpected End Of File" outchan
-    | Malformed_request req ->
-        respond_error
-          ~code:400
-          ~body:(
-            "request 1st line format should be: '<method> <url> <version>'" ^
-            "<br />\nwhile received request 1st line was:<br />\n" ^ req)
-          outchan
-    | Unsupported_method meth ->
-        respond_error
-          ~code:501
-          ~body:("Method '" ^ meth ^ "' isn't supported (yet)")
-          outchan
-    | Malformed_request_URI uri ->
-        respond_error ~code:400 ~body:("Malformed URL: '" ^ uri ^ "'") outchan
-    | Unsupported_HTTP_version version ->
-        respond_error
-          ~code:505
-          ~body:("HTTP version '" ^ version ^ "' isn't supported (yet)")
-          outchan
-    | Malformed_query query ->
-        respond_error
-          ~code:400 ~body:(sprintf "Malformed query string '%s'" query) outchan
-    | Malformed_query_part (binding, query) ->
-        respond_error
-          ~code:400
-          ~body:(
-            sprintf "Malformed query part '%s' in query '%s'" binding query)
-          outchan
+    with Again -> ()
   in
   match mode with
   | `Single -> Http_tcp_server.simple ~sockaddr ~timeout daemon_callback
@@ -350,3 +386,60 @@ module Trivial =
       start ~addr ~port callback
   end
 
+  (* @param inchan input channel connected to client
+     @param outchan output channel connected to client
+     @param sockaddr client socket address *)
+class connection inchan outchan sockaddr =
+  (* ASSUMPTION: inchan and outchan are channels built on top of the same
+  Unix.file_descr thus closing one of them will close also the other *)
+  let close' o = o#close in
+  object (self)
+
+    initializer Gc.finalise close' self
+
+    val mutable closed = false
+
+    method private assertNotClosed =
+      if closed then
+        failwith "Http_daemon.connection: connection is closed"
+
+    method getRequest =
+      self#assertNotClosed;
+      try
+        Some (safe_parse_request' inchan outchan)
+      with Again -> None
+
+    method respond_with res =
+      self#assertNotClosed;
+      respond_with res outchan
+
+    method close =
+      self#assertNotClosed;
+      close_in inchan;  (* this close also outchan *)
+      closed <- true
+
+  end
+
+class daemon ?(addr = "0.0.0.0") ?(port = 80) () =
+  object (self)
+
+    val suck =
+      Http_tcp_server.init_socket (Http_misc.build_sockaddr ~addr ~port)
+
+    method accept =
+      let (cli_suck, cli_sockaddr) = Unix.accept suck in  (* may block *)
+      let (inchan, outchan) =
+        (Unix.in_channel_of_descr cli_suck, Unix.out_channel_of_descr cli_suck)
+      in
+      new connection inchan outchan cli_sockaddr
+
+    method getRequest =
+      let conn = self#accept in
+      match conn#getRequest with
+      | None ->
+          conn#close;
+          self#getRequest
+      | Some req -> (req, conn)
+
+  end
+

diff --git a/helm/DEVEL/ocaml-http/http_daemon.mli b/helm/DEVEL/ocaml-http/http_daemon.mli
index 46e8f61d58234412126b5baacfd68909bdd864c1..c9c8deb535f4f36c372756dca87e1ea6c303229f 100644 (file)
--- a/helm/DEVEL/ocaml-http/http_daemon.mli
+++ b/helm/DEVEL/ocaml-http/http_daemon.mli
@@ -125,15 +125,6 @@ val start':
   (Http_types.request -> out_channel -> unit) ->
     unit
 
-(*
-  (** OO interface to HTTP daemons *)
-class daemon:
-  ?addr: string -> ?port: int ->
-  ?timeout: int option -> ?mode: Http_types.daemon_mode ->?root:; string -> 
-  (Http_types.request -> out_channel -> unit) ->
-    Http_types.daemon
-*)
-
   (** Trivial static pages HTTP daemon *)
 module Trivial :
   sig
@@ -141,3 +132,5 @@ module Trivial :
     val start : ?addr:string -> ?port:int -> unit -> unit
   end
 
+class daemon: ?addr: string -> ?port: int -> unit -> Http_types.daemon
+