From: Stefano Zacchiroli Date: Fri, 6 Dec 2002 17:15:37 +0000 (+0000) Subject: - added safe_parse_request{,'} which wrap parse_request{,'} catching X-Git-Tag: v0_3_99~168 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=8c529f71e51025d3e827475f9e224bd0e07190eb;p=helm.git - 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 bcf3da81a..56596a920 100644 --- 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: ' '" ^ + "
\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' + (* 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: ' '" ^ - "
\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_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 46e8f61d5..c9c8deb53 100644 --- 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 +