helm/DEVEL/ocaml-http/http_response.ml

   1
   2 (*
   3   OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
   4
   5   Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
   6
   7   This program is free software; you can redistribute it and/or modify
   8   it under the terms of the GNU General Public License as published by
   9   the Free Software Foundation; either version 2 of the License, or
  10   (at your option) any later version.
  11
  12   This program is distributed in the hope that it will be useful,
  13   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15   GNU General Public License for more details.
  16
  17   You should have received a copy of the GNU General Public License
  18   along with this program; if not, write to the Free Software
  19   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  20 *)
  21
  22 open Http_common;;
  23 open Http_daemon;;
  24
  25 exception Invalid_status_line of string
  26 exception Header_not_found of string
  27
  28   (* TODO sanity checks on set* methods' arguments (e.g. dates 822 compliant,
  29   code values < 600, ...) *)
  30 class response =
  31   let default_code = 200 in
  32     (* remove all bindings of 'name' from hashtbl 'tbl' *)
  33   let rec hashtbl_remove_all tbl name =
  34     if not (Hashtbl.mem tbl name) then
  35       raise (Header_not_found name);
  36     Hashtbl.remove tbl name;
  37     if Hashtbl.mem tbl name then hashtbl_remove_all tbl name
  38   in
  39     (* "version code reason_phrase" *)
  40   let status_line_re = Pcre.regexp "^(HTTP/\d\.\d) (\d{3}) (.*)$" in
  41   object (self)
  42     val mutable version = Http_common.http_version
  43     val mutable code = default_code val mutable reason: string option = None
  44     val contentsBuf = Buffer.create 1024
  45     val headers = Hashtbl.create 11
  46
  47     method version = version
  48     method setVersion v = version <- v
  49
  50     method code = code
  51     method setCode c = code <- c
  52     method status = status_of_code code
  53     method setStatus (s: Http_types.status) = code <- code_of_status s
  54     method reason =
  55       match reason with
  56       | None -> reason_phrase_of_code code
  57       | Some r -> r
  58     method setReason r = reason <- Some r
  59     method statusLine =
  60       String.concat
  61         " "
  62         [string_of_version self#version; string_of_int self#code; self#reason]
  63     method setStatusLine s =
  64       try
  65         let subs = Pcre.extract ~rex:status_line_re s in
  66         self#setVersion (Http_common.version_of_string subs.(1));
  67         self#setCode (int_of_string subs.(2));
  68         self#setReason subs.(3)
  69       with Not_found ->
  70         raise (Invalid_status_line s)
  71
  72     method isInformational = is_informational code
  73     method isSuccess = is_success code
  74     method isRedirection = is_redirection code
  75     method isClientError = is_client_error code
  76     method isServerError = is_server_error code
  77     method isError = is_error code
  78
  79     method contents = Buffer.contents contentsBuf
  80     method setContents c =
  81       Buffer.clear contentsBuf;
  82       Buffer.add_string contentsBuf c
  83     method contentsBuf = contentsBuf
  84     method setContentsBuf b =
  85       Buffer.clear contentsBuf;
  86       Buffer.add_buffer contentsBuf b
  87     method addContents s = Buffer.add_string contentsBuf s
  88     method addContentsBuf b = Buffer.add_buffer contentsBuf b
  89
  90       (** adds an header named 'name' with value 'value', if an header with the
  91       same name exists, the new value is considered an addition to the header as
  92       specified in RFC 2616, thus getting value for this header will return a
  93       comma separated list of values provided via 'addHeader' *)
  94     method addHeader ~name ~value = Hashtbl.add headers name value
  95       (** set the value of header 'name' to 'value', removing all previous
  96       values if any *)
  97     method replaceHeader ~name ~value = Hashtbl.replace headers name value
  98       (** remove the header named 'name', please note that this remove all
  99       values provided for this header *)
 100     method removeHeader ~name = hashtbl_remove_all headers name
 101     method hasHeader ~name = Hashtbl.mem headers name
 102       (** @return value of header 'name', if multiple values were provided for
 103       header 'name', the return value will be a comma separated list of
 104       provided values as stated in RFC 2616 *)
 105     method header ~name =
 106       if not (self#hasHeader name) then
 107         raise (Header_not_found name);
 108       String.concat ", " (List.rev (Hashtbl.find_all headers name))
 109       (** @return all headers as a list of pairs <name, value> *)
 110     method headers =
 111       List.rev
 112         (Hashtbl.fold
 113           (fun name _ headers -> (name, self#header ~name)::headers)
 114           headers
 115           [])
 116
 117     method contentType = self#header "Content-Type"
 118     method setContentType t = self#replaceHeader "Content-Type" t
 119     method contentEncoding = self#header "Content-Encoding"
 120     method setContentEncoding e = self#replaceHeader "Content-Encoding" e
 121     method date = self#header "Date"
 122     method setDate d = self#replaceHeader "Date" d
 123     method expires = self#header "Expires"
 124     method setExpires t = self#replaceHeader "Expires" t
 125     method server = self#header "Server"
 126     method setServer s = self#replaceHeader "Server" s
 127
 128     method serialize outchan =
 129       output_string outchan self#statusLine;
 130       send_CRLF outchan;
 131       send_headers self#headers outchan;
 132       send_CRLF outchan;
 133       Buffer.output_buffer outchan contentsBuf;
 134       flush outchan
 135
 136   end
 137