3 OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
5 Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
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.
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.
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
28 let status_line_RE = Pcre.regexp "^(HTTP/\\d\\.\\d) (\\d{3}) (.*)$"
31 (* Warning: keep default values in sync with Http_daemon.respond function *)
32 ?(body = "") ?(headers = [])
33 ?(version = http_version) ?(code = 200) ?status ()
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
42 (* "version code reason_phrase" *)
45 val mutable _version = version
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
55 self#setContents body;
56 self#addHeaders headers
58 method version = _version
59 method setVersion v = _version <- v
63 ignore (status_of_code c); (* sanity check on c *)
65 method status = status_of_code _code
66 method setStatus (s: Http_types.status) = _code <- code_of_status s
69 | None -> Http_misc.reason_phrase_of_code _code
71 method setReason r = _reason <- Some r
75 [string_of_version self#version; string_of_int self#code; self#reason]
76 method setStatusLine s =
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)
83 raise (Invalid_status_line s)
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
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
103 method addHeader ~name ~value =
104 Http_parser.heal_header (name, value);
105 Hashtbl.add _headers name value
107 List.iter (fun (name, value) -> self#addHeader ~name ~value)
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)
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))
128 (fun name _ headers -> (name, self#header ~name)::headers)
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
146 self#statusLine (* status line *)
148 (String.concat (* headers, crlf terminated *)
150 (List.map (fun (h,v) -> h ^ ": " ^ v ^ crlf) self#headers))
152 (Buffer.contents _contentsBuf) (* body *)
153 method serialize outchan =
154 output_string outchan self#toString;