X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_response.ml;h=58308d30700ed217f3482727c1d6a46ef32cb180;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=b71d887fc576327b1322f22a2624646414cf9496;hpb=6a8da4dd52033adfe80533f7467439aec1561147;p=helm.git diff --git a/helm/DEVEL/ocaml-http/http_response.ml b/helm/DEVEL/ocaml-http/http_response.ml index b71d887fc..58308d307 100644 --- a/helm/DEVEL/ocaml-http/http_response.ml +++ b/helm/DEVEL/ocaml-http/http_response.ml @@ -2,117 +2,103 @@ (* OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - Copyright (C) <2002> Stefano Zacchiroli + Copyright (C) <2002-2005> 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. + it under the terms of the GNU Library General Public License as + published by the Free Software Foundation, version 2. 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. + GNU Library 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 + You should have received a copy of the GNU Library 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;; +open Http_constants;; open Http_common;; open Http_daemon;; +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) + ?clisockaddr ?srvsockaddr (* optional because response have to be easily + buildable in callback functions *) + ?(code = 200) ?status + () + = + + (** if no address were supplied for client and/or server, use a foo address + instead *) + let (clisockaddr, srvsockaddr) = (anyize clisockaddr, anyize srvsockaddr) in -exception Invalid_status_line of string -exception Header_not_found of string - - (* TODO sanity checks on set* methods' arguments (e.g. dates 822 compliant, - code values < 600, ...) *) -class response = - let default_code = 200 in - (* 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 (* "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 code = default_code val mutable reason: string option = None - val contentsBuf = Buffer.create 1024 - val headers = Hashtbl.create 11 - - method version = version - method setVersion v = version <- v - - method code = code - method setCode c = code <- c - method status = status_of_code code - method setStatus (s: Http_types.status) = code <- code_of_status s + + (* note that response objects can't be created with a None version *) + inherit + Http_message.message + ~body ~headers ~version:(Some 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 + + method private getRealVersion = + match self#version with + | None -> + failwith ("Http_response.fstLineToString: " ^ + "can't serialize an HTTP response with no HTTP version defined") + | Some v -> string_of_version v + + method code = _code + method setCode c = + ignore (status_of_code c); (* sanity check on c *) + _code <- c + method status = status_of_code _code + method setStatus (s: Http_types.status) = _code <- code_of_status s method reason = - match reason with - | None -> reason_phrase_of_code code + match _reason with + | None -> Http_misc.reason_phrase_of_code _code | Some r -> r - method setReason r = reason <- Some r + method setReason r = _reason <- Some r method statusLine = - String.concat - " " - [string_of_version self#version; string_of_int self#code; self#reason] + String.concat " " + [self#getRealVersion; string_of_int self#code; self#reason] method setStatusLine s = try - let subs = Pcre.extract ~rex:status_line_re s in - self#setVersion (Http_common.version_of_string subs.(1)); + let subs = Pcre.extract ~rex:status_line_RE s in + self#setVersion (version_of_string subs.(1)); self#setCode (int_of_string subs.(2)); self#setReason subs.(3) with Not_found -> raise (Invalid_status_line s) - method isInformational = is_informational code - method isSuccess = is_success code - method isRedirection = is_redirection code - method isClientError = is_client_error code - 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 - - (** 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 *) - 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 - (fun name _ headers -> (name, self#header ~name)::headers) - headers - []) + method isInformational = is_informational _code + method isSuccess = is_success _code + method isRedirection = is_redirection _code + method isClientError = is_client_error _code + method isServerError = is_server_error _code + method isError = is_error _code + + (* 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 contentType = self#header "Content-Type" method setContentType t = self#replaceHeader "Content-Type" t @@ -125,13 +111,8 @@ class response = method server = self#header "Server" method setServer s = self#replaceHeader "Server" s - method serialize outchan = - output_string outchan self#statusLine; - send_CRLF outchan; - send_headers self#headers outchan; - send_CRLF outchan; - Buffer.output_buffer outchan contentsBuf; - flush outchan + method private fstLineToString = + sprintf "%s %d %s" self#getRealVersion self#code self#reason end