--- /dev/null
+
+(*
+ OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
+
+ Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+*)
+
+open Http_common;;
+open Http_daemon;;
+
+exception Invalid_status_line of string
+exception Header_not_found of string
+
+ (* TODO sanity checks on set* methods' arguments (e.g. dates 822 compliant,
+ code values < 600, ...) *)
+class response =
+ let default_code = 200 in
+ (* remove all bindings of 'name' from hashtbl 'tbl' *)
+ let rec hashtbl_remove_all tbl name =
+ if not (Hashtbl.mem tbl name) then
+ raise (Header_not_found name);
+ Hashtbl.remove tbl name;
+ 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
+ method reason =
+ match reason with
+ | None -> reason_phrase_of_code code
+ | Some r -> 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));
+ 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 contents = Buffer.contents contentsBuf
+ method setContents c =
+ 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 *)
+ 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> *)
+ method headers =
+ List.rev
+ (Hashtbl.fold
+ (fun name _ headers -> (name, self#header ~name)::headers)
+ headers
+ [])
+
+ method contentType = self#header "Content-Type"
+ method setContentType t = self#replaceHeader "Content-Type" t
+ method contentEncoding = self#header "Content-Encoding"
+ method setContentEncoding e = self#replaceHeader "Content-Encoding" e
+ method date = self#header "Date"
+ method setDate d = self#replaceHeader "Date" d
+ method expires = self#header "Expires"
+ method setExpires t = self#replaceHeader "Expires" t
+ method server = self#header "Server"
+ method setServer s = self#replaceHeader "Server" s
+
+ method serialize outchan =
+ output_string outchan self#statusLine;
+ send_CRLF outchan;
+ send_headers self#headers outchan;
+ send_CRLF outchan;
+ Buffer.output_buffer outchan contentsBuf;
+ flush outchan
+
+ end
+
projects / helm.git / blobdiff