-http_common.cmo: http_constants.cmi http_types.cmi http_common.cmi
+http_common.cmo: http_constants.cmi http_types.cmo http_common.cmi
http_common.cmx: http_constants.cmx http_types.cmx http_common.cmi
http_constants.cmo: http_constants.cmi
http_constants.cmx: http_constants.cmi
http_daemon.cmo: http_common.cmi http_constants.cmi http_misc.cmi \
- http_parser.cmi http_request.cmi http_tcp_server.cmi http_types.cmi \
- http_daemon.cmi
+ http_parser.cmi http_parser_sanity.cmi http_request.cmi \
+ http_tcp_server.cmi http_types.cmo http_daemon.cmi
http_daemon.cmx: http_common.cmx http_constants.cmx http_misc.cmx \
- http_parser.cmx http_request.cmx http_tcp_server.cmx http_types.cmx \
- http_daemon.cmi
-http_misc.cmo: http_types.cmi http_misc.cmi
+ http_parser.cmx http_parser_sanity.cmx http_request.cmx \
+ http_tcp_server.cmx http_types.cmx http_daemon.cmi
+http_message.cmo: http_common.cmi http_constants.cmi http_misc.cmi \
+ http_parser_sanity.cmi http_types.cmo http_message.cmi
+http_message.cmx: http_common.cmx http_constants.cmx http_misc.cmx \
+ http_parser_sanity.cmx http_types.cmx http_message.cmi
+http_misc.cmo: http_types.cmo http_misc.cmi
http_misc.cmx: http_types.cmx http_misc.cmi
-http_parser.cmo: http_common.cmi http_constants.cmi http_misc.cmi \
- http_request.cmi http_types.cmi http_parser.cmi
-http_parser.cmx: http_common.cmx http_constants.cmx http_misc.cmx \
- http_request.cmx http_types.cmx http_parser.cmi
-http_request.cmo: http_common.cmi http_misc.cmi http_types.cmi \
- http_request.cmi
-http_request.cmx: http_common.cmx http_misc.cmx http_types.cmx \
- http_request.cmi
+http_parser.cmo: http_common.cmi http_constants.cmi http_parser_sanity.cmi \
+ http_types.cmo http_parser.cmi
+http_parser.cmx: http_common.cmx http_constants.cmx http_parser_sanity.cmx \
+ http_types.cmx http_parser.cmi
+http_parser_sanity.cmo: http_constants.cmi http_types.cmo \
+ http_parser_sanity.cmi
+http_parser_sanity.cmx: http_constants.cmx http_types.cmx \
+ http_parser_sanity.cmi
+http_request.cmo: http_common.cmi http_message.cmi http_misc.cmi \
+ http_parser.cmi http_types.cmo http_request.cmi
+http_request.cmx: http_common.cmx http_message.cmx http_misc.cmx \
+ http_parser.cmx http_types.cmx http_request.cmi
http_response.cmo: http_common.cmi http_constants.cmi http_daemon.cmi \
- http_misc.cmi http_parser.cmi http_types.cmi http_response.cmi
+ http_message.cmi http_misc.cmi http_types.cmo http_response.cmi
http_response.cmx: http_common.cmx http_constants.cmx http_daemon.cmx \
- http_misc.cmx http_parser.cmx http_types.cmx http_response.cmi
+ http_message.cmx http_misc.cmx http_types.cmx http_response.cmi
http_tcp_server.cmo: http_threaded_tcp_server.cmi http_tcp_server.cmi
http_tcp_server.cmx: http_threaded_tcp_server.cmi http_tcp_server.cmi
-http_types.cmo: http_types.cmi
-http_types.cmx: http_types.cmi
-http_common.cmi: http_types.cmi
-http_constants.cmi: http_types.cmi
-http_daemon.cmi: http_types.cmi
-http_parser.cmi: http_types.cmi
-http_request.cmi: http_types.cmi
-http_response.cmi: http_types.cmi
-http_tcp_server.cmi: http_types.cmi
+http_common.cmi: http_types.cmo
+http_constants.cmi: http_types.cmo
+http_daemon.cmi: http_types.cmo
+http_message.cmi: http_types.cmo
+http_parser.cmi: http_types.cmo
+http_request.cmi: http_types.cmo
+http_response.cmi: http_types.cmo
+http_tcp_server.cmi: http_types.cmo
include Makefile.defs
MODULES = \
- http_types http_constants http_misc http_tcp_server http_common \
- http_request http_parser http_daemon http_response
+ http_types http_constants http_tcp_server http_parser_sanity \
+ http_misc http_common http_parser http_message http_request \
+ http_daemon http_response
THREADED_SRV = http_threaded_tcp_server
MODULES_MT = $(patsubst http_tcp_server, mt/$(THREADED_SRV) http_tcp_server, $(MODULES))
MODULES_NON_MT = $(patsubst http_tcp_server, non_mt/$(THREADED_SRV) http_tcp_server, $(MODULES))
$(OCAMLC) -c $<
%.cmx: %.ml %.cmi
$(OCAMLOPT) -c $<
+include Makefile.overrides
non_mt/$(THREADED_SRV).cmo: non_mt/$(THREADED_SRV).ml $(THREADED_SRV).cmi
cp $(THREADED_SRV).{cmi,mli} non_mt/
--- /dev/null
+http_types.cmi http_types.cmo: http_types.ml
+ $(OCAMLC) -c $<
-
-- keep in request objects or somewhere client information like IP address
-
-- parse also header and contents of http requests and add corresponding methods
- to requests objects
- - subTODO: support POST requests
-
* Use Pcre to perform sanity test on headers instead of home made
parsing
- -- Stefano Zacchiroli <zack@debian.org> Wed, 4 Dec 2002 09:43:31 +0100
+ -- Stefano Zacchiroli <zack@debian.org> Wed, 25 Dec 2002 16:22:31 +0100
ocaml-http (0.0.6) unstable; urgency=low
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
+open Http_types;;
open Printf;;
(*
let inchan = Unix.in_channel_of_descr suck in
wget' inchan ""
in
-let callback req outchan =
+let callback (req: request) outchan =
let i = int_of_string (req#param "x") in
prerr_endline (string_of_int i);
match i with
open Printf;;
-let dump_args path args =
- Printf.sprintf
- "PATH: %s\nARGS:\n%s"
- path
- (String.concat
- ""
- (List.map
- (fun (name, value) -> sprintf "\tNAME: '%s', VALUE: '%s'\n" name value)
- args))
-in
-let callback path args outchan =
- match path with
- | "/gone" ->
- Http_daemon.respond_redirect
- ~location:"/foo" ~body:"REDIRECT" ~code:302 outchan
- | "/error" ->
- Http_daemon.respond_error ~body:"ERROR" ~code:500 outchan
- | _ ->
- begin
- Http_daemon.send_basic_headers ~code:200 outchan;
- Http_daemon.send_CRLF outchan;
- output_string outchan (dump_args path args)
- end
+let callback req outchan =
+ Http_daemon.send_basic_headers ~code:200 outchan;
+ Http_daemon.send_CRLF outchan;
+ let (s1, s2, s3, s4) =
+ (sprintf "request path = %s\n" req#path),
+ (sprintf "request GET params = %s\n"
+ (String.concat ";"
+ (List.map (fun (h,v) -> String.concat "=" [h;v]) req#params_GET))),
+ (sprintf "request POST params = %s\n"
+ (String.concat ";"
+ (List.map (fun (h,v) -> String.concat "=" [h;v]) req#params_POST))),
+ (sprintf "request ALL params = %s\n"
+ (String.concat ";"
+ (List.map (fun (h,v) -> String.concat "=" [h;v]) req#params)))
+ in
+ output_string outchan (s1 ^ s2 ^ s3 ^ s4);
+ prerr_endline (s1 ^ s2 ^ s3 ^ s4)
in
print_endline "Starting custom Http_daemon ...";
flush stdout;
-Http_daemon.start ~port:9999 callback
+Http_daemon.start' ~port:9999 callback
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
-let callback req outchan =
+open Http_types;;
+
+let callback (req: request) outchan =
Http_daemon.respond_error ~body:(req#param "foo") outchan
in
Http_daemon.start' ~port:9999 callback
| "HTTP/1.1" -> `HTTP_1_1
| invalid_version -> raise (Invalid_HTTP_version invalid_version)
+let string_of_method = function
+ | `GET -> "GET"
+ | `POST -> "POST"
+
+let method_of_string = function
+ | "GET" -> `GET
+ | "POST" -> `POST
+ | invalid_method -> raise (Invalid_HTTP_method invalid_method)
+
let status_of_code = function
| 100 -> `Informational `Continue
| 101 -> `Informational `Switching_protocols
(** Common functionalities *)
+open Http_types;;
+
(** whether debugging messages are enabled or not, can be changed at runtime
*)
val debug: bool ref
(** print a string on stderr only if debugging is enabled *)
val debug_print: string -> unit
-val http_version: Http_types.version
+val http_version: version
val server_string: string
-val string_of_version: Http_types.version -> string
-val version_of_string: string -> Http_types.version
+val string_of_version: version -> string
+val version_of_string: string -> version
+
+val string_of_method: meth -> string
+val method_of_string: string -> meth
-val status_of_code: int -> Http_types.status
-val code_of_status: [< Http_types.status] -> int
+val status_of_code: int -> status
+val code_of_status: [< status] -> int
val is_informational: int -> bool
val is_success: int -> bool
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 =
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 = [])
in
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
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.ocaml_builtin
+ | `Thread -> Http_tcp_server.thread
+
(* TODO support also chroot to 'root', not only chdir *)
(* curried request *)
let start
flush outchan
with Again -> ()
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
+ (server_of_mode mode) ~sockaddr ~timeout daemon_callback
(* OO request *)
let start'
?(addr = default_addr) ?(port = default_port)
?(timeout = Some default_timeout) ?(mode = default_mode) ?root callback
=
- let wrapper path params outchan =
- let clisockaddr = Http_misc.peername_of_out_channel outchan in
- let req = new Http_request.request ~path ~params ~clisockaddr in
- callback req outchan
+ chdir_to_document_root root;
+ let sockaddr = Http_misc.build_sockaddr (addr, port) in
+ let daemon_callback inchan outchan =
+ try
+ let req = safe_parse_request' inchan outchan in
+ callback req outchan;
+ flush outchan
+ with Again -> ()
in
- match root with
- | None -> start ~addr ~port ~timeout ~mode wrapper
- | Some root -> start ~addr ~port ~timeout ~mode ~root wrapper
+ (server_of_mode mode) ~sockaddr ~timeout daemon_callback
module Trivial =
struct
(if 'file' is given) or as a file name (if 'name' is given) *)
val send_file: ?name:string -> ?file:in_channel -> out_channel -> unit
- (** high level response function, respond on outchan sending: basic headers,
- headers probided via 'headers' argument, body given via 'body' argument.
- Default response status is 200, default response HTTP version is
- Http_common.http_version *)
+ (** high level response function, respond on outchan sending: basic headers
+ (including Content-Length computed using 'body' argument), headers probided
+ via 'headers' argument, body given via 'body' argument. Default response
+ status is 200, default response HTTP version is Http_common.http_version *)
val respond:
?body:string -> ?headers:(string * string) list ->
?version:Http_types.version -> ?code:int -> ?status:Http_types.status ->
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> 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.
+
+ 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.
+
+ 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
+*)
+
+open Http_common;;
+open Http_constants;;
+open Http_types;;
+open Printf;;
+
+class virtual message ~body ~headers ~version ~clisockaddr ~srvsockaddr =
+
+ (* remove all bindings of 'name' from hashtbl 'tbl' *)
+ let rec hashtbl_remove_all tbl name =
+ if not (Hashtbl.mem tbl name) then
+ raise (Header_not_found name);
+ Hashtbl.remove tbl name;
+ if Hashtbl.mem tbl name then hashtbl_remove_all tbl name
+ in
+
+ let ((cliaddr, cliport), (srvaddr, srvport)) =
+ (Http_misc.explode_sockaddr clisockaddr,
+ Http_misc.explode_sockaddr srvsockaddr)
+ in
+
+ object (self)
+
+ val _contentsBuf = Buffer.create 1024
+ val _headers = Hashtbl.create 11
+ val mutable _version: version = version
+
+ initializer
+ self#setBody body;
+ self#addHeaders headers
+
+ method version = _version
+ method setVersion v = _version <- v
+
+ method body = Buffer.contents _contentsBuf
+ method setBody c =
+ Buffer.clear _contentsBuf;
+ Buffer.add_string _contentsBuf c
+ method bodyBuf = _contentsBuf
+ method setBodyBuf b =
+ Buffer.clear _contentsBuf;
+ Buffer.add_buffer _contentsBuf b
+ method addBody s = Buffer.add_string _contentsBuf s
+ method addBodyBuf b = Buffer.add_buffer _contentsBuf b
+
+ method addHeader ~name ~value =
+ Http_parser_sanity.heal_header (name, value);
+ Hashtbl.add _headers name value
+ method addHeaders =
+ List.iter (fun (name, value) -> self#addHeader ~name ~value)
+ method replaceHeader ~name ~value =
+ Http_parser_sanity.heal_header (name, value);
+ Hashtbl.replace _headers name value
+ method replaceHeaders =
+ List.iter (fun (name, value) -> self#replaceHeader ~name ~value)
+ method removeHeader ~name = hashtbl_remove_all _headers name
+ method hasHeader ~name = Hashtbl.mem _headers name
+ method header ~name =
+ if not (self#hasHeader name) then
+ raise (Header_not_found name);
+ String.concat ", " (List.rev (Hashtbl.find_all _headers name))
+ method headers =
+ List.rev
+ (Hashtbl.fold
+ (fun name _ headers -> (name, self#header ~name)::headers)
+ _headers
+ [])
+
+ method clientSockaddr = clisockaddr
+ method clientAddr = cliaddr
+ method clientPort = cliport
+
+ method serverSockaddr = srvsockaddr
+ method serverAddr = srvaddr
+ method serverPort = srvport
+
+ method private virtual fstLineToString: string
+ method toString =
+ self#fstLineToString ^ (* {request,status} line *)
+ crlf ^
+ (String.concat (* headers, crlf terminated *)
+ ""
+ (List.map (fun (h,v) -> h ^ ": " ^ v ^ crlf) self#headers)) ^
+ (sprintf "Content-Length: %d" (String.length self#body)) ^ crlf ^
+ crlf ^
+ self#body (* body *)
+ method serialize outchan =
+ output_string outchan self#toString;
+ flush outchan
+
+ end
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> 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.
+
+ 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.
+
+ 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
+*)
+
+open Http_types;;
+
+ (** OO representation of an HTTP message
+ @param entity body included in the message
+ @param headers message headers shipped with the message *)
+class virtual message:
+ body: string -> headers: (string * string) list -> version: version ->
+ clisockaddr: Unix.sockaddr -> srvsockaddr: Unix.sockaddr ->
+ object
+
+ method version: version
+ method setVersion: version -> unit
+
+ method body: string
+ method setBody: string -> unit
+ method bodyBuf: Buffer.t
+ method setBodyBuf: Buffer.t -> unit
+ method addBody: string -> unit
+ method addBodyBuf: Buffer.t -> unit
+
+ method addHeader: name:string -> value:string -> unit
+ method addHeaders: (string * string) list -> unit
+ method replaceHeader: name:string -> value:string -> unit
+ method replaceHeaders: (string * string) list -> unit
+ method removeHeader: name:string -> unit
+ method hasHeader: name:string -> bool
+ method header: name:string -> string
+ method headers: (string * string) list
+
+ method clientSockaddr: Unix.sockaddr
+ method clientAddr: string
+ method clientPort: int
+
+ method serverSockaddr: Unix.sockaddr
+ method serverAddr: string
+ method serverPort: int
+
+ method private virtual fstLineToString: string
+ method toString: string
+ method serialize: out_channel -> unit
+
+ end
+
Unix.getpeername (Unix.descr_of_out_channel outchan)
let peername_of_in_channel inchan =
Unix.getpeername (Unix.descr_of_in_channel inchan)
+let sockname_of_out_channel outchan =
+ Unix.getsockname (Unix.descr_of_out_channel outchan)
+let sockname_of_in_channel inchan =
+ Unix.getsockname (Unix.descr_of_in_channel inchan)
+
+let buf_of_inchan ?limit ic =
+ let buf = Buffer.create 10240 in
+ let tmp = String.make 1024 '\000' in
+ let rec buf_of_inchan' limit =
+ (match limit with
+ | None ->
+ let bytes = input ic tmp 0 1024 in
+ if bytes > 0 then begin
+ Buffer.add_substring buf tmp 0 bytes;
+ buf_of_inchan' None
+ end
+ | Some lim -> (* TODO what about using a single really_input call? *)
+ let bytes = input ic tmp 0 (min lim 1024) in
+ if bytes > 0 then begin
+ Buffer.add_substring buf tmp 0 bytes;
+ buf_of_inchan' (Some (lim - bytes))
+ end)
+ in
+ (try buf_of_inchan' limit with End_of_file -> ());
+ buf
+
+let list_assoc_all key pairs =
+ snd (List.split (List.filter (fun (k, v) -> k = key) pairs))
val peername_of_out_channel: out_channel -> Unix.sockaddr
(** as above but works on in_channels *)
val peername_of_in_channel: in_channel -> Unix.sockaddr
+ (** given an out_channel build on top of a socket, return sockname related to
+ that socket *)
+val sockname_of_out_channel: out_channel -> Unix.sockaddr
+ (** as above but works on in_channels *)
+val sockname_of_in_channel: in_channel -> Unix.sockaddr
+
+ (** reads from an input channel till it End_of_file and returns what has been
+ read; if limit is given returned buffer will contains at most first 'limit'
+ bytes read from input channel *)
+val buf_of_inchan: ?limit: int -> in_channel -> Buffer.t
+
+ (** like List.assoc but return all bindings of a given key instead of the
+ leftmost one only *)
+val list_assoc_all: 'a -> ('a * 'b) list -> 'b list
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
-open Neturl;;
open Printf;;
+open Http_common;;
open Http_types;;
open Http_constants;;
-(*
-type url_syntax_option =
- Url_part_not_recognized
- | Url_part_allowed
- | Url_part_required
-
-* (1) scheme://user:password@host:port/path;params?query#fragment
-*)
-
-let request_uri_syntax = {
- url_enable_scheme = Url_part_not_recognized;
- url_enable_user = Url_part_not_recognized;
- url_enable_password = Url_part_not_recognized;
- url_enable_host = Url_part_not_recognized;
- url_enable_port = Url_part_not_recognized;
- url_enable_path = Url_part_required;
- url_enable_param = Url_part_not_recognized;
- url_enable_query = Url_part_allowed;
- url_enable_fragment = Url_part_not_recognized;
- url_enable_other = Url_part_not_recognized;
- url_accepts_8bits = false;
- url_is_valid = (fun _ -> true);
-}
-
- (* convention:
- foo_RE_raw is the uncompiled regexp matching foo
- foo_RE is the compiled regexp matching foo
- is_foo is the predicate over string matching foo
- *)
-
-let separators_RE_raw = "()<>@,;:\\\\\"/\\[\\]?={} \t"
-let ctls_RE_raw = "\\x00-\\x1F\\x7F"
-let token_RE_raw = "[^" ^ separators_RE_raw ^ ctls_RE_raw ^ "]+"
-let lws_RE_raw = "(\r\n)?[ \t]"
-let quoted_string_RE_raw = "\"(([^\"])|(\\\\\"))*\""
-let text_RE_raw = "(([^" ^ ctls_RE_raw ^ "])|(" ^ lws_RE_raw ^ "))+"
-let field_content_RE_raw =
- sprintf
- "^(((%s)|(%s)|(%s))|(%s))*$"
- token_RE_raw
- separators_RE_raw
- quoted_string_RE_raw
- text_RE_raw
-(*
- (* following RFC 2616 specifications *)
-let field_value_RE_raw = "((" ^ field_content_RE_raw ^ ")|(" ^ lws_RE_raw^ "))*"
-*)
- (* smarter implementation: TEXT production is included in the regexp below *)
-let field_value_RE_raw =
- sprintf
- "^((%s)|(%s)|(%s)|(%s))*$"
- token_RE_raw
- separators_RE_raw
- quoted_string_RE_raw
- lws_RE_raw
-
-let token_RE = Pcre.regexp ("^" ^ token_RE_raw ^ "$")
-let field_value_RE = Pcre.regexp ("^" ^ field_value_RE_raw ^ "$")
-
-let is_token s = Pcre.pmatch ~rex:token_RE s
-let is_field_name = is_token
-let is_field_value s = Pcre.pmatch ~rex:field_value_RE s
-
-let heal_header_name s =
- if not (is_field_name s) then raise (Invalid_header_name s) else ()
+let (bindings_sep, binding_sep, pieces_sep, header_sep) =
+ (Pcre.regexp "&", Pcre.regexp "=", Pcre.regexp " ", Pcre.regexp ":")
+let header_RE = Pcre.regexp "([^:]*):(.*)"
-let heal_header_value s =
- if not (is_field_value s) then raise (Invalid_header_value s) else ()
-
-let heal_header (name, value) =
- heal_header_name name;
- heal_header_value name
+let url_decode url = Netencoding.Url.decode ~plus:true url
(** given an HTTP like query string (e.g. "name1=value1&name2=value2&...")
@return a list of pairs [("name1", "value1"); ("name2", "value2")]
@raise Malformed_query if the string isn't a valid query string
@raise Malformed_query_part if some piece of the query isn't valid
*)
-let split_query_params =
- let (bindings_sep, binding_sep) = (Pcre.regexp "&", Pcre.regexp "=") in
- let http_decode url = Netencoding.Url.decode ~plus:false url in
- fun ~query ->
- let bindings = Pcre.split ~rex:bindings_sep query in
- if List.length bindings < 1 then
- raise (Malformed_query query);
- List.map
- (fun binding ->
- match Pcre.split ~rex:binding_sep binding with
- | [""; b] -> (* '=b' *) raise (Malformed_query_part (binding, query))
- | [a; b] -> (* 'a=b' *) (http_decode a, http_decode b)
- | [a] -> (* 'a=' || 'a' *) (http_decode a, "")
- | _ -> raise (Malformed_query_part (binding, query)))
- bindings
+let split_query_params query =
+ let bindings = Pcre.split ~rex:bindings_sep query in
+ match bindings with
+ | [] -> raise (Malformed_query query)
+ | bindings ->
+ List.map
+ (fun binding ->
+ match Pcre.split ~rex:binding_sep binding with
+ | [ ""; b ] -> (* '=b' *)
+ raise (Malformed_query_part (binding, query))
+ | [ a; b ] -> (* 'a=b' *) (url_decode a, url_decode b)
+ | [ a ] -> (* 'a=' || 'a' *) (url_decode a, "")
+ | _ -> raise (Malformed_query_part (binding, query)))
+ bindings
+
+ (** internal, used by generic_input_line *)
+exception Line_completed;;
(** given an input channel and a separator
@return a line read from it (like Pervasives.input_line)
try
while true do
if !sep_pointer >= String.length sep then (* line completed *)
- raise End_of_file
+ raise Line_completed
else begin (* incomplete line: need to read more *)
let ch = input_char ic in
if ch = String.get sep !sep_pointer then (* next piece of sep *)
end
done;
assert false (* unreacheable statement *)
- with End_of_file ->
- if !line = "" then
- raise End_of_file
- else
- !line
-
-let parse_request =
- let patch_empty_path s = (if s = "" then "/" else s) in
- let pieces_sep = Pcre.regexp " " in
- fun ic ->
- let request_line = generic_input_line ~sep:crlf ~ic in
- match Pcre.split ~rex:pieces_sep request_line with
- | [meth; request_uri_raw; http_version] ->
- if meth <> "GET" then
- raise (Unsupported_method meth);
- (match http_version with
- | "HTTP/1.0" | "HTTP/1.1" -> ()
- | _ -> raise (Unsupported_HTTP_version http_version));
- let request_uri =
+ with Line_completed -> !line
+
+let patch_empty_path = function "" -> "/" | s -> s
+let debug_dump_request path params =
+ debug_print
+ (sprintf
+ "recevied request; path: %s; params: %s"
+ path
+ (String.concat ", " (List.map (fun (n, v) -> n ^ "=" ^ v) params)))
+
+let parse_request_fst_line ic =
+ let request_line = generic_input_line ~sep:crlf ~ic in
+ match Pcre.split ~rex:pieces_sep request_line with
+ | [ meth_raw; uri_raw; http_version_raw ] ->
+ (try
+ (method_of_string meth_raw, (* method *)
+ Http_parser_sanity.url_of_string uri_raw, (* uri *)
+ version_of_string http_version_raw) (* version *)
+ with Neturl.Malformed_URL -> raise (Malformed_request_URI uri_raw))
+ | _ -> raise (Malformed_request request_line)
+
+let parse_path uri = patch_empty_path (String.concat "/" (Neturl.url_path uri))
+let parse_query_get_params uri =
+ try (* act on HTTP encoded URIs *)
+ split_query_params (Neturl.url_query ~encoded:true uri)
+ with Not_found -> []
+
+let parse_headers ic =
+ (* consume also trailing "^\r\n$" line *)
+ let rec parse_headers' headers =
+ match generic_input_line ~sep:crlf ~ic with
+ | "" -> List.rev headers
+ | line ->
+ (let subs = Pcre.extract ~rex:header_RE line in
+ let header =
try
- url_of_string request_uri_syntax request_uri_raw
- with Malformed_URL ->
- raise (Malformed_request_URI request_uri_raw)
- in
- let path =
- patch_empty_path (String.concat "/" (url_path request_uri))
+ subs.(1)
+ with Invalid_argument "Array.get" -> raise (Invalid_header line)
in
- let query_params =
- try (* act on HTTP encoded URIs *)
- split_query_params (url_query ~encoded:true request_uri)
- with Not_found -> []
+ let value =
+ try
+ Http_parser_sanity.normalize_header_value subs.(2)
+ with Invalid_argument "Array.get" -> ""
in
- Http_common.debug_print
- (sprintf
- "recevied request; path: %s; params: %s"
- path
- (String.concat
- ", "
- (List.map (fun (n, v) -> n ^ "=" ^ v) query_params)));
- (path, query_params)
- | _ -> raise (Malformed_request request_line)
-
-let parse_request' ic =
- let (path, params) = parse_request ic in
- let clisockaddr = Http_misc.peername_of_in_channel ic in
- new Http_request.request ~path ~params ~clisockaddr
+ Http_parser_sanity.heal_header (header, value);
+ parse_headers' ((header, value) :: headers))
+ in
+ parse_headers' []
+
+let parse_request ic =
+ let (meth, uri, version) = parse_request_fst_line ic in
+ let path = parse_path uri in
+ let query_get_params = parse_query_get_params uri in
+ debug_dump_request path query_get_params;
+ (path, query_get_params)
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
-val heal_header_name: string -> unit
-val heal_header_value: string -> unit
-val heal_header: string * string -> unit
+open Http_types;;
+
+val split_query_params: string -> (string * string) list
+
+val parse_request_fst_line: in_channel -> meth * Neturl.url * version
+val parse_query_get_params: Neturl.url -> (string * string) list
+val parse_path: Neturl.url -> string
+val parse_headers: in_channel -> (string * string) list
(** given an input channel, reads from it a GET HTTP request and
@return a pair <path, query_params> where path is a string representing the
parameters) *)
val parse_request: in_channel -> string * (string * string) list
- (** as above, but return an Http_types.request instance *)
-val parse_request': in_channel -> Http_types.request
-
--- /dev/null
+
+open Neturl;;
+open Printf;;
+
+open Http_types;;
+open Http_constants;;
+
+(*
+type url_syntax_option =
+ Url_part_not_recognized
+ | Url_part_allowed
+ | Url_part_required
+
+* (1) scheme://user:password@host:port/path;params?query#fragment
+*)
+
+let request_uri_syntax = {
+ url_enable_scheme = Url_part_not_recognized;
+ url_enable_user = Url_part_not_recognized;
+ url_enable_password = Url_part_not_recognized;
+ url_enable_host = Url_part_not_recognized;
+ url_enable_port = Url_part_not_recognized;
+ url_enable_path = Url_part_required;
+ url_enable_param = Url_part_not_recognized;
+ url_enable_query = Url_part_allowed;
+ url_enable_fragment = Url_part_not_recognized;
+ url_enable_other = Url_part_not_recognized;
+ url_accepts_8bits = false;
+ url_is_valid = (fun _ -> true);
+}
+
+ (* convention:
+ foo_RE_raw is the uncompiled regexp matching foo
+ foo_RE is the compiled regexp matching foo
+ is_foo is the predicate over string matching foo
+ *)
+
+let separators_RE_raw = "()<>@,;:\\\\\"/\\[\\]?={} \t"
+let ctls_RE_raw = "\\x00-\\x1F\\x7F"
+let token_RE_raw = "[^" ^ separators_RE_raw ^ ctls_RE_raw ^ "]+"
+let lws_RE_raw = "(\r\n)?[ \t]"
+let quoted_string_RE_raw = "\"(([^\"])|(\\\\\"))*\""
+let text_RE_raw = "(([^" ^ ctls_RE_raw ^ "])|(" ^ lws_RE_raw ^ "))+"
+let field_content_RE_raw =
+ sprintf
+ "^(((%s)|(%s)|(%s))|(%s))*$"
+ token_RE_raw
+ separators_RE_raw
+ quoted_string_RE_raw
+ text_RE_raw
+(*
+ (* following RFC 2616 specifications *)
+let field_value_RE_raw = "((" ^ field_content_RE_raw ^ ")|(" ^ lws_RE_raw^ "))*"
+*)
+ (* smarter implementation: TEXT production is included in the regexp below *)
+let field_value_RE_raw =
+ sprintf
+ "^((%s)|(%s)|(%s)|(%s))*$"
+ token_RE_raw
+ separators_RE_raw
+ quoted_string_RE_raw
+ lws_RE_raw
+
+let token_RE = Pcre.regexp ("^" ^ token_RE_raw ^ "$")
+let field_value_RE = Pcre.regexp ("^" ^ field_value_RE_raw ^ "$")
+let heading_lws_RE = Pcre.regexp (sprintf "^%s*" lws_RE_raw)
+let trailing_lws_RE = Pcre.regexp (sprintf "%s*$" lws_RE_raw)
+
+let is_token s = Pcre.pmatch ~rex:token_RE s
+let is_field_name = is_token
+let is_field_value s = Pcre.pmatch ~rex:field_value_RE s
+
+let heal_header_name s =
+ if not (is_field_name s) then raise (Invalid_header_name s) else ()
+
+let heal_header_value s =
+ if not (is_field_value s) then raise (Invalid_header_value s) else ()
+
+let normalize_header_value s =
+ Pcre.replace ~rex:trailing_lws_RE
+ (Pcre.replace ~rex:heading_lws_RE s)
+
+let heal_header (name, value) =
+ heal_header_name name;
+ heal_header_value name
+
+let url_of_string = url_of_string request_uri_syntax
+let string_of_url = Neturl.string_of_url
+
--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> 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.
+
+ 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.
+
+ 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
+*)
+
+val heal_header_name: string -> unit
+val heal_header_value: string -> unit
+val heal_header: string * string -> unit
+
+ (** remove heading and/or trailing LWS sequences as per RFC2616 *)
+val normalize_header_value: string -> string
+
+val url_of_string: string -> Neturl.url
+val string_of_url: Neturl.url -> string
+
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
+open Printf;;
+
open Http_common;;
open Http_types;;
-class request ~path ~params ~clisockaddr =
- let (addr, port) = Http_misc.explode_sockaddr clisockaddr in
+let debug_dump_request path params =
+ debug_print ("request path = " ^ path);
+ debug_print (
+ sprintf"request params = %s"
+ (String.concat ";"
+ (List.map (fun (h,v) -> String.concat "=" [h;v]) params)))
+
+exception Fallback;; (* used internally by request class *)
+
+class request ic =
+ let (meth, uri, version) = Http_parser.parse_request_fst_line ic in
+ let uri_str = Neturl.string_of_url uri in
+ let path = Http_parser.parse_path uri in
+ let query_get_params = Http_parser.parse_query_get_params uri in
+ let headers = Http_parser.parse_headers ic in (* trailing \r\n consumed! *)
+ let body =
+ (* TODO fallback on Transfer-Encoding if Content-Length isn't defined *)
+ if meth = `POST then
+ Buffer.contents
+ (try (* read only Content-Length bytes *)
+ let limit_raw =
+ (try
+ (snd (List.find
+ (fun (h,v) -> String.lowercase h = "content-length") headers))
+ with Not_found -> raise Fallback)
+ in
+ let limit =
+ (try (* TODO supports only a maximum content-length of 1Gb *)
+ int_of_string limit_raw
+ with Failure "int_of_string" ->
+ raise (Invalid_header ("Content-Length: " ^ limit_raw)))
+ in
+ Http_misc.buf_of_inchan ~limit ic
+ with Fallback -> Http_misc.buf_of_inchan ic) (* read until EOF *)
+ else "" (* TODO empty body for methods other than POST, is what we want? *)
+ in
+ (* TODO brave assumption: when meth = `POST, Content-Type is
+ application/x-www-form-urlencoded and is therefore one-liner parsed as a GET
+ query *)
+ let query_post_params =
+ match meth with
+ | `POST -> Http_parser.split_query_params body
+ | _ -> []
+ in
+ let params = query_post_params @ query_get_params in (* prefers POST params *)
+ let _ = debug_dump_request path params in
+ let (clisockaddr, srvsockaddr) =
+ (Http_misc.peername_of_in_channel ic, Http_misc.sockname_of_in_channel ic)
+ in
+
+ object (self)
+
+ inherit
+ Http_message.message ~body ~headers ~version ~clisockaddr ~srvsockaddr
+
+ val params_tbl =
+ let tbl = Hashtbl.create (List.length params) in
+ List.iter (fun (n,v) -> Hashtbl.add tbl n v) params;
+ tbl
+
+ method meth = meth
+ method uri = uri_str
+ method path = path
+ method param ?meth name =
+ (match (meth: meth option) with
+ | None ->
+ (try
+ Hashtbl.find params_tbl name
+ with Not_found -> raise (Param_not_found name))
+ | Some `GET -> List.assoc name query_get_params
+ | Some `POST -> List.assoc name query_post_params)
+ method paramAll ?meth name =
+ (match (meth: meth option) with
+ | None -> List.rev (Hashtbl.find_all params_tbl name)
+ | Some `GET -> Http_misc.list_assoc_all name query_get_params
+ | Some `POST -> Http_misc.list_assoc_all name query_post_params)
+ method params = params
+ method params_GET = query_get_params
+ method params_POST = query_post_params
+
+ method private fstLineToString =
+ sprintf "%s %s %s"
+ (string_of_method self#meth) self#uri (string_of_version self#version)
+
+ end
+
+(* (* OLD IMPLEMENTATION *)
+class request
+ ~body ~headers ~version ~meth ~uri
+ ~clisockaddr ~srvsockaddr
+ ~path ~params
+ ()
+ =
object (self)
+
+ inherit
+ Http_message.message ~body ~headers ~version ~clisockaddr ~srvsockaddr
+
val params_tbl =
let tbl = Hashtbl.create (List.length params) in
List.iter (fun (n,v) -> Hashtbl.add tbl n v) params;
tbl
- val uri =
- path ^ "?" ^
- (String.concat "&" (List.map (fun (n, v) -> n ^ "=" ^ v) params))
+
+ method meth = meth
method uri = uri
method path = path
method param name =
raise (Param_not_found name)
method paramAll name = List.rev (Hashtbl.find_all params_tbl name)
method params = params
- method clientSockaddr = clisockaddr
- method clientAddr = addr
- method clientPort = port
+
+ method private fstLineToString =
+ sprintf
+ "%s %s %s"
+ (string_of_method self#meth)
+ self#uri
+ (string_of_version self#version)
+
end
+*)
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
+open Http_types;;
+
(** OO representation of an HTTP request
- @param path path requested by client
- @param params list of <name, value> bindings enclosed in request
- @param clisockaddr client's Unix.sockaddr *)
-class request:
- path: string -> params: (string * string) list ->
- clisockaddr: Unix.sockaddr ->
- Http_types.request
+ @param inchan input channel from which parse an HTTP request *)
+class request: in_channel -> Http_types.request
let status_line_RE = Pcre.regexp "^(HTTP/\\d\\.\\d) (\\d{3}) (.*)$"
+let anyize = function
+ | Some addr -> addr
+ | None -> Unix.ADDR_INET (Unix.inet_addr_any, -1)
+
class response
(* Warning: keep default values in sync with Http_daemon.respond function *)
- ?(body = "") ?(headers = [])
- ?(version = http_version) ?(code = 200) ?status ()
+ ?(body = "") ?(headers = []) ?(version = http_version)
+ ?clisockaddr ?srvsockaddr (* optional because response have to be easily
+ buildable in callback functions *)
+ ?(code = 200) ?status
+ ()
=
- (* remove all bindings of 'name' from hashtbl 'tbl' *)
- let rec hashtbl_remove_all tbl name =
- if not (Hashtbl.mem tbl name) then
- raise (Header_not_found name);
- Hashtbl.remove tbl name;
- if Hashtbl.mem tbl name then hashtbl_remove_all tbl name
- in
+
+ (** if no address were supplied for client and/or server, use a foo address
+ instead *)
+ let (clisockaddr, srvsockaddr) = (anyize clisockaddr, anyize srvsockaddr) in
+
(* "version code reason_phrase" *)
object (self)
- val mutable _version = version
+ inherit
+ Http_message.message ~body ~headers ~version ~clisockaddr ~srvsockaddr
+
val mutable _code =
match status with
| None -> code
| Some (s: Http_types.status) -> code_of_status s
val mutable _reason: string option = None
- val _contentsBuf = Buffer.create 1024
- val _headers = Hashtbl.create 11
-
- initializer
- self#setContents body;
- self#addHeaders headers
-
- method version = _version
- method setVersion v = _version <- v
method code = _code
method setCode c =
method isServerError = is_server_error _code
method isError = is_error _code
- method contents = Buffer.contents _contentsBuf
- method setContents c =
- Buffer.clear _contentsBuf;
- Buffer.add_string _contentsBuf c
- method contentsBuf = _contentsBuf
- method setContentsBuf b =
- Buffer.clear _contentsBuf;
- Buffer.add_buffer _contentsBuf b
- method addContents s = Buffer.add_string _contentsBuf s
- method addContentsBuf b = Buffer.add_buffer _contentsBuf b
-
- method addHeader ~name ~value =
- Http_parser.heal_header (name, value);
- Hashtbl.add _headers name value
- method addHeaders =
- List.iter (fun (name, value) -> self#addHeader ~name ~value)
-
- method replaceHeader ~name ~value =
- Http_parser.heal_header (name, value);
- Hashtbl.replace _headers name value
- method replaceHeaders =
- List.iter (fun (name, value) -> self#replaceHeader ~name ~value)
-
(* FIXME duplication of code between this and send_basic_headers *)
method addBasicHeaders =
self#addHeader ~name:"Date" ~value:(Http_misc.date_822 ());
self#addHeader ~name:"Server" ~value:server_string
- method removeHeader ~name = hashtbl_remove_all _headers name
- method hasHeader ~name = Hashtbl.mem _headers name
- method header ~name =
- if not (self#hasHeader name) then
- raise (Header_not_found name);
- String.concat ", " (List.rev (Hashtbl.find_all _headers name))
- method headers =
- List.rev
- (Hashtbl.fold
- (fun name _ headers -> (name, self#header ~name)::headers)
- _headers
- [])
method contentType = self#header "Content-Type"
method setContentType t = self#replaceHeader "Content-Type" t
method server = self#header "Server"
method setServer s = self#replaceHeader "Server" s
- method toString =
+ method private fstLineToString =
sprintf
- "%s%s%s%s%s"
- self#statusLine (* status line *)
- crlf
- (String.concat (* headers, crlf terminated *)
- ""
- (List.map (fun (h,v) -> h ^ ": " ^ v ^ crlf) self#headers))
- crlf
- (Buffer.contents _contentsBuf) (* body *)
- method serialize outchan =
- output_string outchan self#toString;
- flush outchan
+ "%s %d %s"
+ (string_of_version self#version)
+ self#code
+ self#reason
end
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
+open Http_types;;
+
class response:
- ?body:string -> ?headers:(string * string) list ->
- ?version:Http_types.version -> ?code:int -> ?status:Http_types.status ->
+ ?body:string -> ?headers:(string * string) list -> ?version: version ->
+ ?clisockaddr: Unix.sockaddr -> ?srvsockaddr: Unix.sockaddr ->
+ ?code:int -> ?status:Http_types.status ->
unit ->
Http_types.response
| `HTTP_1_1
]
-type meth = [ `GET ]
+type meth =
+ [ `GET
+ | `POST
+ ]
type daemon_mode = [ `Single | `Fork | `Thread ]
exception Invalid_header_name of string
exception Invalid_header_value of string
exception Invalid_HTTP_version of string
+exception Invalid_HTTP_method of string
exception Invalid_code of int
exception Invalid_status of status
exception Invalid_status_line of string
exception Header_not_found of string
-class type response =
- object
+class type message = object
+
method version: version
method setVersion: version -> unit
+
+ method body: string
+ method setBody: string -> unit
+ method bodyBuf: Buffer.t
+ method setBodyBuf: Buffer.t -> unit
+ method addBody: string -> unit
+ method addBodyBuf: Buffer.t -> unit
+
+ method addHeader: name:string -> value:string -> unit
+ method addHeaders: (string * string) list -> unit
+ method replaceHeader: name:string -> value:string -> unit
+ method replaceHeaders: (string * string) list -> unit
+ method removeHeader: name:string -> unit
+ method hasHeader: name:string -> bool
+ method header: name:string -> string
+ method headers: (string * string) list
+
+ method clientSockaddr: Unix.sockaddr
+ method clientAddr: string
+ method clientPort: int
+
+ method serverSockaddr: Unix.sockaddr
+ method serverAddr: string
+ method serverPort: int
+
+ method toString: string
+ method serialize: out_channel -> unit
+
+ end
+
+class type request = object
+
+ inherit message
+
+ method meth: meth
+ method uri: string
+ method path: string
+ method param: ?meth:meth -> string -> string
+ method paramAll: ?meth:meth -> string -> string list
+ method params: (string * string) list
+ method params_GET: (string * string) list
+ method params_POST: (string * string) list
+
+ end
+
+class type response = object
+
+ inherit message
+
method code: int
method setCode: int -> unit
method status: status
method setReason: string -> unit
method statusLine: string
method setStatusLine: string -> unit
+
method isInformational: bool
method isSuccess: bool
method isRedirection: bool
method isClientError: bool
method isServerError: bool
method isError: bool
- method contents: string
- method setContents: string -> unit
- method contentsBuf: Buffer.t
- method setContentsBuf: Buffer.t -> unit
- method addContents: string -> unit
- method addContentsBuf: Buffer.t -> unit
- method addHeader: name:string -> value:string -> unit
- method addHeaders: (string * string) list -> unit
+
method addBasicHeaders: unit
- method replaceHeader: name:string -> value:string -> unit
- method replaceHeaders: (string * string) list -> unit
- method removeHeader: name:string -> unit
- method hasHeader: name:string -> bool
- method header: name:string -> string
- method headers: (string * string) list
method contentType: string
method setContentType: string -> unit
method contentEncoding: string
method setExpires: string -> unit
method server: string
method setServer: string -> unit
- method toString: string
- method serialize: out_channel -> unit
- end
-class type request =
- object
- method uri: string
- method path: string
- method param: string -> string
- method paramAll: string -> string list
- method params: (string * string) list
- method clientSockaddr: Unix.sockaddr
- method clientAddr: string
- method clientPort: int
+
end
+
class type connection =
object
method getRequest: request option
method respond_with: response -> unit
method close: unit
end
+
class type daemon =
object
method accept: connection
projects / helm.git / commitdiff