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 let anyize = function
  31   | Some addr -> addr
  32   | None -> Unix.ADDR_INET (Unix.inet_addr_any, -1)
  33
  34 class response
  35   (* Warning: keep default values in sync with Http_daemon.respond function *)
  36   ?(body = "") ?(headers = []) ?(version = http_version)
  37   ?clisockaddr ?srvsockaddr (* optional because response have to be easily
  38                             buildable in callback functions *)
  39   ?(code = 200) ?status
  40   ()
  41   =
  42
  43     (** if no address were supplied for client and/or server, use a foo address
  44     instead *)
  45   let (clisockaddr, srvsockaddr) = (anyize clisockaddr, anyize srvsockaddr) in
  46
  47     (* "version code reason_phrase" *)
  48   object (self)
  49
  50     inherit
  51       Http_message.message ~body ~headers ~version ~clisockaddr ~srvsockaddr
  52
  53     val mutable _code =
  54       match status with
  55       | None -> code
  56       | Some (s: Http_types.status) -> code_of_status s
  57     val mutable _reason: string option = None
  58
  59     method code = _code
  60     method setCode c =
  61       ignore (status_of_code c);  (* sanity check on c *)
  62       _code <- c
  63     method status = status_of_code _code
  64     method setStatus (s: Http_types.status) = _code <- code_of_status s
  65     method reason =
  66       match _reason with
  67       | None -> Http_misc.reason_phrase_of_code _code
  68       | Some r -> r
  69     method setReason r = _reason <- Some r
  70     method statusLine =
  71       String.concat
  72         " "
  73         [string_of_version self#version; string_of_int self#code; self#reason]
  74     method setStatusLine s =
  75       try
  76         let subs = Pcre.extract ~rex:status_line_RE s in
  77         self#setVersion (version_of_string subs.(1));
  78         self#setCode (int_of_string subs.(2));
  79         self#setReason subs.(3)
  80       with Not_found ->
  81         raise (Invalid_status_line s)
  82
  83     method isInformational = is_informational _code
  84     method isSuccess = is_success _code
  85     method isRedirection = is_redirection _code
  86     method isClientError = is_client_error _code
  87     method isServerError = is_server_error _code
  88     method isError = is_error _code
  89
  90       (* FIXME duplication of code between this and send_basic_headers *)
  91     method addBasicHeaders =
  92       self#addHeader ~name:"Date" ~value:(Http_misc.date_822 ());
  93       self#addHeader ~name:"Server" ~value:server_string
  94
  95     method contentType = self#header "Content-Type"
  96     method setContentType t = self#replaceHeader "Content-Type" t
  97     method contentEncoding = self#header "Content-Encoding"
  98     method setContentEncoding e = self#replaceHeader "Content-Encoding" e
  99     method date = self#header "Date"
 100     method setDate d = self#replaceHeader "Date" d
 101     method expires = self#header "Expires"
 102     method setExpires t = self#replaceHeader "Expires" t
 103     method server = self#header "Server"
 104     method setServer s = self#replaceHeader "Server" s
 105
 106     method private fstLineToString =
 107       sprintf
 108         "%s %d %s"
 109         (string_of_version self#version)
 110         self#code
 111         self#reason
 112
 113   end
 114