open Http_constants
open Http_parser
+exception Http_daemon_failure of string
+
(** send raw data on outchan, flushing it afterwards *)
let send_raw ~data outchan =
output_string outchan data;
(int_of_code code) func_name)
else begin (* status code suitable for answering *)
let headers =
- [ "Connection", "close";
- "Content-Type", "text/html; charset=iso-8859-1" ] @ headers
+ [ "Content-Type", "text/html; charset=iso-8859-1" ] @ headers
in
let body = (foo_body (int_of_code code) body) ^ body in
respond ?version ~code ~headers ~body outchan
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:(`Code 400) ~body:"Unexpected End Of File" outchan;
- raise Again
| (Malformed_request req) as e ->
debug_print (pp_parse_exc e);
respond_error ~code:(`Code 400)
- ~body:("request 1st line format should be: '<method> <url> <version>'" ^
- "<br />\nwhile received request 1st line was:<br />\n" ^ req)
+ ~body:("request 1st line format should be: " ^
+ "'<method> <url> <version>'" ^
+ "<br />\nwhile received request 1st line was:<br />\n" ^ req)
outchan;
raise Again
| (Invalid_HTTP_method meth) as e ->
~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
chdir_to_document_root spec.root_dir;
let sockaddr = Http_misc.build_sockaddr (spec.address, spec.port) in
let daemon_callback inchan outchan =
- try
- let req = safe_parse_request' inchan outchan in
- handle_auth req spec outchan;
- flush outchan
+ let next_req () =
+ try Some (safe_parse_request' inchan outchan)
+ with _ -> None
+ in
+ let rec loop n =
+ match next_req () with
+ | Some req ->
+ debug_print (sprintf "request #%d" n);
+ handle_auth req spec outchan;
+ flush outchan;
+ loop (n + 1)
+ | None ->
+ debug_print "server exiting";
+ ()
+ in
+ debug_print "server starting";
+ try loop 1
with exn ->
+ debug_print (sprintf "uncaught exception: %s" (Printexc.to_string exn));
(match spec.exn_handler with
| Some f ->
- debug_print "uncaught exception: executing handler";
+ debug_print "executing handler";
f exn outchan
| None ->
- debug_print "uncaught exception but no handler given: re-raising";
+ debug_print "no handler given: re-raising";
raise exn)
in
try
let main spec = main { spec with callback = trivial_callback }
end
- (* @param inchan input channel connected to client
+ (** @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
+ let close' o = try o#close with Http_daemon_failure _ -> () in
object (self)
initializer Gc.finalise close' self
method private assertNotClosed =
if closed then
- failwith "Http_daemon.connection: connection is closed"
+ raise (Http_daemon_failure
+ "Http_daemon.connection: connection is closed")
method getRequest =
self#assertNotClosed;
try
Some (safe_parse_request' inchan outchan)
- with Again -> None
+ with _ -> None
method respond_with res =
self#assertNotClosed;