X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_daemon.ml;h=732a5b31d1e7f77f88b2141502f604d424dcd06a;hb=6de3b960806c544b580a15fd28309eea0c319771;hp=0a0f47775da721d4edac7980be759b299f6f4e7f;hpb=9a072f192471daeca8cb409e991f0073b1d4271f;p=helm.git diff --git a/helm/DEVEL/ocaml-http/http_daemon.ml b/helm/DEVEL/ocaml-http/http_daemon.ml index 0a0f47775..732a5b31d 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.ml +++ b/helm/DEVEL/ocaml-http/http_daemon.ml @@ -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.heal_header (header, value); send_raw ~data:(header ^ ": " ^ value ^ crlf) let send_headers ~headers outchan = @@ -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 " @@ -108,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 = @@ -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 = @@ -273,52 +275,89 @@ 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: ' '" ^ + "
\nwhile received request 1st line was:
\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' + +let chdir_to_document_root = function (* chdir to document root *) + | Some dir -> Sys.chdir dir + | None -> () + (* 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: ' '" ^ - "
\nwhile received request 1st line was:
\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_binding (binding, query) -> - respond_error - ~code:400 - ~body:( - sprintf "Malformed query element '%s' in query '%s'" binding query) - outchan + with Again -> () in match mode with | `Single -> Http_tcp_server.simple ~sockaddr ~timeout daemon_callback @@ -331,7 +370,8 @@ let start' ?(timeout = Some default_timeout) ?(mode = default_mode) ?root callback = let wrapper path params outchan = - let req = new Http_request.request ~path ~params in + let clisockaddr = Http_misc.peername_of_out_channel outchan in + let req = new Http_request.request ~path ~params ~clisockaddr in callback req outchan in match root with @@ -349,3 +389,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 +