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
  44     val mutable reason: string option = None
  45     val contentsBuf = Buffer.create 1024
  46     val headers = Hashtbl.create 11
  47
  48     method version = version
  49     method setVersion v = version <- v
  50
  51     method code = code
  52     method setCode c = code <- c
  53     method status = status_of_code code
  54     method setStatus (s: Http_types.status) = code <- code_of_status s
  55     method reason =
  56       match reason with
  57       | None -> reason_phrase_of_code code
  58       | Some r -> r
  59     method setReason r = reason <- Some r
  60     method statusLine =
  61       String.concat
  62         " "
  63         [string_of_version self#version; string_of_int self#code; self#reason]
  64     method setStatusLine s =
  65       try
  66         let subs = Pcre.extract ~rex:status_line_re s in
  67         self#setVersion (Http_common.version_of_string subs.(1));
  68         self#setCode (int_of_string subs.(2));
  69         self#setReason subs.(3)
  70       with Not_found ->
  71         raise (Invalid_status_line s)
  72
  73     method isInformational = is_informational code
  74     method isSuccess = is_success code
  75     method isRedirection = is_redirection code
  76     method isClientError = is_client_error code
  77     method isServerError = is_server_error code
  78     method isError = is_error code
  79
  80     method contents = Buffer.contents contentsBuf
  81     method setContents c =
  82       Buffer.clear contentsBuf;
  83       Buffer.add_string contentsBuf c
  84     method contentsBuf = contentsBuf
  85     method setContentsBuf b =
  86       Buffer.clear contentsBuf;
  87       Buffer.add_buffer contentsBuf b
  88     method addContents s = Buffer.add_string contentsBuf s
  89     method addContentsBuf b = Buffer.add_buffer contentsBuf b
  90
  91     method addHeader ~name ~value = Hashtbl.add headers name value
  92       (* FIXME duplication of code between this and send_basic_headers *)
  93     method addBasicHeaders =
  94       self#addHeader ~name:"Date" ~value:(Http_misc.date_822 ());
  95       self#addHeader ~name:"Server" ~value:(Http_common.server_string)
  96     method replaceHeader ~name ~value = Hashtbl.replace headers name value
  97     method removeHeader ~name = hashtbl_remove_all headers name
  98     method hasHeader ~name = Hashtbl.mem headers name
  99     method header ~name =
 100       if not (self#hasHeader name) then
 101         raise (Header_not_found name);
 102       String.concat ", " (List.rev (Hashtbl.find_all headers name))
 103     method headers =
 104       List.rev
 105         (Hashtbl.fold
 106           (fun name _ headers -> (name, self#header ~name)::headers)
 107           headers
 108           [])
 109
 110     method contentType = self#header "Content-Type"
 111     method setContentType t = self#replaceHeader "Content-Type" t
 112     method contentEncoding = self#header "Content-Encoding"
 113     method setContentEncoding e = self#replaceHeader "Content-Encoding" e
 114     method date = self#header "Date"
 115     method setDate d = self#replaceHeader "Date" d
 116     method expires = self#header "Expires"
 117     method setExpires t = self#replaceHeader "Expires" t
 118     method server = self#header "Server"
 119     method setServer s = self#replaceHeader "Server" s
 120
 121     method serialize outchan =
 122       output_string outchan self#statusLine;
 123       send_CRLF outchan;
 124       send_headers self#headers outchan;
 125       send_CRLF outchan;
 126       Buffer.output_buffer outchan contentsBuf;
 127       flush outchan
 128
 129   end
 130