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

    method addHeader ~name ~value = Hashtbl.add headers 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:(Http_common.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 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
    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