X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_daemon.ml;h=8dfc83e5076e3af6e424a678b4a794e1589d361d;hb=856dc227c9781439a31d03f5b68d32a41db63ab9;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..8dfc83e50 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.ml +++ b/helm/DEVEL/ocaml-http/http_daemon.ml @@ -19,158 +19,32 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) -open Neturl;; open Printf;; -let debug = false +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_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:crlf +let send_CRLF = send_raw ~data:Http_common.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 = + send_raw ~data:(header ^ ": " ^ value ^ Http_common.crlf) let send_headers ~headers outchan = List.iter (fun (header, value) -> send_header ~header ~value outchan) headers @@ -196,7 +70,7 @@ let send_status_line' ~version ~code = string_of_int code; Http_common.reason_phrase_of_code code ] in - send_raw ~data:(status_line ^ crlf) + send_raw ~data:(status_line ^ Http_common.crlf) let send_status_line ?(version = Http_common.http_version) ?code ?status outchan @@ -206,6 +80,7 @@ let send_status_line ~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 = @@ -213,7 +88,7 @@ let send_basic_headers ~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", Http_common.server_string] outchan (** internal: send a fooish body explaining in HTML form the 'reason phrase' @@ -376,26 +251,16 @@ let respond_with (res: Http_types.response) outchan = res#serialize outchan; flush outchan + (* curried request *) let start ?(addr = default_addr) ?(port = default_port) - ?(timeout = Some default_timeout) + ?(timeout = Some default_timeout) ?(fork = default_fork) 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 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) = Http_parser.parse_request inchan in callback path parameters outchan; flush outchan with @@ -430,18 +295,21 @@ let start sprintf "Malformed query element '%s' in query '%s'" binding query) outchan in - Unix.establish_server daemon_callback sockaddr + match fork with + | true -> Http_tcp_server.ocaml_builtin ~sockaddr ~timeout daemon_callback + | false -> Http_tcp_server.simple ~sockaddr ~timeout daemon_callback + (* OO request *) let start' ?(addr = default_addr) ?(port = default_port) - ?(timeout = Some default_timeout) + ?(timeout = Some default_timeout) ?(fork = default_fork) (callback: (Http_types.request -> out_channel -> unit)) = let wrapper path params outchan = let req = new Http_request.request ~path ~params in callback req outchan in - start ~addr ~port ~timeout wrapper + start ~addr ~port ~timeout ~fork wrapper module Trivial = struct