From 697d0d8857366485238a67386d0ce8f18404ac42 Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Sun, 17 Nov 2002 15:48:37 +0000 Subject: [PATCH] - split http_parser module (all code that parse http requests and responses) - split tcp_server module (which contains different [actually 2] implementation of Unix.establish_server like functions) - implemented a tcp_server which doesn't fork - added ~fork parameter to Http_daemon.start* functions --- helm/DEVEL/ocaml-http/.cvsignore | 1 + helm/DEVEL/ocaml-http/.depend | 20 +- helm/DEVEL/ocaml-http/.ocamlinit | 1 + helm/DEVEL/ocaml-http/Makefile | 2 +- helm/DEVEL/ocaml-http/examples/Makefile | 2 +- .../ocaml-http/examples/always_ok_daemon.ml | 2 +- helm/DEVEL/ocaml-http/examples/dont_fork.ml | 28 +++ helm/DEVEL/ocaml-http/examples/dump_args.ml | 2 +- helm/DEVEL/ocaml-http/examples/obj_foo.ml | 2 +- helm/DEVEL/ocaml-http/examples/timeout.ml | 3 +- helm/DEVEL/ocaml-http/http_common.ml | 2 + helm/DEVEL/ocaml-http/http_common.mli | 2 + helm/DEVEL/ocaml-http/http_daemon.ml | 178 +++--------------- helm/DEVEL/ocaml-http/http_daemon.mli | 13 +- helm/DEVEL/ocaml-http/http_parser.ml | 150 +++++++++++++++ helm/DEVEL/ocaml-http/http_parser.mli | 29 +++ helm/DEVEL/ocaml-http/http_response.ml | 19 +- helm/DEVEL/ocaml-http/http_types.ml | 1 + helm/DEVEL/ocaml-http/tcp_server.ml | 51 +++++ helm/DEVEL/ocaml-http/tcp_server.mli | 8 + 20 files changed, 328 insertions(+), 188 deletions(-) create mode 100644 helm/DEVEL/ocaml-http/.ocamlinit create mode 100644 helm/DEVEL/ocaml-http/examples/dont_fork.ml create mode 100644 helm/DEVEL/ocaml-http/http_parser.ml create mode 100644 helm/DEVEL/ocaml-http/http_parser.mli create mode 100644 helm/DEVEL/ocaml-http/tcp_server.ml create mode 100644 helm/DEVEL/ocaml-http/tcp_server.mli diff --git a/helm/DEVEL/ocaml-http/.cvsignore b/helm/DEVEL/ocaml-http/.cvsignore index fd405f9e4..c0404dd2a 100644 --- a/helm/DEVEL/ocaml-http/.cvsignore +++ b/helm/DEVEL/ocaml-http/.cvsignore @@ -2,3 +2,4 @@ *.cmo *.cmx *.cma +*.cmxa diff --git a/helm/DEVEL/ocaml-http/.depend b/helm/DEVEL/ocaml-http/.depend index a23e19f1d..92b97aa58 100644 --- a/helm/DEVEL/ocaml-http/.depend +++ b/helm/DEVEL/ocaml-http/.depend @@ -1,19 +1,23 @@ http_common.cmo: http_types.cmi http_common.cmi http_common.cmx: http_types.cmx http_common.cmi -http_daemon.cmo: http_common.cmi http_misc.cmi http_request.cmi \ - http_types.cmi http_daemon.cmi -http_daemon.cmx: http_common.cmx http_misc.cmx http_request.cmx \ - http_types.cmx http_daemon.cmi +http_daemon.cmo: http_common.cmi http_misc.cmi http_parser.cmi \ + http_request.cmi http_types.cmi tcp_server.cmo http_daemon.cmi +http_daemon.cmx: http_common.cmx http_misc.cmx http_parser.cmx \ + http_request.cmx http_types.cmx tcp_server.cmx http_daemon.cmi http_misc.cmo: http_misc.cmi http_misc.cmx: http_misc.cmi +http_parser.cmo: http_common.cmi http_parser.cmi +http_parser.cmx: http_common.cmx http_parser.cmi http_request.cmo: http_common.cmi http_request.cmi http_request.cmx: http_common.cmx http_request.cmi -http_response.cmo: http_common.cmi http_daemon.cmi http_types.cmi \ - http_response.cmi -http_response.cmx: http_common.cmx http_daemon.cmx http_types.cmx \ - http_response.cmi +http_response.cmo: http_common.cmi http_daemon.cmi http_misc.cmi \ + http_types.cmi http_response.cmi +http_response.cmx: http_common.cmx http_daemon.cmx http_misc.cmx \ + http_types.cmx http_response.cmi http_types.cmo: http_types.cmi http_types.cmx: http_types.cmi +tcp_server.cmo: http_parser.cmi +tcp_server.cmx: http_parser.cmx http_common.cmi: http_types.cmi http_daemon.cmi: http_types.cmi http_request.cmi: http_types.cmi diff --git a/helm/DEVEL/ocaml-http/.ocamlinit b/helm/DEVEL/ocaml-http/.ocamlinit new file mode 100644 index 000000000..577740dbd --- /dev/null +++ b/helm/DEVEL/ocaml-http/.ocamlinit @@ -0,0 +1 @@ +#use "tophttp";; diff --git a/helm/DEVEL/ocaml-http/Makefile b/helm/DEVEL/ocaml-http/Makefile index 4f4def3fe..31f63cf97 100644 --- a/helm/DEVEL/ocaml-http/Makefile +++ b/helm/DEVEL/ocaml-http/Makefile @@ -1,6 +1,6 @@ include Makefile.defs -MODULES = http_common http_misc http_types http_request http_daemon http_response +MODULES = http_common http_misc http_types http_request http_parser tcp_server http_daemon http_response PUBLIC_MODULES = http_common http_types http_request http_daemon http_response DESTDIR = $(shell $(OCAMLFIND) printconf stdlib) diff --git a/helm/DEVEL/ocaml-http/examples/Makefile b/helm/DEVEL/ocaml-http/examples/Makefile index 794b64ef4..e4025264b 100644 --- a/helm/DEVEL/ocaml-http/examples/Makefile +++ b/helm/DEVEL/ocaml-http/examples/Makefile @@ -3,7 +3,7 @@ OBJS = ../http.cma OBJS_OPT = ../http.cmxa EXAMPLES_OPTS = -I .. -linkpkg -EXAMPLES = always_ok_daemon webfsd obj_foo dump_args timeout +EXAMPLES = always_ok_daemon webfsd obj_foo dump_args timeout dont_fork all: $(EXAMPLES) opt: $(patsubst %,%.opt,$(EXAMPLES)) diff --git a/helm/DEVEL/ocaml-http/examples/always_ok_daemon.ml b/helm/DEVEL/ocaml-http/examples/always_ok_daemon.ml index aafe347e7..48b5fd4bb 100644 --- a/helm/DEVEL/ocaml-http/examples/always_ok_daemon.ml +++ b/helm/DEVEL/ocaml-http/examples/always_ok_daemon.ml @@ -23,4 +23,4 @@ open Http_daemon;; open Http_response;; (* start an http daemon that alway respond with a 200 status code and an empty content *) -start (fun _ _ -> respond_with (new Http_response.response)) +start ~port:9999 (fun _ _ -> respond_with (new Http_response.response)) diff --git a/helm/DEVEL/ocaml-http/examples/dont_fork.ml b/helm/DEVEL/ocaml-http/examples/dont_fork.ml new file mode 100644 index 000000000..8d8eb45cc --- /dev/null +++ b/helm/DEVEL/ocaml-http/examples/dont_fork.ml @@ -0,0 +1,28 @@ + +(* + 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 +*) + +let callback req outchan = + output_string outchan "FOO\n"; + flush outchan; + Unix.sleep 5; + Http_daemon.respond_error ~body:"AH AH AH :-P" outchan +in +Http_daemon.start' ~port:9999 ~fork:false callback diff --git a/helm/DEVEL/ocaml-http/examples/dump_args.ml b/helm/DEVEL/ocaml-http/examples/dump_args.ml index 6f3f60bbb..c1f445f12 100644 --- a/helm/DEVEL/ocaml-http/examples/dump_args.ml +++ b/helm/DEVEL/ocaml-http/examples/dump_args.ml @@ -45,5 +45,5 @@ let callback path args outchan = in print_endline "Starting custom Http_daemon ..."; flush stdout; -Http_daemon.start ~addr:"127.0.0.1" ~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 d28c7e4ac..c36ea3ec3 100644 --- a/helm/DEVEL/ocaml-http/examples/obj_foo.ml +++ b/helm/DEVEL/ocaml-http/examples/obj_foo.ml @@ -22,4 +22,4 @@ let callback req outchan = Http_daemon.respond_error ~body:(req#param "foo") outchan in -Http_daemon.start' ~addr:"127.0.0.1" ~port:9999 callback +Http_daemon.start' ~port:9999 callback diff --git a/helm/DEVEL/ocaml-http/examples/timeout.ml b/helm/DEVEL/ocaml-http/examples/timeout.ml index 261b8ee3a..eaa840778 100644 --- a/helm/DEVEL/ocaml-http/examples/timeout.ml +++ b/helm/DEVEL/ocaml-http/examples/timeout.ml @@ -23,5 +23,4 @@ let callback _ _ outchan = output_string outchan "Here you are!\n"; flush outchan in -Http_daemon.start ~addr:"127.0.0.1" ~port:9999 ~timeout:(Some 10) callback - +Http_daemon.start ~port:9999 ~timeout:(Some 10) callback diff --git a/helm/DEVEL/ocaml-http/http_common.ml b/helm/DEVEL/ocaml-http/http_common.ml index 8e59dbd58..28b7201b9 100644 --- a/helm/DEVEL/ocaml-http/http_common.ml +++ b/helm/DEVEL/ocaml-http/http_common.ml @@ -24,6 +24,8 @@ exception Invalid_code of int exception Invalid_status of Http_types.status let http_version = `HTTP_1_1 +let server_string = "OCaml HTTP Daemon" +let crlf = "\r\n" let string_of_version = function | `HTTP_1_0 -> "HTTP/1.0" diff --git a/helm/DEVEL/ocaml-http/http_common.mli b/helm/DEVEL/ocaml-http/http_common.mli index 172e66e5a..447f317e7 100644 --- a/helm/DEVEL/ocaml-http/http_common.mli +++ b/helm/DEVEL/ocaml-http/http_common.mli @@ -24,6 +24,8 @@ exception Invalid_code of int exception Invalid_status of Http_types.status val http_version: Http_types.version +val server_string: string +val crlf: string val string_of_version: Http_types.version -> string val version_of_string: string -> Http_types.version diff --git a/helm/DEVEL/ocaml-http/http_daemon.ml b/helm/DEVEL/ocaml-http/http_daemon.ml index 3fa78b349..c26d284ea 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.ml +++ b/helm/DEVEL/ocaml-http/http_daemon.ml @@ -19,158 +19,32 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) -open Neturl;; open Printf;; -let debug = false +open Http_parser;; + +let debug = true let debug_print str = - prerr_endline ("DEBUG: " ^ str); - flush stderr + if debug then begin + prerr_endline ("DEBUG: " ^ str); + flush stderr + end let default_addr = "0.0.0.0" let default_port = 80 let default_timeout = 300 - -(* -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); -} - -let crlf = "\r\n" - -exception Malformed_request of string -exception Unsupported_method of string -exception Malformed_request_URI of string -exception Unsupported_HTTP_version of string -exception Malformed_query of string -exception Malformed_query_binding of string * string - - (** given a list of length 2 - @return a pair formed by the elements of the list - @raise Assert_failure if the list length isn't 2 - *) -let pair_of_2_sized_list = function - | [a;b] -> (a,b) - | _ -> assert false - - (** 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_binding if some piece of the query isn't valid - *) -let split_query_params = - let (bindings_sep, binding_sep) = (Pcre.regexp "&", Pcre.regexp "=") 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 -> - let pieces = Pcre.split ~rex:binding_sep binding in - if List.length pieces <> 2 then - raise (Malformed_query_binding (binding, query)); - pair_of_2_sized_list pieces) - bindings - - (** given an input channel and a separator - @return a line read from it (like Pervasives.input_line) - line is returned only after reading a separator string; separator string isn't - included in the returned value - FIXME what about efficiency?, input is performed char-by-char - *) -let generic_input_line ~sep ~ic = - let sep_len = String.length sep in - if sep_len < 1 then - failwith ("Separator '" ^ sep ^ "' is too short!") - else (* valid separator *) - let line = ref "" in - let sep_pointer = ref 0 in - try - while true do - if !sep_pointer >= String.length sep then (* line completed *) - raise End_of_file - 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 *) - incr sep_pointer - else begin (* useful char *) - for i = 0 to !sep_pointer - 1 do - line := !line ^ (String.make 1 (String.get sep i)) - done; - sep_pointer := 0; - line := !line ^ (String.make 1 ch) - end - end - done; - assert false (* unreacheable statement *) - with End_of_file -> - if !line = "" then - raise End_of_file - else - !line - - (** given an input channel, reads from it a GET HTTP request and - @return a pair where path is a string representing the - requested path and query_params is a list of pairs (the GET - parameters) - *) -let parse_http_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 - if debug then - debug_print ("request_line: '" ^ request_line ^ "'"); - 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 = - 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)) - in - let query_params = - try split_query_params (url_query request_uri) with Not_found -> [] - in - (path, query_params) - | _ -> raise (Malformed_request request_line) +let default_fork = true (** send raw data on outchan, flushing it afterwards *) let send_raw ~data outchan = output_string outchan data; flush outchan -let send_CRLF = send_raw ~data:crlf +let send_CRLF = send_raw ~data:Http_common.crlf (** TODO perform some sanity test on header and value *) -let send_header ~header ~value = send_raw ~data:(header ^ ": " ^ value ^ crlf) +let send_header ~header ~value = + send_raw ~data:(header ^ ": " ^ value ^ Http_common.crlf) let send_headers ~headers outchan = List.iter (fun (header, value) -> send_header ~header ~value outchan) headers @@ -196,7 +70,7 @@ let send_status_line' ~version ~code = string_of_int code; Http_common.reason_phrase_of_code code ] in - send_raw ~data:(status_line ^ crlf) + send_raw ~data:(status_line ^ Http_common.crlf) let send_status_line ?(version = Http_common.http_version) ?code ?status outchan @@ -206,6 +80,7 @@ let send_status_line ~code:(get_code_argument "Daemon.send_status_line" ~code ~status) outchan + (* FIXME duplication of code between this and response#addBasicHeaders *) let send_basic_headers ?(version = Http_common.http_version) ?code ?status outchan = @@ -213,7 +88,7 @@ let send_basic_headers ~version ~code:(get_code_argument "Daemon.send_basic_headers" ~code ~status) outchan; send_headers - ~headers:["Date", Http_misc.date_822 (); "Server", "OCaml HTTP Daemon"] + ~headers:["Date", Http_misc.date_822 (); "Server", Http_common.server_string] outchan (** internal: send a fooish body explaining in HTML form the 'reason phrase' @@ -376,26 +251,16 @@ let respond_with (res: Http_types.response) outchan = res#serialize outchan; flush outchan + (* curried request *) let start ?(addr = default_addr) ?(port = default_port) - ?(timeout = Some default_timeout) + ?(timeout = Some default_timeout) ?(fork = default_fork) callback = let sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port) in - let timeout_callback signo = - if signo = Sys.sigalrm then begin - debug_print "TIMEOUT, exiting ..."; - exit 2 - end - in let daemon_callback inchan outchan = - (match timeout with - | Some timeout -> - ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_callback)); - ignore (Unix.alarm timeout) - | None -> ()); try - let (path, parameters) = parse_http_request inchan in + let (path, parameters) = Http_parser.parse_request inchan in callback path parameters outchan; flush outchan with @@ -430,18 +295,21 @@ let start sprintf "Malformed query element '%s' in query '%s'" binding query) outchan in - Unix.establish_server daemon_callback sockaddr + match fork with + | true -> Tcp_server.ocaml_builtin ~sockaddr ~timeout daemon_callback + | false -> Tcp_server.simple ~sockaddr ~timeout daemon_callback + (* OO request *) let start' ?(addr = default_addr) ?(port = default_port) - ?(timeout = Some default_timeout) + ?(timeout = Some default_timeout) ?(fork = default_fork) (callback: (Http_types.request -> out_channel -> unit)) = let wrapper path params outchan = let req = new Http_request.request ~path ~params in callback req outchan in - start ~addr ~port ~timeout wrapper + start ~addr ~port ~timeout ~fork wrapper module Trivial = struct diff --git a/helm/DEVEL/ocaml-http/http_daemon.mli b/helm/DEVEL/ocaml-http/http_daemon.mli index 60384b26c..975efb894 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.mli +++ b/helm/DEVEL/ocaml-http/http_daemon.mli @@ -91,12 +91,15 @@ val respond_with: Http_types.response -> out_channel -> unit receive as a first parameter the path required by the the HTTP client as a string, and a list of pair representing parameters passed via GET. The last argument of the callback is an output_channel connected to - the HTTP client to which the user can write directly. 'timeout' parameter - sets a timeout for each request processed by the daemon, if it's set to None, + the HTTP client to which the user can write directly. 'timeout' parameter sets + a timeout for each request processed by the daemon, if it's set to None, daemon waits forever for completed requests (use with care!), default is 5 - minute *) + minute. 'fork' parameter (default 'true') sets whether the daemon forks a + child for each request or not, if children aren't forked request are server + one at a time (backlog is 10) and callbacks live in the same address space of + the process invoking 'start' *) val start: - ?addr: string -> ?port: int -> ?timeout: int option -> + ?addr: string -> ?port: int -> ?timeout: int option -> ?fork: bool -> (string -> (string * string) list -> out_channel -> unit) -> unit @@ -104,7 +107,7 @@ val start: one is an out_channel as per 'start', but the secondo one is a Request.request object *) val start': - ?addr: string -> ?port: int -> ?timeout: int option -> + ?addr: string -> ?port: int -> ?timeout: int option -> ?fork: bool -> (Http_types.request -> out_channel -> unit) -> unit diff --git a/helm/DEVEL/ocaml-http/http_parser.ml b/helm/DEVEL/ocaml-http/http_parser.ml new file mode 100644 index 000000000..a753e40bb --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_parser.ml @@ -0,0 +1,150 @@ + +(* + 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 Neturl;; + +exception Malformed_query of string +exception Malformed_query_binding of string * string +exception Unsupported_method of string +exception Unsupported_HTTP_version of string +exception Malformed_request_URI of string +exception Malformed_request of string + +(* +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); +} + + (** given a list of length 2 + @return a pair formed by the elements of the list + @raise Assert_failure if the list length isn't 2 + *) +let pair_of_2_sized_list = function + | [a;b] -> (a,b) + | _ -> assert false + + (** 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_binding if some piece of the query isn't valid + *) +let split_query_params = + let (bindings_sep, binding_sep) = (Pcre.regexp "&", Pcre.regexp "=") 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 -> + let pieces = Pcre.split ~rex:binding_sep binding in + if List.length pieces <> 2 then + raise (Malformed_query_binding (binding, query)); + pair_of_2_sized_list pieces) + bindings + + (** given an input channel and a separator + @return a line read from it (like Pervasives.input_line) + line is returned only after reading a separator string; separator string isn't + included in the returned value + FIXME what about efficiency?, input is performed char-by-char + *) +let generic_input_line ~sep ~ic = + let sep_len = String.length sep in + if sep_len < 1 then + failwith ("Separator '" ^ sep ^ "' is too short!") + else (* valid separator *) + let line = ref "" in + let sep_pointer = ref 0 in + try + while true do + if !sep_pointer >= String.length sep then (* line completed *) + raise End_of_file + 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 *) + incr sep_pointer + else begin (* useful char *) + for i = 0 to !sep_pointer - 1 do + line := !line ^ (String.make 1 (String.get sep i)) + done; + sep_pointer := 0; + line := !line ^ (String.make 1 ch) + end + end + done; + assert false (* unreacheable statement *) + with End_of_file -> + if !line = "" then + raise End_of_file + else + !line + + (** given an input channel, reads from it a GET HTTP request and + @return a pair where path is a string representing the + requested path and query_params is a list of pairs (the GET + parameters) + *) +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:Http_common.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 = + 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)) + in + let query_params = + try split_query_params (url_query request_uri) with Not_found -> [] + in + (path, query_params) + | _ -> raise (Malformed_request request_line) + diff --git a/helm/DEVEL/ocaml-http/http_parser.mli b/helm/DEVEL/ocaml-http/http_parser.mli new file mode 100644 index 000000000..1cffb2a4a --- /dev/null +++ b/helm/DEVEL/ocaml-http/http_parser.mli @@ -0,0 +1,29 @@ + +(* + 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 +*) + +exception Malformed_query of string +exception Malformed_query_binding of string * string +exception Unsupported_method of string +exception Unsupported_HTTP_version of string +exception Malformed_request_URI of string +exception Malformed_request of string + +val parse_request: in_channel -> string * (string * string) list diff --git a/helm/DEVEL/ocaml-http/http_response.ml b/helm/DEVEL/ocaml-http/http_response.ml index b71d887fc..dd145b840 100644 --- a/helm/DEVEL/ocaml-http/http_response.ml +++ b/helm/DEVEL/ocaml-http/http_response.ml @@ -40,7 +40,8 @@ class response = let status_line_re = Pcre.regexp "^(HTTP/\d\.\d) (\d{3}) (.*)$" in object (self) val mutable version = Http_common.http_version - val mutable code = default_code val mutable reason: string option = None + val mutable code = default_code + val mutable reason: string option = None val contentsBuf = Buffer.create 1024 val headers = Hashtbl.create 11 @@ -87,26 +88,18 @@ class response = method addContents s = Buffer.add_string contentsBuf s method addContentsBuf b = Buffer.add_buffer contentsBuf b - (** adds an header named 'name' with value 'value', if an header with the - same name exists, the new value is considered an addition to the header as - specified in RFC 2616, thus getting value for this header will return a - comma separated list of values provided via 'addHeader' *) method addHeader ~name ~value = Hashtbl.add headers name value - (** set the value of header 'name' to 'value', removing all previous - values if any *) + (* 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:(Http_common.server_string) method replaceHeader ~name ~value = Hashtbl.replace headers name value - (** remove the header named 'name', please note that this remove all - values provided for this header *) method removeHeader ~name = hashtbl_remove_all headers name method hasHeader ~name = Hashtbl.mem headers name - (** @return value of header 'name', if multiple values were provided for - header 'name', the return value will be a comma separated list of - provided values as stated in RFC 2616 *) method header ~name = if not (self#hasHeader name) then raise (Header_not_found name); String.concat ", " (List.rev (Hashtbl.find_all headers name)) - (** @return all headers as a list of pairs *) method headers = List.rev (Hashtbl.fold diff --git a/helm/DEVEL/ocaml-http/http_types.ml b/helm/DEVEL/ocaml-http/http_types.ml index 37621ef07..79ccf783a 100644 --- a/helm/DEVEL/ocaml-http/http_types.ml +++ b/helm/DEVEL/ocaml-http/http_types.ml @@ -125,6 +125,7 @@ class type response = method addContents: string -> unit method addContentsBuf: Buffer.t -> unit method addHeader: name:string -> value:string -> unit + method addBasicHeaders: unit method replaceHeader: name:string -> value:string -> unit method removeHeader: name:string -> unit method hasHeader: name:string -> bool diff --git a/helm/DEVEL/ocaml-http/tcp_server.ml b/helm/DEVEL/ocaml-http/tcp_server.ml new file mode 100644 index 000000000..70b303eeb --- /dev/null +++ b/helm/DEVEL/ocaml-http/tcp_server.ml @@ -0,0 +1,51 @@ + + (** raised when a client timeouts *) +exception Timeout;; + + (** if timeout is given (Some _) @return a new callback which establish + timeout_callback as callback for signal Sys.sigalrm and register an alarm + (expiring after timeout seconds) before invoking the real callback given. If + timeout is None, callback is returned unchanged. *) +let wrap_callback_w_timeout ~callback ~timeout ~timeout_callback = + match timeout with + | None -> callback + | Some timeout -> (* wrap callback setting an handler for ALRM signal and an + alarm that ring after timeout seconds *) + (fun inchan outchan -> + ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle ~timeout_callback)); + ignore (Unix.alarm timeout); + callback inchan outchan) + + (** Http_daemon.start function low level which use Unix.establish_server which + in turn forks a child for each request *) +let ocaml_builtin ~sockaddr ~timeout callback = + let timeout_callback signo = + if signo = Sys.sigalrm then + exit 2 + in + Unix.establish_server + (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback) + sockaddr + + (** Http_daemon.start function low level which doesn't fork, requests are + server sequentially and in the same address space of the calling process *) +let simple ~sockaddr ~timeout callback = + let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Unix.setsockopt suck Unix.SO_REUSEADDR true; + Unix.bind suck sockaddr; + Unix.listen suck 10; + let timeout_callback signo = + if signo = Sys.sigalrm then + raise Timeout + in + let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in + while true do + let (suck, _) = Unix.accept suck in + (* client is now connected *) + let (inchan, outchan) = + (Unix.in_channel_of_descr suck, Unix.out_channel_of_descr suck) + in + (try callback inchan outchan with Timeout -> ()); + close_out outchan (* this close also inchan, because socket is the same *) + done + diff --git a/helm/DEVEL/ocaml-http/tcp_server.mli b/helm/DEVEL/ocaml-http/tcp_server.mli new file mode 100644 index 000000000..230b838a2 --- /dev/null +++ b/helm/DEVEL/ocaml-http/tcp_server.mli @@ -0,0 +1,8 @@ +val ocaml_builtin: + sockaddr:Unix.sockaddr -> timeout:int option -> + (in_channel -> out_channel -> unit) -> + unit +val simple: + sockaddr:Unix.sockaddr -> timeout:int option -> + (in_channel -> out_channel -> unit) -> + unit -- 2.39.2