X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_daemon.ml;h=629d1286cfd7ea97be793e28bb01b8b891591455;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=1bbf83b20760080395bf73128fcbc0be31090797;hpb=54b81f2644be0741421824d757fc06128d9d7edc;p=helm.git diff --git a/helm/DEVEL/ocaml-http/http_daemon.ml b/helm/DEVEL/ocaml-http/http_daemon.ml index 1bbf83b20..629d1286c 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.ml +++ b/helm/DEVEL/ocaml-http/http_daemon.ml @@ -2,21 +2,21 @@ (* OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - Copyright (C) <2002-2004> Stefano Zacchiroli + Copyright (C) <2002-2005> Stefano Zacchiroli This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. + it under the terms of the GNU Library General Public License as + published by the Free Software Foundation, version 2. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. + GNU Library General Public License for more details. - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + You should have received a copy of the GNU Library General Public + License along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 + USA *) open Printf @@ -26,6 +26,8 @@ open Http_types 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; @@ -105,8 +107,7 @@ let send_empty_response (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 @@ -209,11 +210,9 @@ let respond_file ~fname ?(version = http_version) outchan = close_in file end with - | Unix.Unix_error (Unix.EACCES, s, _) when (s = fname) -> + | Unix.Unix_error (Unix.EACCES, _, _) + | Sys_error _ -> respond_forbidden ~url:fname ~version outchan - | Sys_error s when - (Pcre.pmatch ~rex:(Pcre.regexp (fname ^ ": Permission denied")) s) -> - respond_forbidden ~url:fname ~version outchan end let respond_with (res: Http_types.response) outchan = @@ -235,19 +234,15 @@ let pp_parse_exc e = 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: ' '" ^ - "
\nwhile received request 1st line was:
\n" ^ req) + ~body:("request 1st line format should be: " ^ + "'<method> <url> <version>'" ^ + "
\nwhile received request 1st line was:
\n" ^ req) outchan; raise Again | (Invalid_HTTP_method meth) as e -> @@ -278,10 +273,6 @@ let rec wrap_parse_request_w_safety parse_function inchan outchan = ~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 @@ -372,17 +363,31 @@ let main spec = 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 @@ -405,13 +410,13 @@ module Trivial = 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 @@ -420,13 +425,14 @@ class connection inchan outchan sockaddr = 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;