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