Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
+open Http_types;;
+open Http_constants;;
open Http_common;;
open Http_daemon;;
+open Printf;;
-exception Invalid_status_line of string
-exception Header_not_found of string
+let status_line_RE = Pcre.regexp "^(HTTP/\\d\\.\\d) (\\d{3}) (.*)$"
- (* TODO sanity checks on set* methods' arguments (e.g. dates 822 compliant,
- code values < 600, ...) *)
-class response =
- let default_code = 200 in
+class response
+ (* Warning: keep default values in sync with Http_daemon.respond function *)
+ ?(body = "") ?(headers = [])
+ ?(version = http_version) ?(code = 200) ?status ()
+ =
(* remove all bindings of 'name' from hashtbl 'tbl' *)
let rec hashtbl_remove_all tbl name =
if not (Hashtbl.mem tbl name) then
if Hashtbl.mem tbl name then hashtbl_remove_all tbl name
in
(* "version code reason_phrase" *)
- let status_line_re = Pcre.regexp "^(HTTP/\d\.\d) (\d{3}) (.*)$" in
object (self)
- val mutable version = Http_common.http_version
- val mutable code = default_code val mutable reason: string option = None
- val contentsBuf = Buffer.create 1024
- val headers = Hashtbl.create 11
-
- method version = version
- method setVersion v = version <- v
-
- method code = code
- method setCode c = code <- c
- method status = status_of_code code
- method setStatus (s: Http_types.status) = code <- code_of_status s
+
+ val mutable _version = version
+ val mutable _code =
+ match status with
+ | None -> code
+ | Some (s: Http_types.status) -> code_of_status s
+ val mutable _reason: string option = None
+ val _contentsBuf = Buffer.create 1024
+ val _headers = Hashtbl.create 11
+
+ initializer
+ self#setContents body;
+ self#addHeaders headers
+
+ method version = _version
+ method setVersion v = _version <- v
+
+ method code = _code
+ method setCode c =
+ ignore (status_of_code c); (* sanity check on c *)
+ _code <- c
+ method status = status_of_code _code
+ method setStatus (s: Http_types.status) = _code <- code_of_status s
method reason =
- match reason with
- | None -> reason_phrase_of_code code
+ match _reason with
+ | None -> Http_misc.reason_phrase_of_code _code
| Some r -> r
- method setReason r = reason <- Some r
+ method setReason r = _reason <- Some r
method statusLine =
String.concat
" "
[string_of_version self#version; string_of_int self#code; self#reason]
method setStatusLine s =
try
- let subs = Pcre.extract ~rex:status_line_re s in
- self#setVersion (Http_common.version_of_string subs.(1));
+ let subs = Pcre.extract ~rex:status_line_RE s in
+ self#setVersion (version_of_string subs.(1));
self#setCode (int_of_string subs.(2));
self#setReason subs.(3)
with Not_found ->
raise (Invalid_status_line s)
- method isInformational = is_informational code
- method isSuccess = is_success code
- method isRedirection = is_redirection code
- method isClientError = is_client_error code
- method isServerError = is_server_error code
- method isError = is_error code
+ method isInformational = is_informational _code
+ method isSuccess = is_success _code
+ method isRedirection = is_redirection _code
+ method isClientError = is_client_error _code
+ method isServerError = is_server_error _code
+ method isError = is_error _code
- method contents = Buffer.contents contentsBuf
+ method contents = Buffer.contents _contentsBuf
method setContents c =
- Buffer.clear contentsBuf;
- Buffer.add_string contentsBuf c
- method contentsBuf = contentsBuf
+ Buffer.clear _contentsBuf;
+ Buffer.add_string _contentsBuf c
+ method contentsBuf = _contentsBuf
method setContentsBuf b =
- Buffer.clear contentsBuf;
- Buffer.add_buffer contentsBuf b
- method addContents s = Buffer.add_string contentsBuf s
- method addContentsBuf b = Buffer.add_buffer contentsBuf b
-
- (** adds an header named 'name' with value 'value', if an header with the
- same name exists, the new value is considered an addition to the header as
- specified in RFC 2616, thus getting value for this header will return a
- comma separated list of values provided via 'addHeader' *)
- method addHeader ~name ~value = Hashtbl.add headers name value
- (** set the value of header 'name' to 'value', removing all previous
- values if any *)
- method replaceHeader ~name ~value = Hashtbl.replace headers name value
- (** remove the header named 'name', please note that this remove all
- values provided for this header *)
- method removeHeader ~name = hashtbl_remove_all headers name
- method hasHeader ~name = Hashtbl.mem headers name
- (** @return value of header 'name', if multiple values were provided for
- header 'name', the return value will be a comma separated list of
- provided values as stated in RFC 2616 *)
+ Buffer.clear _contentsBuf;
+ Buffer.add_buffer _contentsBuf b
+ method addContents s = Buffer.add_string _contentsBuf s
+ method addContentsBuf b = Buffer.add_buffer _contentsBuf b
+
+ method addHeader ~name ~value =
+ Http_parser.heal_header (name, value);
+ Hashtbl.add _headers name value
+ method addHeaders =
+ List.iter (fun (name, value) -> self#addHeader ~name ~value)
+
+ method replaceHeader ~name ~value =
+ Http_parser.heal_header (name, value);
+ Hashtbl.replace _headers name value
+ method replaceHeaders =
+ List.iter (fun (name, value) -> self#replaceHeader ~name ~value)
+
+ (* FIXME duplication of code between this and send_basic_headers *)
+ method addBasicHeaders =
+ self#addHeader ~name:"Date" ~value:(Http_misc.date_822 ());
+ self#addHeader ~name:"Server" ~value:server_string
+ method removeHeader ~name = hashtbl_remove_all _headers name
+ method hasHeader ~name = Hashtbl.mem _headers name
method header ~name =
if not (self#hasHeader name) then
raise (Header_not_found name);
- String.concat ", " (List.rev (Hashtbl.find_all headers name))
- (** @return all headers as a list of pairs <name, value> *)
+ String.concat ", " (List.rev (Hashtbl.find_all _headers name))
method headers =
List.rev
(Hashtbl.fold
(fun name _ headers -> (name, self#header ~name)::headers)
- headers
+ _headers
[])
method contentType = self#header "Content-Type"
method server = self#header "Server"
method setServer s = self#replaceHeader "Server" s
+ method toString =
+ sprintf
+ "%s%s%s%s%s"
+ self#statusLine (* status line *)
+ crlf
+ (String.concat (* headers, crlf terminated *)
+ ""
+ (List.map (fun (h,v) -> h ^ ": " ^ v ^ crlf) self#headers))
+ crlf
+ (Buffer.contents _contentsBuf) (* body *)
method serialize outchan =
- output_string outchan self#statusLine;
- send_CRLF outchan;
- send_headers self#headers outchan;
- send_CRLF outchan;
- Buffer.output_buffer outchan contentsBuf;
+ output_string outchan self#toString;
flush outchan
end
projects / helm.git / blobdiff