(*
OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
- Copyright (C) <2002> 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
-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
-let default_mode = `Fork
+exception Http_daemon_failure of string
(** send raw data on outchan, flushing it afterwards *)
let send_raw ~data outchan =
let send_CRLF = send_raw ~data:crlf
let send_header ~header ~value =
- Http_parser.heal_header (header, value);
+ Http_parser_sanity.heal_header (header, value);
send_raw ~data:(header ^ ": " ^ value ^ crlf)
let send_headers ~headers outchan =
List.iter (fun (header, value) -> send_header ~header ~value outchan) headers
- (** internal: parse a code argument from a function which have two optional
- arguments "code" and "status" *)
-let get_code_argument func_name =
- fun ~code ~status ->
- (match code, status with
- | Some c, None -> c
- | None, Some s -> code_of_status s
- | Some _, Some _ ->
- failwith (func_name ^ " you must give 'code' or 'status', not both")
- | None, None ->
- failwith (func_name ^ " you must give 'code' or 'status', not none"))
-
(** internal: low level for send_status_line *)
-let send_status_line' ~version ~code =
+let send_status_line' ~version code =
let status_line =
String.concat
" "
in
send_raw ~data:(status_line ^ crlf)
-let send_status_line ?(version = http_version) ?code ?status outchan =
- send_status_line'
- ~version
- ~code:(get_code_argument "Daemon.send_status_line" ~code ~status)
- outchan
+let int_of_code = function
+ | `Code code -> code
+ | `Status status -> code_of_status status
+
+let send_status_line ?(version = http_version) ~(code: status_code) outchan =
+ send_status_line' ~version (int_of_code code) outchan
(* FIXME duplication of code between this and response#addBasicHeaders *)
-let send_basic_headers ?(version = http_version) ?code ?status outchan =
- send_status_line'
- ~version ~code:(get_code_argument "Daemon.send_basic_headers" ~code ~status)
- outchan;
+let send_basic_headers ?(version = http_version) ~(code: status_code) outchan =
+ send_status_line' ~version (int_of_code code) outchan;
send_headers
~headers:["Date", Http_misc.date_822 (); "Server", server_string]
outchan
of an HTTP response; body, if given, will be appended to the body *)
let send_foo_body code body = send_raw ~data:(foo_body code body)
- (* TODO add the computation of Content-Length header *)
-let respond
(* Warning: keep default values in sync with Http_response.response class *)
- ?(body = "") ?(headers = [])
- ?(version = http_version) ?(code = 200) ?status outchan
- =
- let code =
- match status with
- | None -> code
- | Some s -> code_of_status s
- in
- send_basic_headers ~version ~code outchan;
+let respond ?(body = "") ?(headers = []) ?version ?(code = `Code 200) outchan =
+ send_basic_headers ?version ~code outchan;
send_headers ~headers outchan;
+ send_header "Content-Length" (string_of_int (String.length body)) outchan;
send_CRLF outchan;
send_raw ~data:body outchan
reason phrase; if body is given it will be included in the body of the HTML
page *)
let send_empty_response
- func_name ?(is_valid_status = fun _ -> true) ?(headers = []) ~body () =
- fun ?(version = http_version) ?code ?status outchan ->
- let code = get_code_argument func_name ~code ~status in
- if not (is_valid_status code) then
+ func_name ?(is_valid_status = fun _ -> true) ?(headers=[]) ?(body="") () =
+ fun ?version code outchan ->
+ if not (is_valid_status (int_of_code code)) then
failwith
- (sprintf "'%d' isn't a valid status code for %s" code func_name)
+ (sprintf "'%d' isn't a valid status code for %s"
+ (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 code body) ^ body in
- respond ~version ~code ~headers ~body outchan
-(*
- (* OLD VERSION, now use 'respond' function *)
- send_basic_headers ~version ~code outchan;
- send_header ~header:"Connection" ~value:"close" outchan;
- send_header
- ~header:"Content-Type"
- ~value:"text/html; charset=iso-8859-1"
- outchan;
- send_headers ~headers outchan;
- send_CRLF outchan;
- send_foo_body ~code ~body outchan
-*)
+ let body = (foo_body (int_of_code code) body) ^ body in
+ respond ?version ~code ~headers ~body outchan
end
let respond_redirect
- ~location ?(body = "") ?(version = http_version) ?(code = 301) ?status outchan
+ ~location ?body ?version ?(code = `Code 301) outchan
=
- let code =
- match status with
- | None -> code
- | Some (s: Http_types.redirection_status) -> code_of_status s
- in
- send_empty_response
- "Daemon.respond_redirect" ~is_valid_status:is_redirection
- ~headers:["Location", location] ~body ()
- ~version ~code outchan
-
-let respond_error
- ?(body = "") ?(version = http_version) ?(code = 400) ?status outchan =
- let code =
- match status with
- | None -> code
- | Some s -> code_of_status s
- in
- send_empty_response
- "Daemon.respond_error" ~is_valid_status:is_error ~body ()
- ~version ~code outchan
+ send_empty_response "Daemon.respond_redirect" ~is_valid_status:is_redirection
+ ~headers:["Location", location] ?body () ?version code outchan
+
+let respond_error ?body ?version ?(code = `Code 400) outchan =
+ send_empty_response "Daemon.respond_error" ~is_valid_status:is_error
+ ?body () ?version code outchan
+
+let respond_not_found ~url ?version outchan =
+ send_empty_response "Daemon.respond_not_found" () ?version (`Code 404) outchan
-let respond_not_found ~url ?(version = http_version) outchan =
- send_empty_response
- "Daemon.respond_not_found" ~body:"" () ~version ~code:404 outchan
+let respond_forbidden ~url ?version outchan =
+ send_empty_response "Daemon.respond_permission_denied" () ?version
+ (`Code 403) outchan
-let respond_forbidden ~url ?(version = http_version) outchan =
- send_empty_response
- "Daemon.respond_permission_denied" ~body:"" () ~version ~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) ~body outchan
-let send_file ?name ?file outchan =
+let send_file ~src outchan =
let buflen = 1024 in
let buf = String.make buflen ' ' in
+
let (file, cleanup) =
- (match (name, file) with
- | Some n, None -> (* if we open the file, we close it before returning *)
- let f = open_in n in
+ match src with
+ | FileSrc fname -> (* if we open the file, we close it before returning *)
+ let f = open_in fname in
f, (fun () -> close_in f)
- | None, Some f -> (f, (fun () -> ()))
- | _ -> failwith "Daemon.send_file: either name or file must be given")
+ | InChanSrc inchan -> inchan, ignore
in
try
while true do
try
if Http_misc.is_directory path then begin (* file found, is a dir *)
let dir = Unix.opendir path in
- send_basic_headers ~version ~code:200 outchan;
+ send_basic_headers ~version ~code:(`Code 200) outchan;
send_header "Content-Type" "text/html" outchan;
send_CRLF outchan;
send_dir_listing ~dir ~name:fname ~path outchan;
Unix.closedir dir
end else begin (* file found, is something else *)
let file = open_in fname in
- send_basic_headers ~version ~code:200 outchan;
+ send_basic_headers ~version ~code:(`Code 200) outchan;
send_header
~header:"Content-Length"
~value:(string_of_int (Http_misc.filesize fname))
outchan;
send_CRLF outchan;
- send_file ~file outchan;
+ send_file ~src:(InChanSrc file) 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 =
res#serialize outchan;
flush outchan
+ (** internal: this exception is raised after a malformed request has been read
+ by a serving process to signal main server (or itself if mode = `Single) to
+ 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
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 ->
- respond_error ~code:400 ~body:"Unexpected End Of File" outchan;
- raise Again
- | Malformed_request req ->
- respond_error
- ~code:400
- ~body:(
- "request 1st line format should be: '<method> <url> <version>'" ^
- "<br />\nwhile received request 1st line was:<br />\n" ^ req)
+ | (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)
outchan;
raise Again
- | Unsupported_method meth ->
- respond_error
- ~code:501
+ | (Invalid_HTTP_method meth) as e ->
+ debug_print (pp_parse_exc e);
+ respond_error ~code:(`Code 501)
~body:("Method '" ^ meth ^ "' isn't supported (yet)")
outchan;
raise Again
- | Malformed_request_URI uri ->
- respond_error ~code:400 ~body:("Malformed URL: '" ^ uri ^ "'") outchan;
+ | (Malformed_request_URI uri) as e ->
+ debug_print (pp_parse_exc e);
+ respond_error ~code:(`Code 400) ~body:("Malformed URL: '" ^ uri ^ "'")
+ outchan;
raise Again
- | Unsupported_HTTP_version version ->
- respond_error
- ~code:505
+ | (Invalid_HTTP_version version) as e ->
+ debug_print (pp_parse_exc e);
+ respond_error ~code:(`Code 505)
~body:("HTTP version '" ^ version ^ "' isn't supported (yet)")
outchan;
raise Again
- | Malformed_query query ->
- respond_error
- ~code:400 ~body:(sprintf "Malformed query string '%s'" query) outchan;
+ | (Malformed_query query) as e ->
+ debug_print (pp_parse_exc e);
+ respond_error ~code:(`Code 400)
+ ~body:(sprintf "Malformed query string '%s'" query) outchan;
raise Again
- | Malformed_query_part (binding, query) ->
- respond_error
- ~code:400
- ~body:(
- sprintf "Malformed query part '%s' in query '%s'" binding query)
+ | (Malformed_query_part (binding, query)) as e ->
+ debug_print (pp_parse_exc e);
+ respond_error ~code:(`Code 400)
+ ~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
let safe_parse_request = wrap_parse_request_w_safety parse_request
(* as above but for OO version (Http_parser.parse_request') *)
-let safe_parse_request' = wrap_parse_request_w_safety parse_request'
+let safe_parse_request' = wrap_parse_request_w_safety (new Http_request.request)
+
+let chdir_to_document_root = function (* chdir to document root *)
+ | Some dir -> Sys.chdir dir
+ | None -> ()
+
+let server_of_mode = function
+ | `Single -> Http_tcp_server.simple
+ | `Fork -> Http_tcp_server.fork
+ | `Thread -> Http_tcp_server.thread
+
+ (* TODO what happens when a Quit exception is raised by a callback? Do other
+ 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
=
- (match root with (* chdir to document root *)
- | Some dir -> Sys.chdir dir
- | None -> ());
- let sockaddr = Http_misc.build_sockaddr ~addr ~port in
+ 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 Again -> ()
+ flush outchan);
in
- match mode with
- | `Single -> Http_tcp_server.simple ~sockaddr ~timeout daemon_callback
- | `Fork -> Http_tcp_server.ocaml_builtin ~sockaddr ~timeout daemon_callback
- | `Thread -> Http_tcp_server.thread ~sockaddr ~timeout daemon_callback
+ 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
- =
- let wrapper path params outchan =
- let req = new Http_request.request ~path ~params in
- callback req outchan
+ ?(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 =
+ handle_manual_auth outchan (fun () ->
+ let req = safe_parse_request' inchan outchan in
+ callback req outchan;
+ flush outchan)
in
- match root with
- | None -> start ~addr ~port ~timeout ~mode wrapper
- | Some root -> start ~addr ~port ~timeout ~mode ~root wrapper
+ 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
- respond_error ~code:400 outchan
+ 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
+ (** @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;
object (self)
val suck =
- Http_tcp_server.init_socket (Http_misc.build_sockaddr ~addr ~port)
+ Http_tcp_server.init_socket (Http_misc.build_sockaddr (addr, port))
method accept =
let (cli_suck, cli_sockaddr) = Unix.accept suck in (* may block *)
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;
+ }
+
projects / helm.git / blobdiff