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_types;;
  23 open Http_constants;;
  24 open Http_common;;
  25 open Http_daemon;;
  26 open Printf;;
  27
  28 class response =
  29   let default_code = 200 in
  30     (* remove all bindings of 'name' from hashtbl 'tbl' *)
  31   let rec hashtbl_remove_all tbl name =
  32     if not (Hashtbl.mem tbl name) then
  33       raise (Header_not_found name);
  34     Hashtbl.remove tbl name;
  35     if Hashtbl.mem tbl name then hashtbl_remove_all tbl name
  36   in
  37     (* "version code reason_phrase" *)
  38   let status_line_re = Pcre.regexp "^(HTTP/\\d\\.\\d) (\\d{3}) (.*)$" in
  39   object (self)
  40     val mutable version = http_version
  41     val mutable code = default_code
  42     val mutable reason: string option = None
  43     val contentsBuf = Buffer.create 1024
  44     val headers = Hashtbl.create 11
  45
  46     method version = version
  47     method setVersion v = version <- v
  48
  49     method code = code
  50     method setCode c =
  51       ignore (status_of_code c);  (* sanity check on c *)
  52       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 -> Http_misc.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 (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 =
  92       Http_parser.heal_header (name, value);
  93       Hashtbl.add headers name value
  94
  95     method replaceHeader ~name ~value =
  96       Http_parser.heal_header (name, value);
  97       Hashtbl.replace headers name value
  98
  99       (* FIXME duplication of code between this and send_basic_headers *)
 100     method addBasicHeaders =
 101       self#addHeader ~name:"Date" ~value:(Http_misc.date_822 ());
 102       self#addHeader ~name:"Server" ~value:server_string
 103     method removeHeader ~name = hashtbl_remove_all headers name
 104     method hasHeader ~name = Hashtbl.mem headers name
 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     method headers =
 110       List.rev
 111         (Hashtbl.fold
 112           (fun name _ headers -> (name, self#header ~name)::headers)
 113           headers
 114           [])
 115
 116     method contentType = self#header "Content-Type"
 117     method setContentType t = self#replaceHeader "Content-Type" t
 118     method contentEncoding = self#header "Content-Encoding"
 119     method setContentEncoding e = self#replaceHeader "Content-Encoding" e
 120     method date = self#header "Date"
 121     method setDate d = self#replaceHeader "Date" d
 122     method expires = self#header "Expires"
 123     method setExpires t = self#replaceHeader "Expires" t
 124     method server = self#header "Server"
 125     method setServer s = self#replaceHeader "Server" s
 126
 127     method toString =
 128       sprintf
 129         "%s%s%s%s%s"
 130         self#statusLine (* status line *)
 131         crlf
 132         (String.concat  (* headers, crlf terminated *)
 133           ""
 134           (List.map (fun (h,v) -> h ^ ": " ^ v ^ crlf) self#headers))
 135         crlf
 136         (Buffer.contents contentsBuf) (* body *)
 137     method serialize outchan =
 138       output_string outchan self#toString;
 139       flush outchan
 140
 141   end
 142