(*
  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