X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_response.ml;h=58308d30700ed217f3482727c1d6a46ef32cb180;hb=97c2d258a5c524eb5c4b85208899d80751a2c82f;hp=a0bda358250158ca56ceaec0eadf0d3e1b965b67;hpb=546ec5e551646b24abc9ad769c157a153d49ca88;p=helm.git diff --git a/helm/DEVEL/ocaml-http/http_response.ml b/helm/DEVEL/ocaml-http/http_response.ml index a0bda3582..58308d307 100644 --- a/helm/DEVEL/ocaml-http/http_response.ml +++ b/helm/DEVEL/ocaml-http/http_response.ml @@ -2,21 +2,21 @@ (* 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;; @@ -27,36 +27,43 @@ 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 + (* 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 - 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 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 = @@ -70,9 +77,8 @@ class response | Some r -> 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 @@ -89,45 +95,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 +111,8 @@ 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 + method private fstLineToString = + sprintf "%s %d %s" self#getRealVersion self#code self#reason end