(*
OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
- Copyright (C) <2002-2004> Stefano Zacchiroli <zack@cs.unibo.it>
+ Copyright (C) <2002-2005> Stefano Zacchiroli <zack@cs.unibo.it>
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;;
+open Printf
-open Http_common;;
-open Http_types;;
-open Http_constants;;
-open Http_parser;;
+open Http_common
+open Http_types
+open Http_constants
+open Http_parser
(** send raw data on outchan, flushing it afterwards *)
let send_raw ~data outchan =
(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
(`Code 403) outchan
let respond_unauthorized ?version ?(realm = server_string) outchan =
+ let body =
+ sprintf "401 - Unauthorized - Authentication failed for realm \"%s\"" realm
+ in
respond ~headers:["WWW-Authenticate", sprintf "Basic realm=\"%s\"" realm]
- ~code:(`Code 401) outchan
+ ~code:(`Code 401) ~body outchan
let send_file ~src outchan =
let buflen = 1024 in
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 =
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
callbacks keep on living until the end or are them all killed immediatly?
The right semantics should obviously be the first one *)
+let handle_manual_auth outchan f =
+ try
+ f ()
+ with
+ | Unauthorized realm -> respond_unauthorized ~realm outchan
+ | Again -> ()
+
+let handle_auth req spec outchan =
+ try
+ (match (spec.auth, req#authorization) with
+ | None, _ -> spec.callback req outchan (* no auth required *)
+ | Some (realm, `Basic (spec_username, spec_password)),
+ Some (`Basic (username, password))
+ when (username = spec_username) && (password = spec_password) ->
+ (* auth ok *)
+ spec.callback req outchan
+ | Some (realm, _), _ -> raise (Unauthorized realm)) (* auth failure *)
+ with
+ | Unauthorized realm -> respond_unauthorized ~realm outchan
+ | Again -> ()
+
(* TODO support also chroot to 'root', not only chdir *)
+ (* TODO deprecated: remove from future versions *)
(* curried request *)
let start
?(addr = default_addr) ?(port = default_port)
- ?(timeout = Some default_timeout) ?(mode = default_mode) ?root callback
+ ?(timeout = default_timeout) ?(mode = default_mode) ?root callback
=
+ Http_misc.warn
+ "Http_daemon.start is deprecated in favour of Http_daemon.main and will be removed in future versions of the library";
chdir_to_document_root root;
let sockaddr = Http_misc.build_sockaddr (addr, port) in
let daemon_callback inchan outchan =
- try
+ handle_manual_auth outchan (fun () ->
let (path, parameters) = safe_parse_request inchan outchan in
callback path parameters outchan;
- flush outchan
- with
- | Unauthorized realm -> respond_unauthorized ~realm outchan
- | Again -> ()
+ flush outchan);
in
try
(server_of_mode mode) ~sockaddr ~timeout daemon_callback
with Quit -> ()
(* OO request *)
+ (* TODO deprecated: remove from future versions *)
let start'
?(addr = default_addr) ?(port = default_port)
- ?(timeout = Some default_timeout) ?(mode = default_mode) ?root callback
- =
+ ?(timeout = default_timeout) ?(mode = default_mode) ?root callback
+=
+ Http_misc.warn
+ "Http_daemon.start' is deprecated in favour of Http_daemon.main and will be removed in future versions of the library";
chdir_to_document_root root;
let sockaddr = Http_misc.build_sockaddr (addr, port) in
let daemon_callback inchan outchan =
- try
+ handle_manual_auth outchan (fun () ->
let req = safe_parse_request' inchan outchan in
callback req outchan;
- flush outchan
- with
- | Unauthorized realm -> respond_unauthorized ~realm outchan
- | Again -> ()
+ flush outchan)
in
try
(server_of_mode mode) ~sockaddr ~timeout daemon_callback
with Quit -> ()
+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 =
+ 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 "executing handler";
+ f exn outchan
+ | None ->
+ debug_print "no handler given: re-raising";
+ raise exn)
+ in
+ try
+ (server_of_mode spec.mode) ~sockaddr ~timeout:spec.timeout daemon_callback
+ with Quit -> ()
+
module Trivial =
struct
- let callback path _ outchan =
- if not (Pcre.pmatch ~rex:(Pcre.regexp "^/") path) then
+ let heading_slash_RE = Pcre.regexp "^/"
+
+ let trivial_callback req outchan =
+ let path = req#path in
+ if not (Pcre.pmatch ~rex:heading_slash_RE path) then
respond_error ~code:(`Code 400) outchan
else
respond_file ~fname:(Http_misc.strip_heading_slash path) outchan
- let start ?(addr = default_addr) ?(port = default_port) () =
- start ~addr ~port callback
+
+ let callback = trivial_callback
+
+ let main spec = main { spec with callback = trivial_callback }
end
(* @param inchan input channel connected to client
self#assertNotClosed;
try
Some (safe_parse_request' inchan outchan)
- with Again -> None
+ with _ -> None
method respond_with res =
self#assertNotClosed;
end
+open Http_constants
+
+let default_spec = {
+ address = default_addr;
+ auth = default_auth;
+ callback = default_callback;
+ mode = default_mode;
+ port = default_port;
+ root_dir = default_root_dir;
+ exn_handler = default_exn_handler;
+ timeout = default_timeout;
+}
+
+let daemon_spec
+ ?(address = default_addr) ?(auth = default_auth)
+ ?(callback = default_callback) ?(mode = default_mode) ?(port = default_port)
+ ?(root_dir = default_root_dir) ?(exn_handler = default_exn_handler)
+ ?(timeout = default_timeout)
+ ()
+=
+ { default_spec with
+ address = address;
+ auth = auth;
+ callback = callback;
+ mode = mode;
+ port = port;
+ root_dir = root_dir;
+ exn_handler = exn_handler;
+ timeout = timeout;
+ }
+