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 open Printf;;
  25
  26 exception Invalid_status_line of string
  27 exception Header_not_found of string
  28
  29   (* TODO sanity checks on set* methods' arguments (e.g. dates 822 compliant,
  30   code values < 600, ...) *)
  31 class response =
  32   let default_code = 200 in
  33     (* remove all bindings of 'name' from hashtbl 'tbl' *)
  34   let rec hashtbl_remove_all tbl name =
  35     if not (Hashtbl.mem tbl name) then
  36       raise (Header_not_found name);
  37     Hashtbl.remove tbl name;
  38     if Hashtbl.mem tbl name then hashtbl_remove_all tbl name
  39   in
  40     (* "version code reason_phrase" *)
  41   let status_line_re = Pcre.regexp "^(HTTP/\d\.\d) (\d{3}) (.*)$" in
  42   object (self)
  43     val mutable version = http_version
  44     val mutable code = default_code
  45     val mutable reason: string option = None
  46     val contentsBuf = Buffer.create 1024
  47     val headers = Hashtbl.create 11
  48
  49     method version = version
  50     method setVersion v = version <- v
  51
  52     method code = code
  53     method setCode c = code <- c
  54     method status = status_of_code code
  55     method setStatus (s: Http_types.status) = code <- code_of_status s
  56     method reason =
  57       match reason with
  58       | None -> reason_phrase_of_code code
  59       | Some r -> r
  60     method setReason r = reason <- Some r
  61     method statusLine =
  62       String.concat
  63         " "
  64         [string_of_version self#version; string_of_int self#code; self#reason]
  65     method setStatusLine s =
  66       try
  67         let subs = Pcre.extract ~rex:status_line_re s in
  68         self#setVersion (version_of_string subs.(1));
  69         self#setCode (int_of_string subs.(2));
  70         self#setReason subs.(3)
  71       with Not_found ->
  72         raise (Invalid_status_line s)
  73
  74     method isInformational = is_informational code
  75     method isSuccess = is_success code
  76     method isRedirection = is_redirection code
  77     method isClientError = is_client_error code
  78     method isServerError = is_server_error code
  79     method isError = is_error code
  80
  81     method contents = Buffer.contents contentsBuf
  82     method setContents c =
  83       Buffer.clear contentsBuf;
  84       Buffer.add_string contentsBuf c
  85     method contentsBuf = contentsBuf
  86     method setContentsBuf b =
  87       Buffer.clear contentsBuf;
  88       Buffer.add_buffer contentsBuf b
  89     method addContents s = Buffer.add_string contentsBuf s
  90     method addContentsBuf b = Buffer.add_buffer contentsBuf b
  91
  92     method addHeader ~name ~value = Hashtbl.add headers name value
  93       (* FIXME duplication of code between this and send_basic_headers *)
  94     method addBasicHeaders =
  95       self#addHeader ~name:"Date" ~value:(Http_misc.date_822 ());
  96       self#addHeader ~name:"Server" ~value:server_string
  97     method replaceHeader ~name ~value = Hashtbl.replace headers name value
  98     method removeHeader ~name = hashtbl_remove_all headers name
  99     method hasHeader ~name = Hashtbl.mem headers name
 100     method header ~name =
 101       if not (self#hasHeader name) then
 102         raise (Header_not_found name);
 103       String.concat ", " (List.rev (Hashtbl.find_all headers name))
 104     method headers =
 105       List.rev
 106         (Hashtbl.fold
 107           (fun name _ headers -> (name, self#header ~name)::headers)
 108           headers
 109           [])
 110
 111     method contentType = self#header "Content-Type"
 112     method setContentType t = self#replaceHeader "Content-Type" t
 113     method contentEncoding = self#header "Content-Encoding"
 114     method setContentEncoding e = self#replaceHeader "Content-Encoding" e
 115     method date = self#header "Date"
 116     method setDate d = self#replaceHeader "Date" d
 117     method expires = self#header "Expires"
 118     method setExpires t = self#replaceHeader "Expires" t
 119     method server = self#header "Server"
 120     method setServer s = self#replaceHeader "Server" s
 121
 122     method toString =
 123       sprintf
 124         "%s%s%s%s%s"
 125         self#statusLine (* status line *)
 126         crlf
 127         (String.concat  (* headers, crlf terminated *)
 128           ""
 129           (List.map (fun (h,v) -> h ^ ": " ^ v ^ crlf) self#headers))
 130         crlf
 131         (Buffer.contents contentsBuf) (* body *)
 132     method serialize outchan =
 133       output_string outchan self#toString;
 134       flush outchan
 135 (*
 136       (* OLD VERSION *)
 137       output_string outchan self#statusLine;
 138       send_CRLF outchan;
 139       send_headers self#headers outchan;
 140       send_CRLF outchan;
 141       Buffer.output_buffer outchan contentsBuf;
 142       flush outchan
 143 *)
 144
 145   end
 146