X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_daemon.ml;h=9e49551f4c6ac742ceaebd1a3040cc624814b9d7;hb=89262281b6e83bd2321150f81f1a0583645eb0c8;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..9e49551f4 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_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 " @@ -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: ' '" ^ + "
\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 (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: ' '" ^ - "
\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 - | `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 +