X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_daemon.ml;h=a56780a9fb1252e78921fc80c4c714ec1f16dd15;hb=ca9cd0aeee0ce78a891f7f6091ca8704231a446d;hp=3fa78b34991b5a2d5f12a0479dfdf2c1b2435a3e;hpb=6a8da4dd52033adfe80533f7467439aec1561147;p=helm.git diff --git a/helm/DEVEL/ocaml-http/http_daemon.ml b/helm/DEVEL/ocaml-http/http_daemon.ml index 3fa78b349..a56780a9f 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.ml +++ b/helm/DEVEL/ocaml-http/http_daemon.ml @@ -19,148 +19,24 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) -open Neturl;; open Printf;; -let debug = false +open Http_common;; +open Http_types;; +open Http_constants;; +open Http_parser;; + +let debug = true let debug_print str = - prerr_endline ("DEBUG: " ^ str); - flush stderr + if debug then begin + prerr_endline ("DEBUG: " ^ str); + flush stderr + end let default_addr = "0.0.0.0" let default_port = 80 let default_timeout = 300 - -(* -type url_syntax_option = - Url_part_not_recognized - | Url_part_allowed - | Url_part_required - -* (1) scheme://user:password@host:port/path;params?query#fragment -*) - -let request_uri_syntax = { - url_enable_scheme = Url_part_not_recognized; - url_enable_user = Url_part_not_recognized; - url_enable_password = Url_part_not_recognized; - url_enable_host = Url_part_not_recognized; - url_enable_port = Url_part_not_recognized; - url_enable_path = Url_part_required; - url_enable_param = Url_part_not_recognized; - url_enable_query = Url_part_allowed; - url_enable_fragment = Url_part_not_recognized; - url_enable_other = Url_part_not_recognized; - url_accepts_8bits = false; - url_is_valid = (fun _ -> true); -} - -let crlf = "\r\n" - -exception Malformed_request of string -exception Unsupported_method of string -exception Malformed_request_URI of string -exception Unsupported_HTTP_version of string -exception Malformed_query of string -exception Malformed_query_binding of string * string - - (** given a list of length 2 - @return a pair formed by the elements of the list - @raise Assert_failure if the list length isn't 2 - *) -let pair_of_2_sized_list = function - | [a;b] -> (a,b) - | _ -> assert false - - (** given an HTTP like query string (e.g. "name1=value1&name2=value2&...") - @return a list of pairs [("name1", "value1"); ("name2", "value2")] - @raise Malformed_query if the string isn't a valid query string - @raise Malformed_query_binding if some piece of the query isn't valid - *) -let split_query_params = - let (bindings_sep, binding_sep) = (Pcre.regexp "&", Pcre.regexp "=") in - fun ~query -> - let bindings = Pcre.split ~rex:bindings_sep query in - if List.length bindings < 1 then - raise (Malformed_query query); - List.map - (fun binding -> - let pieces = Pcre.split ~rex:binding_sep binding in - if List.length pieces <> 2 then - raise (Malformed_query_binding (binding, query)); - pair_of_2_sized_list pieces) - bindings - - (** given an input channel and a separator - @return a line read from it (like Pervasives.input_line) - line is returned only after reading a separator string; separator string isn't - included in the returned value - FIXME what about efficiency?, input is performed char-by-char - *) -let generic_input_line ~sep ~ic = - let sep_len = String.length sep in - if sep_len < 1 then - failwith ("Separator '" ^ sep ^ "' is too short!") - else (* valid separator *) - let line = ref "" in - let sep_pointer = ref 0 in - try - while true do - if !sep_pointer >= String.length sep then (* line completed *) - raise End_of_file - else begin (* incomplete line: need to read more *) - let ch = input_char ic in - if ch = String.get sep !sep_pointer then (* next piece of sep *) - incr sep_pointer - else begin (* useful char *) - for i = 0 to !sep_pointer - 1 do - line := !line ^ (String.make 1 (String.get sep i)) - done; - sep_pointer := 0; - line := !line ^ (String.make 1 ch) - end - end - done; - assert false (* unreacheable statement *) - with End_of_file -> - if !line = "" then - raise End_of_file - else - !line - - (** given an input channel, reads from it a GET HTTP request and - @return a pair where path is a string representing the - requested path and query_params is a list of pairs (the GET - parameters) - *) -let parse_http_request = - let patch_empty_path s = (if s = "" then "/" else s) in - let pieces_sep = Pcre.regexp " " in - fun ~ic -> - let request_line = generic_input_line ~sep:crlf ~ic in - if debug then - debug_print ("request_line: '" ^ request_line ^ "'"); - match Pcre.split ~rex:pieces_sep request_line with - | [meth; request_uri_raw; http_version] -> - if meth <> "GET" then - raise (Unsupported_method meth); - (match http_version with - | "HTTP/1.0" | "HTTP/1.1" -> () - | _ -> raise (Unsupported_HTTP_version http_version)); - let request_uri = - try - url_of_string request_uri_syntax request_uri_raw - with Malformed_URL -> - raise (Malformed_request_URI request_uri_raw) - in - let path = - patch_empty_path (String.concat "/" (url_path request_uri)) - in - let query_params = - try split_query_params (url_query request_uri) with Not_found -> [] - in - (path, query_params) - | _ -> raise (Malformed_request request_line) +let default_mode = `Fork (** send raw data on outchan, flushing it afterwards *) let send_raw ~data outchan = @@ -169,8 +45,9 @@ 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 = send_raw ~data:(header ^ ": " ^ value ^ crlf) +let send_header ~header ~value = + Http_parser_sanity.heal_header (header, value); + send_raw ~data:(header ^ ": " ^ value ^ crlf) let send_headers ~headers outchan = List.iter (fun (header, value) -> send_header ~header ~value outchan) headers @@ -181,7 +58,7 @@ let get_code_argument func_name = fun ~code ~status -> (match code, status with | Some c, None -> c - | None, Some s -> Http_common.code_of_status s + | None, Some s -> code_of_status s | Some _, Some _ -> failwith (func_name ^ " you must give 'code' or 'status', not both") | None, None -> @@ -192,46 +69,60 @@ let send_status_line' ~version ~code = let status_line = String.concat " " - [ Http_common.string_of_version version; + [ string_of_version version; string_of_int code; - Http_common.reason_phrase_of_code code ] + Http_misc.reason_phrase_of_code code ] in send_raw ~data:(status_line ^ crlf) -let send_status_line - ?(version = Http_common.http_version) ?code ?status outchan - = +let send_status_line ?(version = http_version) ?code ?status outchan = send_status_line' ~version ~code:(get_code_argument "Daemon.send_status_line" ~code ~status) outchan -let send_basic_headers - ?(version = Http_common.http_version) ?code ?status outchan - = + (* FIXME duplication of code between this and response#addBasicHeaders *) +let send_basic_headers ?(version = http_version) ?code ?status outchan = send_status_line' ~version ~code:(get_code_argument "Daemon.send_basic_headers" ~code ~status) outchan; send_headers - ~headers:["Date", Http_misc.date_822 (); "Server", "OCaml HTTP Daemon"] + ~headers:["Date", Http_misc.date_822 (); "Server", server_string] outchan - (** internal: send a fooish body explaining in HTML form the 'reason phrase' - of an HTTP response; body, if given, will be appended to the body *) -let send_foo_body ~code ~body = - let reason_phrase = Http_common.reason_phrase_of_code code in - let body = - sprintf + (** internal: given a status code and an additional body return a string + 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 = Http_misc.reason_phrase_of_code code in + sprintf " %d %s

%d - %s

%s " - code reason_phrase code reason_phrase - (match body with None -> "" | Some text -> "\n" ^ text) + code reason_phrase code reason_phrase body + + (** internal: send a fooish body explaining in HTML form the 'reason phrase' + 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) + +let respond + (* Warning: keep default values in sync with Http_response.response class *) + ?(body = "") ?(headers = []) + ?(version = http_version) ?(code = 200) ?status outchan + = + let code = + match status with + | None -> code + | Some s -> code_of_status s in - send_raw ~data:body + 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 (** internal: low level for respond_redirect, respond_error, ... This function send a status line corresponding to a given code, some basic @@ -239,12 +130,23 @@ let send_foo_body ~code ~body = reason phrase; if body is given it will be included in the body of the HTML page *) let send_empty_response - f_name ?(is_valid_status = fun _ -> true) ?(headers = []) ~body () = - fun ?(version = Http_common.http_version) ?code ?status outchan -> - let code = get_code_argument f_name ~code ~status in + func_name ?(is_valid_status = fun _ -> true) ?(headers = []) ~body () = + fun ?(version = http_version) ?code ?status outchan -> + let code = get_code_argument func_name ~code ~status in if not (is_valid_status code) then - failwith (sprintf "'%d' isn't a valid status code for %s" code f_name) + failwith + (sprintf "'%d' isn't a valid status code for %s" code func_name) else begin (* status code suitable for answering *) + let headers = + [ + "Connection", "close"; + "Content-Type", "text/html; charset=iso-8859-1" + ] @ headers + in + let body = (foo_body code body) ^ body in + respond ~version ~code ~headers ~body outchan +(* + (* OLD VERSION, now use 'respond' function *) send_basic_headers ~version ~code outchan; send_header ~header:"Connection" ~value:"close" outchan; send_header @@ -254,43 +156,40 @@ let send_empty_response send_headers ~headers outchan; send_CRLF outchan; send_foo_body ~code ~body outchan +*) end - (* TODO sanity tests on location *) let respond_redirect - ~location ?body - ?(version = Http_common.http_version) ?(code = 301) ?status outchan = - let code = - match status with - | None -> code - | Some (s: Http_types.redirection_status) -> Http_common.code_of_status s - in - send_empty_response - "Daemon.respond_redirect" ~is_valid_status:Http_common.is_redirection - ~headers:["Location", location] ~body () - ~version ~code outchan + ~location ?(body = "") ?(version = http_version) ?(code = 301) ?status outchan + = + let code = + match status with + | None -> code + | Some (s: Http_types.redirection_status) -> code_of_status s + in + send_empty_response + "Daemon.respond_redirect" ~is_valid_status:is_redirection + ~headers:["Location", location] ~body () + ~version ~code outchan let respond_error - ?body - ?(version = Http_common.http_version) ?(code = 400) ?status outchan = + ?(body = "") ?(version = http_version) ?(code = 400) ?status outchan = let code = match status with | None -> code - | Some s -> Http_common.code_of_status s + | Some s -> code_of_status s in send_empty_response - "Daemon.respond_error" ~is_valid_status:Http_common.is_error ~body () + "Daemon.respond_error" ~is_valid_status:is_error ~body () ~version ~code outchan -let respond_not_found ~url ?(version = Http_common.http_version) outchan = +let respond_not_found ~url ?(version = http_version) outchan = send_empty_response - "Daemon.respond_not_found" ~body:None () - ~version ~code:404 outchan + "Daemon.respond_not_found" ~body:"" () ~version ~code:404 outchan -let respond_forbidden ~url ?(version = Http_common.http_version) outchan = +let respond_forbidden ~url ?(version = http_version) outchan = send_empty_response - "Daemon.respond_permission_denied" ~body:None () - ~version ~code:403 outchan + "Daemon.respond_permission_denied" ~body:"" () ~version ~code:403 outchan let send_file ?name ?file outchan = let buflen = 1024 in @@ -337,7 +236,7 @@ let send_dir_listing ~dir ~name ~path outchan = fprintf outchan "\n"; flush outchan -let respond_file ~fname ?(version = Http_common.http_version) outchan = +let respond_file ~fname ?(version = http_version) outchan = (** ASSUMPTION: 'fname' doesn't begin with a "/"; it's relative to the current document root (usually the daemon's cwd) *) let droot = Sys.getcwd () in (* document root *) @@ -376,72 +275,112 @@ 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 (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) - callback + ?(timeout = Some default_timeout) ?(mode = default_mode) ?root callback = - let sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port) in - let timeout_callback signo = - if signo = Sys.sigalrm then begin - debug_print "TIMEOUT, exiting ..."; - exit 2 - end - in + chdir_to_document_root root; + let sockaddr = Http_misc.build_sockaddr (addr, port) in let daemon_callback inchan outchan = - (match timeout with - | Some timeout -> - ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_callback)); - ignore (Unix.alarm timeout) - | None -> ()); try - let (path, parameters) = parse_http_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:("Malformed query string '" ^ 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 - Unix.establish_server daemon_callback sockaddr + (server_of_mode mode) ~sockaddr ~timeout daemon_callback + (* OO request *) let start' ?(addr = default_addr) ?(port = default_port) - ?(timeout = Some default_timeout) - (callback: (Http_types.request -> out_channel -> unit)) + ?(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 - start ~addr ~port ~timeout wrapper + (server_of_mode mode) ~sockaddr ~timeout daemon_callback module Trivial = struct @@ -454,3 +393,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 +