]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/ocaml-http/http_response.ml
1. syntax error fixed
[helm.git] / 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