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
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
(try
parse_function inchan
with
- | End_of_file ->
+ | (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 ->
+ | (Malformed_request req) as e ->
+ debug_print (pp_parse_exc e);
respond_error
~code:400
~body:(
"<br />\nwhile received request 1st line was:<br />\n" ^ req)
outchan;
raise Again
- | Unsupported_method meth ->
+ | (Unsupported_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 ->
+ | (Malformed_request_URI uri) as e ->
+ debug_print (pp_parse_exc e);
respond_error ~code:400 ~body:("Malformed URL: '" ^ uri ^ "'") outchan;
raise Again
- | Unsupported_HTTP_version version ->
+ | (Unsupported_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 ->
+ | (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) ->
+ | (Malformed_query_part (binding, query)) as e ->
+ debug_print (pp_parse_exc e);
respond_error
~code:400
~body:(
let server_of_mode = function
| `Single -> Http_tcp_server.simple
- | `Fork -> Http_tcp_server.ocaml_builtin
+ | `Fork -> Http_tcp_server.fork
| `Thread -> Http_tcp_server.thread
(* TODO support also chroot to 'root', not only chdir *)