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 <path, query_params> where path is a string representing the
- requested path and query_params is a list of pairs <name, value> (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
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
~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
=
~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'
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
sprintf "Malformed query element '%s' in query '%s'" binding query)
outchan
in
- Unix.establish_server daemon_callback sockaddr
+ match fork with
+ | true -> Tcp_server.ocaml_builtin ~sockaddr ~timeout daemon_callback
+ | false -> 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
projects / helm.git / blobdiff