X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_response.ml;h=6fc3213254114f63a76a30ca47ec236b327b42a3;hb=7cb90c67bc6f8113188a91ecc29f6db20db5aeb8;hp=5ca7878acf4f8ee4fadf2153e4876316e1873670;hpb=50b702f7ab48c12829a3b7328bcd47491c3c5262;p=helm.git diff --git a/helm/DEVEL/ocaml-http/http_response.ml b/helm/DEVEL/ocaml-http/http_response.ml index 5ca7878ac..6fc321325 100644 --- a/helm/DEVEL/ocaml-http/http_response.ml +++ b/helm/DEVEL/ocaml-http/http_response.ml @@ -25,93 +25,80 @@ open Http_common;; open Http_daemon;; open Printf;; -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 +let status_line_RE = Pcre.regexp "^(HTTP/\\d\\.\\d) (\\d{3}) (.*)$" + +let anyize = function + | Some addr -> addr + | None -> Unix.ADDR_INET (Unix.inet_addr_any, -1) + +class response + (* Warning: keep default values in sync with Http_daemon.respond function *) + ?(body = "") ?(headers = []) ?(version = http_version) + ?clisockaddr ?srvsockaddr (* optional because response have to be easily + buildable in callback functions *) + ?(code = 200) ?status + () + = + + (** if no address were supplied for client and/or server, use a foo address + instead *) + let (clisockaddr, srvsockaddr) = (anyize clisockaddr, anyize srvsockaddr) 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 + (* note that response objects can't be created with a None version *) + inherit + Http_message.message + ~body ~headers ~version:(Some version) ~clisockaddr ~srvsockaddr + + val mutable _code = + match status with + | None -> code + | Some (s: Http_types.status) -> code_of_status s + val mutable _reason: string option = None + + method private getRealVersion = + match self#version with + | None -> + failwith ("Http_response.fstLineToString: " ^ + "can't serialize an HTTP response with no HTTP version defined") + | Some v -> string_of_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 + _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 -> Http_misc.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] + String.concat " " + [self#getRealVersion; 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 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 - - method addHeader ~name ~value = - Http_parser.heal_header (name, value); - Hashtbl.add headers name value - - method replaceHeader ~name ~value = - Http_parser.heal_header (name, value); - Hashtbl.replace headers name value + 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 (* 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)) - 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 @@ -124,19 +111,8 @@ class response = 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#toString; - flush outchan + method private fstLineToString = + sprintf "%s %d %s" self#getRealVersion self#code self#reason end