helm/DEVEL/ocaml-http/http_response.ml

   1
   2 (*
   3   OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
   4
   5   Copyright (C) <2002-2005> 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 Library General Public License as
   9   published by the Free Software Foundation, version 2.
  10
  11   This program is distributed in the hope that it will be useful,
  12   but WITHOUT ANY WARRANTY; without even the implied warranty of
  13   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14   GNU Library General Public License for more details.
  15
  16   You should have received a copy of the GNU Library General Public
  17   License along with this program; if not, write to the Free Software
  18   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  19   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       (* note that response objects can't be created with a None version *)
  51     inherit
  52       Http_message.message
  53         ~body ~headers ~version:(Some version) ~clisockaddr ~srvsockaddr
  54
  55     val mutable _code =
  56       match status with
  57       | None -> code
  58       | Some (s: Http_types.status) -> code_of_status s
  59     val mutable _reason: string option = None
  60
  61     method private getRealVersion =
  62       match self#version with
  63       | None ->
  64           failwith ("Http_response.fstLineToString: " ^
  65             "can't serialize an HTTP response with no HTTP version defined")
  66       | Some v -> string_of_version v
  67
  68     method code = _code
  69     method setCode c =
  70       ignore (status_of_code c);  (* sanity check on c *)
  71       _code <- c
  72     method status = status_of_code _code
  73     method setStatus (s: Http_types.status) = _code <- code_of_status s
  74     method reason =
  75       match _reason with
  76       | None -> Http_misc.reason_phrase_of_code _code
  77       | Some r -> r
  78     method setReason r = _reason <- Some r
  79     method statusLine =
  80       String.concat " "
  81         [self#getRealVersion; string_of_int self#code; self#reason]
  82     method setStatusLine s =
  83       try
  84         let subs = Pcre.extract ~rex:status_line_RE s in
  85         self#setVersion (version_of_string subs.(1));
  86         self#setCode (int_of_string subs.(2));
  87         self#setReason subs.(3)
  88       with Not_found ->
  89         raise (Invalid_status_line s)
  90
  91     method isInformational = is_informational _code
  92     method isSuccess = is_success _code
  93     method isRedirection = is_redirection _code
  94     method isClientError = is_client_error _code
  95     method isServerError = is_server_error _code
  96     method isError = is_error _code
  97
  98       (* FIXME duplication of code between this and send_basic_headers *)
  99     method addBasicHeaders =
 100       self#addHeader ~name:"Date" ~value:(Http_misc.date_822 ());
 101       self#addHeader ~name:"Server" ~value:server_string
 102
 103     method contentType = self#header "Content-Type"
 104     method setContentType t = self#replaceHeader "Content-Type" t
 105     method contentEncoding = self#header "Content-Encoding"
 106     method setContentEncoding e = self#replaceHeader "Content-Encoding" e
 107     method date = self#header "Date"
 108     method setDate d = self#replaceHeader "Date" d
 109     method expires = self#header "Expires"
 110     method setExpires t = self#replaceHeader "Expires" t
 111     method server = self#header "Server"
 112     method setServer s = self#replaceHeader "Server" s
 113
 114     method private fstLineToString =
 115       sprintf "%s %d %s" self#getRealVersion self#code self#reason
 116
 117   end
 118