From 54b81f2644be0741421824d757fc06128d9d7edc Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Thu, 3 Feb 2005 22:24:29 +0000 Subject: [PATCH] - added main that starts a new http_daemon given a daemon_spec (see Http_types.daemon_spec) - added default_spec - deprecated start and start' in favour of main --- helm/DEVEL/ocaml-http/http_daemon.ml | 127 +++++++++++++++++++++----- helm/DEVEL/ocaml-http/http_daemon.mli | 85 +++++++++++------ 2 files changed, 163 insertions(+), 49 deletions(-) diff --git a/helm/DEVEL/ocaml-http/http_daemon.ml b/helm/DEVEL/ocaml-http/http_daemon.ml index f29b4c1d1..1bbf83b20 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.ml +++ b/helm/DEVEL/ocaml-http/http_daemon.ml @@ -19,12 +19,12 @@ 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 = @@ -130,8 +130,11 @@ let respond_forbidden ~url ?version 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 @@ -303,56 +306,103 @@ let server_of_mode = function 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 = + try + let req = safe_parse_request' inchan outchan in + handle_auth req spec outchan; + flush outchan + with exn -> + (match spec.exn_handler with + | Some f -> + debug_print "uncaught exception: executing handler"; + f exn outchan + | None -> + debug_print "uncaught exception but 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 @@ -412,3 +462,34 @@ class daemon ?(addr = "0.0.0.0") ?(port = 80) () = 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; + } + diff --git a/helm/DEVEL/ocaml-http/http_daemon.mli b/helm/DEVEL/ocaml-http/http_daemon.mli index ba20a0b42..54b8c19d0 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.mli +++ b/helm/DEVEL/ocaml-http/http_daemon.mli @@ -108,27 +108,53 @@ val respond_file: (** respond using a prebuilt Http_types.response object *) val respond_with: Http_types.response -> out_channel -> unit - (** starts an HTTP daemon listening - * @param addr adress on which daemon will be listening, can be both a numeric - * address (e.g. "127.0.0.1") and an hostname (e.g. "localhost"). Default is + (** start an HTTP daemon + * @param spec specification of daemon behaviour + *) +val main: Http_types.daemon_spec -> unit + + (** default daemon specification: + * - listen on 0.0.0.0, port 80 + * - "always ok" callback (return an empty response, response code 200) + * - fork a child for each request + * - do not change to a root directory (i.e. keep cwd) + * - 300 seconds timeout + * - ignores exceptions + * - no authentication required *) +val default_spec: Http_types.daemon_spec + + (** currified daemon_spec constructor. Each parameter of this function + * corresponds to one field of Http_types.daemon_spec and defaults to the + * corresponding field of Http_daemon.default_spec *) +val daemon_spec: + ?address:string -> + ?auth:(string * Http_types.auth_info) option -> + ?callback:(Http_types.request -> out_channel -> unit) -> + ?mode:(Http_types.daemon_mode) -> + ?port:int -> + ?root_dir:string option -> + ?exn_handler:(exn -> out_channel -> unit) option -> + ?timeout:int option -> + unit -> + Http_types.daemon_spec + + (** starts an HTTP daemon (deprecated function) + * + * DEPRECATED, will be removed in future versions, please switch to + * Http_daemon.main below. + * + * see Http_types.daemon_spec for a detailed description of parameters + * @param addr like the "address" field of Http_types.daemon_spec, defaults to * the wildcard address "0.0.0.0" - * @param port TCP port on which the daemon will be listening. Default is the - * HTTP port 80 - * @param timeout timeout in seconds after which an incoming HTTP request will - * be terminated closing the corresponding TCP connection. Passing None will - * disable the timeout. Default is 5 minutes (300 seconds) - * @param mode requests handling mode, it can have three different values. - * `Single -> all requests will be handled by the same process, - * `Fork -> each request will be handled by a separate process - * `Thread -> each request will be handled by a separate thread - * Default is `Fork - * @param root document root (i.e. directory to which ocaml http will chdir - * before starting handling requests). Default is current working directory - * @param callback function which will be called each time a correct HTTP - * request will be received. 1st callback argument is the path requested by - * the HTTP client; 2nd argument is a list of pairs - * representing decoded query string; 3rd argument is an output channel - * connected with the client + * @param like the "port" field of Http_types.daemon_spec, defaults to 80 + * @param like the "timeout" field of Http_types.daemon_spec, defaults to Some + * 300 + * @param like the "mode" field of Http_types.daemon_spec, defaults to `Fork + * @param like the "root_dir" field of Http_types.daemon_spec, defaults to None + * @param callback functional version of the "callback" field of + * Http_types.daemon_spec. 1st argument is the request path, 2nd argument + * the decoded query string, 3rd argument an output channel connect to the + * client *) val start: ?addr: string -> ?port: int -> @@ -136,9 +162,14 @@ val start: (string -> (string * string) list -> out_channel -> unit) -> unit - (** identical to 'start' above but callback receive two arguments, the second - one is an out_channel as per 'start', but the secondo one is a Request.request - object *) + (** starts an HTTP daemon (deprecated function) + * + * DEPRECATED, will be removed in future versions, please switch to + * Http_daemon.main below. + * + * parameters as above except for the callback, in this case it behaves as the + * "callback" field of Http_types.daemon_spec + *) val start': ?addr: string -> ?port: int -> ?timeout: int option -> ?mode: Http_types.daemon_mode -> ?root: string -> @@ -161,9 +192,11 @@ module Trivial : sig (** callback function, exposed if you like to use it as a basis to define a more powerful daemon *) - val callback : string -> 'a -> out_channel -> unit + val callback : Http_types.request -> out_channel -> unit - (** start the "trivial" HTTP daemon *) - val start : ?addr:string -> ?port:int -> unit -> unit + (** start the "trivial" HTTP daemon + * @param spec trivial HTTP daemon specification, "callback" field is + * ignored and set to the callback above *) + val main : Http_types.daemon_spec -> unit end -- 2.39.2