From ca9cd0aeee0ce78a891f7f6091ca8704231a446d Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Wed, 25 Dec 2002 15:26:32 +0000 Subject: [PATCH] - merged "post" branch --- helm/DEVEL/ocaml-http/.depend | 57 ++--- helm/DEVEL/ocaml-http/Makefile | 6 +- helm/DEVEL/ocaml-http/Makefile.overrides | 2 + helm/DEVEL/ocaml-http/TODO | 7 - helm/DEVEL/ocaml-http/debian/changelog | 2 +- .../ocaml-http/examples/damned_recursion.ml | 3 +- helm/DEVEL/ocaml-http/examples/dump_args.ml | 42 ++-- helm/DEVEL/ocaml-http/examples/obj_foo.ml | 4 +- helm/DEVEL/ocaml-http/http_common.ml | 9 + helm/DEVEL/ocaml-http/http_common.mli | 15 +- helm/DEVEL/ocaml-http/http_daemon.ml | 32 +-- helm/DEVEL/ocaml-http/http_daemon.mli | 8 +- helm/DEVEL/ocaml-http/http_message.ml | 112 ++++++++++ helm/DEVEL/ocaml-http/http_message.mli | 64 ++++++ helm/DEVEL/ocaml-http/http_misc.ml | 28 +++ helm/DEVEL/ocaml-http/http_misc.mli | 14 ++ helm/DEVEL/ocaml-http/http_parser.ml | 206 +++++++----------- helm/DEVEL/ocaml-http/http_parser.mli | 14 +- helm/DEVEL/ocaml-http/http_parser_sanity.ml | 89 ++++++++ helm/DEVEL/ocaml-http/http_parser_sanity.mli | 31 +++ helm/DEVEL/ocaml-http/http_request.ml | 118 +++++++++- helm/DEVEL/ocaml-http/http_request.mli | 11 +- helm/DEVEL/ocaml-http/http_response.ml | 88 ++------ helm/DEVEL/ocaml-http/http_response.mli | 7 +- helm/DEVEL/ocaml-http/http_types.ml | 91 +++++--- 25 files changed, 726 insertions(+), 334 deletions(-) create mode 100644 helm/DEVEL/ocaml-http/Makefile.overrides create mode 100644 helm/DEVEL/ocaml-http/http_message.ml create mode 100644 helm/DEVEL/ocaml-http/http_message.mli create mode 100644 helm/DEVEL/ocaml-http/http_parser_sanity.ml create mode 100644 helm/DEVEL/ocaml-http/http_parser_sanity.mli diff --git a/helm/DEVEL/ocaml-http/.depend b/helm/DEVEL/ocaml-http/.depend index f80cca7be..c175b1912 100644 --- a/helm/DEVEL/ocaml-http/.depend +++ b/helm/DEVEL/ocaml-http/.depend @@ -1,35 +1,42 @@ -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 diff --git a/helm/DEVEL/ocaml-http/Makefile b/helm/DEVEL/ocaml-http/Makefile index 48c267589..5a63b4322 100644 --- a/helm/DEVEL/ocaml-http/Makefile +++ b/helm/DEVEL/ocaml-http/Makefile @@ -1,8 +1,9 @@ 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)) @@ -35,6 +36,7 @@ depend: $(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/ diff --git a/helm/DEVEL/ocaml-http/Makefile.overrides b/helm/DEVEL/ocaml-http/Makefile.overrides new file mode 100644 index 000000000..62a81b549 --- /dev/null +++ b/helm/DEVEL/ocaml-http/Makefile.overrides @@ -0,0 +1,2 @@ +http_types.cmi http_types.cmo: http_types.ml + $(OCAMLC) -c $< diff --git a/helm/DEVEL/ocaml-http/TODO b/helm/DEVEL/ocaml-http/TODO index ded75c3f5..e69de29bb 100644 --- a/helm/DEVEL/ocaml-http/TODO +++ b/helm/DEVEL/ocaml-http/TODO @@ -1,7 +0,0 @@ - -- 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 - diff --git a/helm/DEVEL/ocaml-http/debian/changelog b/helm/DEVEL/ocaml-http/debian/changelog index a95d0e9f9..408fd360a 100644 --- a/helm/DEVEL/ocaml-http/debian/changelog +++ b/helm/DEVEL/ocaml-http/debian/changelog @@ -5,7 +5,7 @@ ocaml-http (0.0.7) unstable; urgency=low * Use Pcre to perform sanity test on headers instead of home made parsing - -- Stefano Zacchiroli Wed, 4 Dec 2002 09:43:31 +0100 + -- Stefano Zacchiroli Wed, 25 Dec 2002 16:22:31 +0100 ocaml-http (0.0.6) unstable; urgency=low diff --git a/helm/DEVEL/ocaml-http/examples/damned_recursion.ml b/helm/DEVEL/ocaml-http/examples/damned_recursion.ml index 32faa0137..0280b3f1c 100644 --- a/helm/DEVEL/ocaml-http/examples/damned_recursion.ml +++ b/helm/DEVEL/ocaml-http/examples/damned_recursion.ml @@ -19,6 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) +open Http_types;; open Printf;; (* @@ -44,7 +45,7 @@ let wget addr port path = 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 diff --git a/helm/DEVEL/ocaml-http/examples/dump_args.ml b/helm/DEVEL/ocaml-http/examples/dump_args.ml index ef4630fde..3287ea710 100644 --- a/helm/DEVEL/ocaml-http/examples/dump_args.ml +++ b/helm/DEVEL/ocaml-http/examples/dump_args.ml @@ -21,31 +21,25 @@ 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 diff --git a/helm/DEVEL/ocaml-http/examples/obj_foo.ml b/helm/DEVEL/ocaml-http/examples/obj_foo.ml index c36ea3ec3..278621853 100644 --- a/helm/DEVEL/ocaml-http/examples/obj_foo.ml +++ b/helm/DEVEL/ocaml-http/examples/obj_foo.ml @@ -19,7 +19,9 @@ 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 diff --git a/helm/DEVEL/ocaml-http/http_common.ml b/helm/DEVEL/ocaml-http/http_common.ml index ed595590d..23beaf9ae 100644 --- a/helm/DEVEL/ocaml-http/http_common.ml +++ b/helm/DEVEL/ocaml-http/http_common.ml @@ -39,6 +39,15 @@ let version_of_string = function | "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 diff --git a/helm/DEVEL/ocaml-http/http_common.mli b/helm/DEVEL/ocaml-http/http_common.mli index af76440cf..aceeb2842 100644 --- a/helm/DEVEL/ocaml-http/http_common.mli +++ b/helm/DEVEL/ocaml-http/http_common.mli @@ -21,20 +21,25 @@ (** 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 diff --git a/helm/DEVEL/ocaml-http/http_daemon.ml b/helm/DEVEL/ocaml-http/http_daemon.ml index 732a5b31d..a56780a9f 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.ml +++ b/helm/DEVEL/ocaml-http/http_daemon.ml @@ -46,7 +46,7 @@ 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 = @@ -108,7 +108,6 @@ let foo_body code body = 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 = []) @@ -121,6 +120,7 @@ let respond 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 @@ -338,12 +338,17 @@ let rec wrap_parse_request_w_safety parse_function inchan 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 @@ -359,24 +364,23 @@ 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 diff --git a/helm/DEVEL/ocaml-http/http_daemon.mli b/helm/DEVEL/ocaml-http/http_daemon.mli index c9c8deb53..7a3ce42d0 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.mli +++ b/helm/DEVEL/ocaml-http/http_daemon.mli @@ -48,10 +48,10 @@ val send_headers: headers:(string * string) list -> out_channel -> unit (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 -> diff --git a/helm/DEVEL/ocaml-http/http_message.ml b/helm/DEVEL/ocaml-http/http_message.ml new file mode 100644 index 000000000..24621e05d --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_message.ml @@ -0,0 +1,112 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> 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. + + 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 + diff --git a/helm/DEVEL/ocaml-http/http_message.mli b/helm/DEVEL/ocaml-http/http_message.mli new file mode 100644 index 000000000..e3f06f03f --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_message.mli @@ -0,0 +1,64 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> 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. + + 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 + diff --git a/helm/DEVEL/ocaml-http/http_misc.ml b/helm/DEVEL/ocaml-http/http_misc.ml index 0e11e1048..191508c49 100644 --- a/helm/DEVEL/ocaml-http/http_misc.ml +++ b/helm/DEVEL/ocaml-http/http_misc.ml @@ -108,4 +108,32 @@ let peername_of_out_channel outchan = 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)) diff --git a/helm/DEVEL/ocaml-http/http_misc.mli b/helm/DEVEL/ocaml-http/http_misc.mli index 6e5fdfcf6..862934040 100644 --- a/helm/DEVEL/ocaml-http/http_misc.mli +++ b/helm/DEVEL/ocaml-http/http_misc.mli @@ -62,4 +62,18 @@ val explode_sockaddr: Unix.sockaddr -> string * int 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 diff --git a/helm/DEVEL/ocaml-http/http_parser.ml b/helm/DEVEL/ocaml-http/http_parser.ml index 7f7b22349..1113b701e 100644 --- a/helm/DEVEL/ocaml-http/http_parser.ml +++ b/helm/DEVEL/ocaml-http/http_parser.ml @@ -19,105 +19,40 @@ 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) @@ -135,7 +70,7 @@ let generic_input_line ~sep ~ic = 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 *) @@ -150,50 +85,59 @@ let generic_input_line ~sep ~ic = 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) diff --git a/helm/DEVEL/ocaml-http/http_parser.mli b/helm/DEVEL/ocaml-http/http_parser.mli index 4e70c35e4..cd42c79e5 100644 --- a/helm/DEVEL/ocaml-http/http_parser.mli +++ b/helm/DEVEL/ocaml-http/http_parser.mli @@ -19,9 +19,14 @@ 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 where path is a string representing the @@ -29,6 +34,3 @@ val heal_header: string * string -> unit 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 - diff --git a/helm/DEVEL/ocaml-http/http_parser_sanity.ml b/helm/DEVEL/ocaml-http/http_parser_sanity.ml new file mode 100644 index 000000000..19204e870 --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_parser_sanity.ml @@ -0,0 +1,89 @@ + +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 + diff --git a/helm/DEVEL/ocaml-http/http_parser_sanity.mli b/helm/DEVEL/ocaml-http/http_parser_sanity.mli new file mode 100644 index 000000000..3076a42a6 --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_parser_sanity.mli @@ -0,0 +1,31 @@ + +(* + OCaml HTTP - do it yourself (fully OCaml) HTTP daemon + + Copyright (C) <2002> 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. + + 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 + diff --git a/helm/DEVEL/ocaml-http/http_request.ml b/helm/DEVEL/ocaml-http/http_request.ml index c135c95b3..e3bc95bc1 100644 --- a/helm/DEVEL/ocaml-http/http_request.ml +++ b/helm/DEVEL/ocaml-http/http_request.ml @@ -19,19 +19,115 @@ 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 = @@ -41,8 +137,14 @@ class request ~path ~params ~clisockaddr = 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 +*) diff --git a/helm/DEVEL/ocaml-http/http_request.mli b/helm/DEVEL/ocaml-http/http_request.mli index 8cc223444..ee3494fee 100644 --- a/helm/DEVEL/ocaml-http/http_request.mli +++ b/helm/DEVEL/ocaml-http/http_request.mli @@ -19,12 +19,9 @@ 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 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 diff --git a/helm/DEVEL/ocaml-http/http_response.ml b/helm/DEVEL/ocaml-http/http_response.ml index a0bda3582..913c22755 100644 --- a/helm/DEVEL/ocaml-http/http_response.ml +++ b/helm/DEVEL/ocaml-http/http_response.ml @@ -27,36 +27,34 @@ open Printf;; 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 = @@ -89,45 +87,10 @@ class response 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 @@ -140,19 +103,12 @@ class response 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 diff --git a/helm/DEVEL/ocaml-http/http_response.mli b/helm/DEVEL/ocaml-http/http_response.mli index 08c5d9db5..78ef0fa42 100644 --- a/helm/DEVEL/ocaml-http/http_response.mli +++ b/helm/DEVEL/ocaml-http/http_response.mli @@ -19,9 +19,12 @@ 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 diff --git a/helm/DEVEL/ocaml-http/http_types.ml b/helm/DEVEL/ocaml-http/http_types.ml index fa09a3d5c..276d2e3aa 100644 --- a/helm/DEVEL/ocaml-http/http_types.ml +++ b/helm/DEVEL/ocaml-http/http_types.ml @@ -24,7 +24,10 @@ type version = | `HTTP_1_1 ] -type meth = [ `GET ] +type meth = + [ `GET + | `POST + ] type daemon_mode = [ `Single | `Fork | `Thread ] @@ -111,6 +114,7 @@ exception Invalid_header of string 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 @@ -126,10 +130,59 @@ exception Param_not_found of string 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 @@ -138,27 +191,15 @@ class type response = 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 @@ -169,26 +210,16 @@ class type response = 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 -- 2.39.2