X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_response.ml;h=a0bda358250158ca56ceaec0eadf0d3e1b965b67;hb=b8bfa7d845726a0421f0314cbea87d3f79a752e5;hp=3c58f13fa033d244e77992bf2c66243761b9bdf9;hpb=9a072f192471daeca8cb409e991f0073b1d4271f;p=helm.git diff --git a/helm/DEVEL/ocaml-http/http_response.ml b/helm/DEVEL/ocaml-http/http_response.ml index 3c58f13fa..a0bda3582 100644 --- a/helm/DEVEL/ocaml-http/http_response.ml +++ b/helm/DEVEL/ocaml-http/http_response.ml @@ -19,17 +19,19 @@ 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 @@ -38,74 +40,93 @@ class response = 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_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 + 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 - - method addHeader ~name ~value = Hashtbl.add headers name value + 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 replaceHeader ~name ~value = Hashtbl.replace headers name value - method removeHeader ~name = hashtbl_remove_all headers name - method hasHeader ~name = Hashtbl.mem headers name + 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)) + 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" @@ -128,19 +149,10 @@ class response = "" (List.map (fun (h,v) -> h ^ ": " ^ v ^ crlf) self#headers)) crlf - (Buffer.contents contentsBuf) (* body *) + (Buffer.contents _contentsBuf) (* body *) method serialize outchan = output_string outchan self#toString; flush outchan -(* - (* OLD VERSION *) - output_string outchan self#statusLine; - send_CRLF outchan; - send_headers self#headers outchan; - send_CRLF outchan; - Buffer.output_buffer outchan contentsBuf; - flush outchan -*) end