From: Stefano Zacchiroli Date: Fri, 22 Nov 2002 10:25:51 +0000 (+0000) Subject: - added support for multithreaded daemons X-Git-Tag: V_0_0_5~7 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=9a072f192471daeca8cb409e991f0073b1d4271f;p=helm.git - added support for multithreaded daemons - added a generic 'respond' function, used also as low level for other respond functions - added support for chdir in a given document root before starting - added toString method to response objects --- diff --git a/helm/DEVEL/ocaml-http/Makefile.defs b/helm/DEVEL/ocaml-http/Makefile.defs index fae18312a..fcd612e5f 100644 --- a/helm/DEVEL/ocaml-http/Makefile.defs +++ b/helm/DEVEL/ocaml-http/Makefile.defs @@ -1,14 +1,14 @@ PKGNAME = http +DISTVERSION = 0.0.4 DEBUG_OPTS = -COMMON_OPTS = $(DEBUG_OPTS) -pp camlp4o -package "unix,pcre,netstring" +COMMON_OPTS = $(DEBUG_OPTS) -pp camlp4o -thread -package "unix,pcre,netstring,threads" OCAMLFIND = ocamlfind OCAMLC = $(OCAMLFIND) ocamlc $(COMMON_OPTS) OCAMLOPT = $(OCAMLFIND) ocamlopt $(COMMON_OPTS) OCAMLDEP = $(OCAMLFIND) ocamldep $(COMMON_OPTS) DISTNAME = ocaml-http -DISTVERSION = 0.0.3 DISTDIR = $(DISTNAME)-$(DISTVERSION) EXTRA_DIST = INSTALL LICENSE README META.in Makefile Makefile.defs .depend tophttp diff --git a/helm/DEVEL/ocaml-http/TODO b/helm/DEVEL/ocaml-http/TODO index ac983999f..a32543a7c 100644 --- a/helm/DEVEL/ocaml-http/TODO +++ b/helm/DEVEL/ocaml-http/TODO @@ -1,10 +1,14 @@ -- add Http_daemon.respond_ok ~body + - add a perlish Http_daemon.daemon class, e.g.: let d = new daemon ... in while true do req = d#accept () ... done -- add the possibility to chdir and/or chroot in a given dir before starting - parse also header and contents of http requests and add corresponding methods to requests objects + +- add the possibility to chdir in a given dir before starting -> DONE +- add support for multi threaded daemon -> DONE +- add Http_daemon.respond -> DONE + diff --git a/helm/DEVEL/ocaml-http/examples/Makefile b/helm/DEVEL/ocaml-http/examples/Makefile index e4025264b..8c74ba641 100644 --- a/helm/DEVEL/ocaml-http/examples/Makefile +++ b/helm/DEVEL/ocaml-http/examples/Makefile @@ -3,7 +3,8 @@ OBJS = ../http.cma OBJS_OPT = ../http.cmxa EXAMPLES_OPTS = -I .. -linkpkg -EXAMPLES = always_ok_daemon webfsd obj_foo dump_args timeout dont_fork +EXAMPLES = \ + always_ok_daemon webfsd obj_foo dump_args timeout dont_fork threads chdir 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 48b5fd4bb..492be655a 100644 --- a/helm/DEVEL/ocaml-http/examples/always_ok_daemon.ml +++ b/helm/DEVEL/ocaml-http/examples/always_ok_daemon.ml @@ -20,7 +20,6 @@ *) open Http_daemon;; -open Http_response;; (* start an http daemon that alway respond with a 200 status code and an empty content *) -start ~port:9999 (fun _ _ -> respond_with (new Http_response.response)) +start ~port:9999 (fun _ _ outchan -> respond outchan) diff --git a/helm/DEVEL/ocaml-http/examples/chdir.ml b/helm/DEVEL/ocaml-http/examples/chdir.ml new file mode 100644 index 000000000..a5e460b3a --- /dev/null +++ b/helm/DEVEL/ocaml-http/examples/chdir.ml @@ -0,0 +1,27 @@ + +(* + 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_daemon;; +open Printf;; +start + ~port:9999 + ~root:"/etc" + (fun _ _ outchan -> respond ~body:(sprintf "%s\n" (Sys.getcwd ())) outchan) diff --git a/helm/DEVEL/ocaml-http/examples/dont_fork.ml b/helm/DEVEL/ocaml-http/examples/dont_fork.ml index a64e661d0..d0e1d91e6 100644 --- a/helm/DEVEL/ocaml-http/examples/dont_fork.ml +++ b/helm/DEVEL/ocaml-http/examples/dont_fork.ml @@ -20,6 +20,6 @@ *) let callback req outchan = - Http_daemon.respond_error ~body:"AH AH AH :-P" outchan + Http_daemon.respond_error ~body:"AH AH AH :-P\n" outchan in -Http_daemon.start' ~port:9999 ~fork:false ~timeout:(Some 5) callback +Http_daemon.start' ~port:9999 ~mode:`Single ~timeout:(Some 5) callback diff --git a/helm/DEVEL/ocaml-http/examples/threads.ml b/helm/DEVEL/ocaml-http/examples/threads.ml new file mode 100644 index 000000000..9eba49f37 --- /dev/null +++ b/helm/DEVEL/ocaml-http/examples/threads.ml @@ -0,0 +1,47 @@ + +(* + 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 m = Mutex.create () in +let i = ref 10 in +let dump_i outchan = + Http_daemon.respond ~body:(Printf.sprintf "i = %d\n" !i) outchan +in +let callback req outchan = + match req#path with + | "/incr" -> + Mutex.lock m; + incr i; + dump_i outchan; + Unix.sleep 5; + Mutex.unlock m + | "/decr" -> + Mutex.lock m; + decr i; + dump_i outchan; + Unix.sleep 5; + Mutex.unlock m + | "/get" -> + Mutex.lock m; + dump_i outchan; + Mutex.unlock m + | bad_request -> Http_daemon.respond_error outchan +in +Http_daemon.start' ~port:9999 ~mode:`Thread callback diff --git a/helm/DEVEL/ocaml-http/http_daemon.ml b/helm/DEVEL/ocaml-http/http_daemon.ml index 8dfc83e50..0a0f47775 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.ml +++ b/helm/DEVEL/ocaml-http/http_daemon.ml @@ -21,6 +21,7 @@ open Printf;; +open Http_common;; open Http_parser;; let debug = true @@ -33,18 +34,18 @@ let debug_print str = let default_addr = "0.0.0.0" let default_port = 80 let default_timeout = 300 -let default_fork = true +let default_mode = `Fork (** 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:Http_common.crlf +let send_CRLF = send_raw ~data:crlf (** TODO perform some sanity test on header and value *) let send_header ~header ~value = - send_raw ~data:(header ^ ": " ^ value ^ Http_common.crlf) + send_raw ~data:(header ^ ": " ^ value ^ crlf) let send_headers ~headers outchan = List.iter (fun (header, value) -> send_header ~header ~value outchan) headers @@ -55,7 +56,7 @@ let get_code_argument func_name = fun ~code ~status -> (match code, status with | Some c, None -> c - | None, Some s -> Http_common.code_of_status s + | None, Some s -> code_of_status s | Some _, Some _ -> failwith (func_name ^ " you must give 'code' or 'status', not both") | None, None -> @@ -66,47 +67,59 @@ let send_status_line' ~version ~code = let status_line = String.concat " " - [ Http_common.string_of_version version; + [ string_of_version version; string_of_int code; - Http_common.reason_phrase_of_code code ] + reason_phrase_of_code code ] in - send_raw ~data:(status_line ^ Http_common.crlf) + send_raw ~data:(status_line ^ crlf) -let send_status_line - ?(version = Http_common.http_version) ?code ?status outchan - = +let send_status_line ?(version = http_version) ?code ?status outchan = send_status_line' ~version ~code:(get_code_argument "Daemon.send_status_line" ~code ~status) outchan (* FIXME duplication of code between this and response#addBasicHeaders *) -let send_basic_headers - ?(version = Http_common.http_version) ?code ?status outchan - = +let send_basic_headers ?(version = http_version) ?code ?status outchan = send_status_line' ~version ~code:(get_code_argument "Daemon.send_basic_headers" ~code ~status) outchan; send_headers - ~headers:["Date", Http_misc.date_822 (); "Server", Http_common.server_string] + ~headers:["Date", Http_misc.date_822 (); "Server", server_string] outchan - (** internal: send a fooish body explaining in HTML form the 'reason phrase' - of an HTTP response; body, if given, will be appended to the body *) -let send_foo_body ~code ~body = - let reason_phrase = Http_common.reason_phrase_of_code code in - let body = - sprintf + (** internal: given a status code and an additional body return a string + representing an HTML document that explains the meaning of given status code. + Additional data can be added to the body via 'body' argument *) +let foo_body code body = + let reason_phrase = reason_phrase_of_code code in + sprintf " %d %s

%d - %s

%s " - code reason_phrase code reason_phrase - (match body with None -> "" | Some text -> "\n" ^ text) + code reason_phrase code reason_phrase body + + (** internal: send a fooish body explaining in HTML form the 'reason phrase' + 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 + ?(body = "") ?(headers = []) + ?(version = http_version) ?(code = 200) ?status outchan + = + let code = + match status with + | None -> code + | Some s -> code_of_status s in - send_raw ~data:body + send_basic_headers ~version ~code outchan; + send_headers ~headers outchan; + send_CRLF outchan; + send_raw ~data:body outchan (** internal: low level for respond_redirect, respond_error, ... This function send a status line corresponding to a given code, some basic @@ -114,12 +127,23 @@ let send_foo_body ~code ~body = reason phrase; if body is given it will be included in the body of the HTML page *) let send_empty_response - f_name ?(is_valid_status = fun _ -> true) ?(headers = []) ~body () = - fun ?(version = Http_common.http_version) ?code ?status outchan -> - let code = get_code_argument f_name ~code ~status in + func_name ?(is_valid_status = fun _ -> true) ?(headers = []) ~body () = + fun ?(version = http_version) ?code ?status outchan -> + let code = get_code_argument func_name ~code ~status in if not (is_valid_status code) then - failwith (sprintf "'%d' isn't a valid status code for %s" code f_name) + failwith + (sprintf "'%d' isn't a valid status code for %s" code func_name) else begin (* status code suitable for answering *) + let headers = + [ + "Connection", "close"; + "Content-Type", "text/html; charset=iso-8859-1" + ] @ headers + in + let body = (foo_body code body) ^ body in + respond ~version ~code ~headers ~body outchan +(* + (* OLD VERSION, now use 'respond' function *) send_basic_headers ~version ~code outchan; send_header ~header:"Connection" ~value:"close" outchan; send_header @@ -129,43 +153,41 @@ let send_empty_response send_headers ~headers outchan; send_CRLF outchan; send_foo_body ~code ~body outchan +*) end (* TODO sanity tests on location *) let respond_redirect - ~location ?body - ?(version = Http_common.http_version) ?(code = 301) ?status outchan = - let code = - match status with - | None -> code - | Some (s: Http_types.redirection_status) -> Http_common.code_of_status s - in - send_empty_response - "Daemon.respond_redirect" ~is_valid_status:Http_common.is_redirection - ~headers:["Location", location] ~body () - ~version ~code outchan + ~location ?(body = "") ?(version = http_version) ?(code = 301) ?status outchan + = + let code = + match status with + | None -> code + | Some (s: Http_types.redirection_status) -> code_of_status s + in + send_empty_response + "Daemon.respond_redirect" ~is_valid_status:is_redirection + ~headers:["Location", location] ~body () + ~version ~code outchan let respond_error - ?body - ?(version = Http_common.http_version) ?(code = 400) ?status outchan = + ?(body = "") ?(version = http_version) ?(code = 400) ?status outchan = let code = match status with | None -> code - | Some s -> Http_common.code_of_status s + | Some s -> code_of_status s in send_empty_response - "Daemon.respond_error" ~is_valid_status:Http_common.is_error ~body () + "Daemon.respond_error" ~is_valid_status:is_error ~body () ~version ~code outchan -let respond_not_found ~url ?(version = Http_common.http_version) outchan = +let respond_not_found ~url ?(version = http_version) outchan = send_empty_response - "Daemon.respond_not_found" ~body:None () - ~version ~code:404 outchan + "Daemon.respond_not_found" ~body:"" () ~version ~code:404 outchan -let respond_forbidden ~url ?(version = Http_common.http_version) outchan = +let respond_forbidden ~url ?(version = http_version) outchan = send_empty_response - "Daemon.respond_permission_denied" ~body:None () - ~version ~code:403 outchan + "Daemon.respond_permission_denied" ~body:"" () ~version ~code:403 outchan let send_file ?name ?file outchan = let buflen = 1024 in @@ -212,7 +234,7 @@ let send_dir_listing ~dir ~name ~path outchan = fprintf outchan "\n"; flush outchan -let respond_file ~fname ?(version = Http_common.http_version) outchan = +let respond_file ~fname ?(version = http_version) outchan = (** ASSUMPTION: 'fname' doesn't begin with a "/"; it's relative to the current document root (usually the daemon's cwd) *) let droot = Sys.getcwd () in (* document root *) @@ -251,12 +273,15 @@ let respond_with (res: Http_types.response) outchan = res#serialize outchan; flush outchan + (* TODO support also chroot to 'root', not only chdir *) (* curried request *) let start ?(addr = default_addr) ?(port = default_port) - ?(timeout = Some default_timeout) ?(fork = default_fork) - callback + ?(timeout = Some default_timeout) ?(mode = default_mode) ?root callback = + (match root with (* chdir to document root *) + | Some dir -> Sys.chdir dir + | None -> ()); let sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port) in let daemon_callback inchan outchan = try @@ -287,7 +312,7 @@ let start outchan | Malformed_query query -> respond_error - ~code:400 ~body:("Malformed query string '" ^ query ^ "'") outchan + ~code:400 ~body:(sprintf "Malformed query string '%s'" query) outchan | Malformed_query_binding (binding, query) -> respond_error ~code:400 @@ -295,21 +320,23 @@ let start sprintf "Malformed query element '%s' in query '%s'" binding query) outchan in - match fork with - | true -> Http_tcp_server.ocaml_builtin ~sockaddr ~timeout daemon_callback - | false -> Http_tcp_server.simple ~sockaddr ~timeout daemon_callback + 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 (* OO request *) let start' ?(addr = default_addr) ?(port = default_port) - ?(timeout = Some default_timeout) ?(fork = default_fork) - (callback: (Http_types.request -> out_channel -> unit)) + ?(timeout = Some default_timeout) ?(mode = default_mode) ?root callback = let wrapper path params outchan = let req = new Http_request.request ~path ~params in callback req outchan in - start ~addr ~port ~timeout ~fork wrapper + match root with + | None -> start ~addr ~port ~timeout ~mode wrapper + | Some root -> start ~addr ~port ~timeout ~mode ~root wrapper module Trivial = struct diff --git a/helm/DEVEL/ocaml-http/http_daemon.mli b/helm/DEVEL/ocaml-http/http_daemon.mli index 975efb894..96d10d638 100644 --- a/helm/DEVEL/ocaml-http/http_daemon.mli +++ b/helm/DEVEL/ocaml-http/http_daemon.mli @@ -48,6 +48,16 @@ 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 *) +val respond: + ?body:string -> ?headers:(string * string) list -> + ?version:Http_types.version -> ?code:int -> ?status:Http_types.status -> + out_channel -> + unit + (** send a 404 (not found) HTTP response *) val respond_not_found: url:string -> ?version: Http_types.version -> out_channel -> unit @@ -94,12 +104,15 @@ val respond_with: Http_types.response -> out_channel -> unit 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. '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' *) + minute. 'mode' parameter has 3 possible values: `Single means that all request + are handled by the same process, `Fork means that each request is handled by a + separate process, `Thread means that each request is handled by a separate + thread, default is `Fork; 'root' (mnemonic "document root") is the directory + where the daemon chdir before starting up, default is current working + directory *) val start: - ?addr: string -> ?port: int -> ?timeout: int option -> ?fork: bool -> + ?addr: string -> ?port: int -> + ?timeout: int option -> ?mode: Http_types.daemon_mode -> ?root: string -> (string -> (string * string) list -> out_channel -> unit) -> unit @@ -107,10 +120,20 @@ 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 -> ?fork: bool -> + ?addr: string -> ?port: int -> + ?timeout: int option -> ?mode: Http_types.daemon_mode -> ?root: string -> (Http_types.request -> out_channel -> unit) -> unit +(* + (** OO interface to HTTP daemons *) +class daemon: + ?addr: string -> ?port: int -> + ?timeout: int option -> ?mode: Http_types.daemon_mode ->?root:; string -> + (Http_types.request -> out_channel -> unit) -> + Http_types.daemon +*) + (** Trivial static pages HTTP daemon *) module Trivial : sig diff --git a/helm/DEVEL/ocaml-http/http_response.ml b/helm/DEVEL/ocaml-http/http_response.ml index dd145b840..3c58f13fa 100644 --- a/helm/DEVEL/ocaml-http/http_response.ml +++ b/helm/DEVEL/ocaml-http/http_response.ml @@ -21,6 +21,7 @@ open Http_common;; open Http_daemon;; +open Printf;; exception Invalid_status_line of string exception Header_not_found of string @@ -39,7 +40,7 @@ class response = (* "version code reason_phrase" *) let status_line_re = Pcre.regexp "^(HTTP/\d\.\d) (\d{3}) (.*)$" in object (self) - val mutable version = Http_common.http_version + val mutable version = http_version val mutable code = default_code val mutable reason: string option = None val contentsBuf = Buffer.create 1024 @@ -64,7 +65,7 @@ class response = method setStatusLine s = try let subs = Pcre.extract ~rex:status_line_re s in - self#setVersion (Http_common.version_of_string subs.(1)); + self#setVersion (version_of_string subs.(1)); self#setCode (int_of_string subs.(2)); self#setReason subs.(3) with Not_found -> @@ -92,7 +93,7 @@ class response = (* 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) + self#addHeader ~name:"Server" ~value:server_string method replaceHeader ~name ~value = Hashtbl.replace headers name value method removeHeader ~name = hashtbl_remove_all headers name method hasHeader ~name = Hashtbl.mem headers name @@ -118,13 +119,28 @@ class response = method server = self#header "Server" method setServer s = self#replaceHeader "Server" s + method toString = + 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 +(* + (* OLD VERSION *) output_string outchan self#statusLine; send_CRLF outchan; send_headers self#headers outchan; send_CRLF outchan; Buffer.output_buffer outchan contentsBuf; flush outchan +*) end diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.ml b/helm/DEVEL/ocaml-http/http_tcp_server.ml index 44e4df1d5..29cf3931e 100644 --- a/helm/DEVEL/ocaml-http/http_tcp_server.ml +++ b/helm/DEVEL/ocaml-http/http_tcp_server.ml @@ -2,6 +2,8 @@ (** raised when a client timeouts *) exception Timeout;; +let backlog = 10;; + (** 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 @@ -16,8 +18,33 @@ let wrap_callback_w_timeout ~callback ~timeout ~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 *) + (** tcp_server 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 backlog; + 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 (client, _) = Unix.accept suck in + (* client is now connected *) + let (inchan, outchan) = + (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client) + in + (try + callback inchan outchan; + ignore (Unix.alarm 0) (* reset alarm *) + with Timeout -> ()); + close_out outchan (* this close also inchan, because socket is the same *) + done + + (** tcp_server 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 @@ -27,28 +54,34 @@ let ocaml_builtin ~sockaddr ~timeout callback = (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 = + (* TODO this is a cut-and-paste from 'simple' *) + (** tcp_server which creates a new thread for each request to be served *) +let thread ~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; + Unix.listen suck backlog; let timeout_callback signo = if signo = Sys.sigalrm then raise Timeout in let callback = wrap_callback_w_timeout ~callback ~timeout ~timeout_callback in + let callback (i, o) = + try + callback i o; + close_out o + with + | Timeout -> close_out o + | e -> + close_out o; + raise e + in while true do - let (suck, _) = Unix.accept suck in + let (client, _) = Unix.accept suck in (* client is now connected *) let (inchan, outchan) = - (Unix.in_channel_of_descr suck, Unix.out_channel_of_descr suck) + (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client) in - (try - callback inchan outchan; - ignore (Unix.alarm 0) - with Timeout -> ()); - close_out outchan (* this close also inchan, because socket is the same *) + ignore (Thread.create callback (inchan, outchan)); done diff --git a/helm/DEVEL/ocaml-http/http_tcp_server.mli b/helm/DEVEL/ocaml-http/http_tcp_server.mli index 230b838a2..7c038a570 100644 --- a/helm/DEVEL/ocaml-http/http_tcp_server.mli +++ b/helm/DEVEL/ocaml-http/http_tcp_server.mli @@ -1,8 +1,3 @@ -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 +val simple: Http_types.tcp_server +val ocaml_builtin: Http_types.tcp_server +val thread: Http_types.tcp_server diff --git a/helm/DEVEL/ocaml-http/http_types.ml b/helm/DEVEL/ocaml-http/http_types.ml index 79ccf783a..70c8fce63 100644 --- a/helm/DEVEL/ocaml-http/http_types.ml +++ b/helm/DEVEL/ocaml-http/http_types.ml @@ -26,6 +26,13 @@ type version = type meth = [ `GET ] +type daemon_mode = [ `Single | `Fork | `Thread ] + +type tcp_server = + sockaddr:Unix.sockaddr -> timeout:int option -> + (in_channel -> out_channel -> unit) -> + unit + type informational_substatus = [ `Continue | `Switching_protocols @@ -141,6 +148,7 @@ 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 =