]> matita.cs.unibo.it Git - helm.git/blobdiff - helm/DEVEL/ocaml-http/http_daemon.ml
- added some TODO comments
[helm.git] / helm / DEVEL / ocaml-http / http_daemon.ml
index f2f70a03729932c647507f37e3cd712b9490431b..9e49551f4c6ac742ceaebd1a3040cc624814b9d7 100644 (file)
@@ -22,6 +22,8 @@
 open Printf;;
 
 open Http_common;;
+open Http_types;;
+open Http_constants;;
 open Http_parser;;
 
 let debug = true
@@ -43,8 +45,8 @@ let send_raw ~data outchan =
 
 let send_CRLF = send_raw ~data:crlf
 
-  (** TODO perform some sanity test on header and value *)
 let send_header ~header ~value =
+  Http_parser_sanity.heal_header (header, value);
   send_raw ~data:(header ^ ": " ^ value ^ crlf)
 
 let send_headers ~headers outchan =
@@ -57,9 +59,9 @@ let get_code_argument func_name =
     (match code, status with
     | Some c, None -> c
     | None, Some s -> code_of_status s
-    | Some _, Some _ ->
+    | Some _, Some _ -> (* TODO use some static type checking *)
         failwith (func_name ^ " you must give 'code' or 'status', not both")
-    | None, None ->
+    | None, None -> (* TODO use some static type checking *)
         failwith (func_name ^ " you must give 'code' or 'status', not none"))
 
   (** internal: low level for send_status_line *)
@@ -69,7 +71,7 @@ let send_status_line' ~version ~code =
       " "
       [ string_of_version version;
       string_of_int code;
-      reason_phrase_of_code code ]
+      Http_misc.reason_phrase_of_code code ]
   in
   send_raw ~data:(status_line ^ crlf)
 
@@ -92,7 +94,7 @@ let send_basic_headers ?(version = http_version) ?code ?status outchan =
   representing an HTML document that explains the meaning of given status code.
   Additional data can be added to the body via 'body' argument *)
 let foo_body code body =
-  let reason_phrase = reason_phrase_of_code code in
+  let reason_phrase = Http_misc.reason_phrase_of_code code in
   sprintf
 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
 <HTML><HEAD>
@@ -106,8 +108,8 @@ let foo_body code body =
   of an HTTP response; body, if given, will be appended to the body *)
 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
   =
@@ -118,6 +120,7 @@ let respond
   in
   send_basic_headers ~version ~code outchan;
   send_headers ~headers outchan;
+  send_header "Content-Length" (string_of_int (String.length body)) outchan;
   send_CRLF outchan;
   send_raw ~data:body outchan
 
@@ -156,7 +159,6 @@ let send_empty_response
 *)
       end
 
-  (* TODO sanity tests on location *)
 let respond_redirect
   ~location ?(body = "") ?(version = http_version) ?(code = 301) ?status outchan
   =
@@ -198,7 +200,8 @@ let send_file ?name ?file outchan =
         let f = open_in n in
         f, (fun () -> close_in f)
     | None, Some f -> (f, (fun () -> ()))
-    | _ -> failwith "Daemon.send_file: either name or file must be given")
+    | _ ->  (* TODO use some static type checking *)
+        failwith "Daemon.send_file: either name or file must be given")
   in
   try
     while true do
@@ -273,70 +276,119 @@ let respond_with (res: Http_types.response) outchan =
   res#serialize outchan;
   flush outchan
 
+  (** internal: this exception is raised after a malformed request has been read
+  by a serving process to signal main server (or itself if mode = `Single) to
+  skip to next request *)
+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 (new Http_request.request)
+
+let chdir_to_document_root = function (* chdir to document root *)
+  | Some dir -> Sys.chdir dir
+  | None -> ()
+
+let server_of_mode = function
+  | `Single -> Http_tcp_server.simple
+  | `Fork   -> Http_tcp_server.ocaml_builtin
+  | `Thread -> Http_tcp_server.thread
+
   (* TODO support also chroot to 'root', not only chdir *)
   (* curried request *)
 let start
   ?(addr = default_addr) ?(port = default_port)
   ?(timeout = Some default_timeout) ?(mode = default_mode) ?root callback
   =
-  (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
+  chdir_to_document_root root;
+  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
-  | `Fork   -> Http_tcp_server.ocaml_builtin ~sockaddr ~timeout daemon_callback 
-  | `Thread -> Http_tcp_server.thread ~sockaddr ~timeout daemon_callback
+  try
+    (server_of_mode mode) ~sockaddr ~timeout daemon_callback 
+  with Quit -> ()
 
   (* OO request *)
 let start'
   ?(addr = default_addr) ?(port = default_port)
   ?(timeout = Some default_timeout) ?(mode = default_mode) ?root callback
   =
-  let wrapper path params outchan =
-    let req = new Http_request.request ~path ~params in
-    callback req outchan
+  chdir_to_document_root root;
+  let sockaddr = Http_misc.build_sockaddr (addr, port) in
+  let daemon_callback inchan outchan =
+    try
+      let req = safe_parse_request' inchan outchan in
+      callback req outchan;
+      flush outchan
+    with Again -> ()
   in
-  match root with
-  | None      -> start ~addr ~port ~timeout ~mode wrapper
-  | Some root -> start ~addr ~port ~timeout ~mode ~root wrapper
+  try
+    (server_of_mode mode) ~sockaddr ~timeout daemon_callback 
+  with Quit -> ()
 
 module Trivial =
   struct
@@ -349,3 +401,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
+