X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_daemon.ml;h=9e0507dd2b1a4135643cef76cdfa73b9864edbe8;hb=1c7fb836e2af4f2f3d18afd0396701f2094265ff;hp=8dfc83e5076e3af6e424a678b4a794e1589d361d;hpb=dfc2157c1067b9958c182b25df103744cc8feb27;p=helm.git diff --git a/helm/DEVEL/ocaml-http/http_daemon.ml b/helm/DEVEL/ocaml-http/http_daemon.ml index 8dfc83e50..9e0507dd2 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.ml +++ b/helm/DEVEL/ocaml-http/http_daemon.ml @@ -21,30 +21,21 @@ open Printf;; +open Http_common;; +open Http_types;; +open Http_constants;; open Http_parser;; -let debug = true -let debug_print str = - 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 -let default_fork = true - (** send raw data on outchan, flushing it afterwards *) let send_raw ~data outchan = output_string outchan data; flush outchan -let send_CRLF = send_raw ~data:Http_common.crlf +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 ^ Http_common.crlf) + 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 @@ -55,10 +46,10 @@ 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 - | Some _, Some _ -> + | None, Some s -> code_of_status s + | 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 *) @@ -66,47 +57,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 ^ Http_common.crlf) + 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 (* FIXME duplication of code between this and response#addBasicHeaders *) -let send_basic_headers - ?(version = Http_common.http_version) ?code ?status outchan - = +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", Http_common.server_string] + ~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 @@ -114,12 +118,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 @@ -129,54 +144,62 @@ 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 send_file ?name ?file outchan = *) +let send_file ~src outchan = let buflen = 1024 in let buf = String.make buflen ' ' in +(* let (file, cleanup) = (match (name, file) with | Some n, None -> (* if we open the file, we close it before returning *) 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 +*) + let (file, cleanup) = + match src with + | FileSrc fname -> (* if we open the file, we close it before returning *) + let f = open_in fname in + f, (fun () -> close_in f) + | InChanSrc inchan -> inchan, ignore in try while true do @@ -212,7 +235,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 *) @@ -236,7 +259,7 @@ let respond_file ~fname ?(version = Http_common.http_version) outchan = ~value:(string_of_int (Http_misc.filesize fname)) outchan; send_CRLF outchan; - send_file ~file outchan; + send_file ~src:(InChanSrc file) outchan; close_in file end with @@ -251,65 +274,133 @@ 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;; + +let pp_parse_exc e = + sprintf "HTTP request parse error: %s" (Printexc.to_string e) + + (* 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) as e -> + debug_print (pp_parse_exc e); + respond_error ~code:400 ~body:"Unexpected End Of File" outchan; + raise Again + | (Malformed_request req) as e -> + debug_print (pp_parse_exc e); + respond_error + ~code:400 + ~body:( + "request 1st line format should be: ' '" ^ + "
\nwhile received request 1st line was:
\n" ^ req) + outchan; + raise Again + | (Invalid_HTTP_method meth) as e -> + debug_print (pp_parse_exc e); + respond_error + ~code:501 + ~body:("Method '" ^ meth ^ "' isn't supported (yet)") + outchan; + raise Again + | (Malformed_request_URI uri) as e -> + debug_print (pp_parse_exc e); + respond_error ~code:400 ~body:("Malformed URL: '" ^ uri ^ "'") outchan; + raise Again + | (Invalid_HTTP_version version) as e -> + debug_print (pp_parse_exc e); + respond_error + ~code:505 + ~body:("HTTP version '" ^ version ^ "' isn't supported (yet)") + outchan; + raise Again + | (Malformed_query query) as e -> + debug_print (pp_parse_exc e); + respond_error + ~code:400 ~body:(sprintf "Malformed query string '%s'" query) outchan; + raise Again + | (Malformed_query_part (binding, query)) as e -> + debug_print (pp_parse_exc e); + 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.fork + | `Thread -> Http_tcp_server.thread + + (* TODO what happens when a Quit exception is raised by a callback? Do other + callbacks keep on living until the end or are them all killed immediatly? + The right semantics should obviously be the first one *) + + (* TODO support also chroot to 'root', not only chdir *) (* curried request *) let start ?(addr = default_addr) ?(port = default_port) - ?(timeout = Some default_timeout) ?(fork = default_fork) - callback + ?(timeout = Some default_timeout) ?(mode = default_mode) ?root callback = - 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:("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 - match fork with - | true -> Http_tcp_server.ocaml_builtin ~sockaddr ~timeout daemon_callback - | false -> Http_tcp_server.simple ~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) ?(fork = default_fork) - (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 ~fork wrapper + try + (server_of_mode mode) ~sockaddr ~timeout daemon_callback + with Quit -> () module Trivial = struct @@ -322,3 +413,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 +