(* netcgi.ml

   Copyright (C) 2005-2006

     Christophe Troestler
     email: Christophe.Troestler@umh.ac.be
     WWW: http://math.umh.ac.be/an/

   This library is free software; see the file LICENSE for more information.

   This library 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 file
   LICENSE for more details.
*)



(* Argument
 ***********************************************************************)

(* This is a simplified mix of Netmime.mime_header_ro and
   Netmime.mime_body_ro *)
class type cgi_argument = Netcgi_common.cgi_argument

(* @deprecated *)
class type rw_cgi_argument = Netcgi_common.rw_cgi_argument
class simple_argument = Netcgi_common.simple_arg
class mime_argument ?work_around_backslash_bug name value
  = Netcgi_common.mime_arg ?work_around_backslash_bug ~name value


module Argument =
struct
  type t = cgi_argument

  exception Oversized = Netcgi_common.Oversized

  let simple (name:string) value =
    (new Netcgi_common.simple_arg name value :> cgi_argument)

  let mime ?work_around_backslash_bug ?name (m: Netmime.mime_message) =
    (new Netcgi_common.mime_arg ?work_around_backslash_bug ?name m
     :> cgi_argument)

  (* Manipulation of arguments *)

  let clone ?name ?value ?msg (arg:cgi_argument) =
    let name = match name with None -> arg#name | Some n -> n in
    match arg#representation with
    | `Simple _ ->
	let value = match value with None -> arg#value | Some v -> v in
	simple name value
    | `MIME message ->
	let m = match msg with
	  | Some m -> m
	  | None -> (match value with
		     | None -> message
		     | Some v -> (new Netmime.basic_mime_header [],
				  `Body(new Netmime.memory_mime_body v))) in
	mime ~name m


  let set new_args (args: cgi_argument list) =
    let names = List.map (fun a -> a#name) new_args in
    let rec filter args' = function
      | [] -> args'
      | a :: tl ->
	  if List.mem a#name names then filter args' tl
	  else filter (a :: args') tl  in
    filter new_args args
end


(* Cookies
 ***********************************************************************)

module Cookie = Nethttp.Cookie


(* Config
 ***********************************************************************)

type http_method =
    [`GET | `HEAD | `POST | `DELETE | `PUT]

type config = Netcgi_common.config = {
  tmp_directory : string;
  tmp_prefix : string;
  permitted_http_methods : http_method list;
  permitted_input_content_types : string list;
  input_content_length_limit : int;
  max_arguments : int;
  workarounds :
    [ `MSIE_Content_type_bug | `Backslash_bug
    | `Work_around_MSIE_Content_type_bug
    | `Work_around_backslash_bug ] list;
  default_exn_handler : bool;
}

let default_config =
  {
    tmp_directory = Netsys_tmp.tmp_directory();
    tmp_prefix = "netcgi";
    permitted_http_methods = [`GET; `HEAD; `POST];
    permitted_input_content_types = [ "multipart/form-data";
				      "application/x-www-form-urlencoded" ];
    input_content_length_limit = max_int;
    max_arguments = 10000;
    workarounds = [ `MSIE_Content_type_bug; `Backslash_bug ];
    default_exn_handler = true;
  }


(* Environment
 ***********************************************************************)

class type cgi_environment =
object
  method cgi_gateway_interface      : string
  method cgi_server_name            : string
  method cgi_server_port            : int option
  method cgi_server_protocol        : string
  method cgi_server_software        : string
  method cgi_request_method         : string
  method cgi_script_name            : string
  method cgi_path_info              : string
  method cgi_path_translated        : string
  method cgi_auth_type              : string
  method cgi_remote_addr            : string
  method cgi_remote_host            : string
  method cgi_remote_user            : string
  method cgi_remote_ident           : string
  method cgi_query_string           : string
  method protocol : Nethttp.protocol
  method cgi_property : ?default:string -> string -> string
  method cgi_properties : (string * string) list
  method cgi_https : bool

  method input_header : Netmime.mime_header
  method input_header_field : ?default:string -> string -> string
  method multiple_input_header_field : string -> string list
  method input_header_fields : (string * string) list
  method cookie : string -> Cookie.t
  method cookies : Cookie.t list
  method user_agent : string
  method input_content_length : int
  method input_content_type_string : string
  method input_content_type :
    unit -> string * (string * Netmime_string.s_param) list

  method output_header : Netmime.mime_header
  method output_header_field : ?default:string -> string -> string
  method multiple_output_header_field : string -> string list
  method output_header_fields : (string * string) list
  method set_output_header_field : string -> string -> unit
  method set_multiple_output_header_field : string -> string list -> unit
  method set_output_header_fields : (string * string) list -> unit
  method set_status : Nethttp.http_status -> unit
  method send_output_header : unit -> unit

  method output_ch : Netchannels.out_obj_channel (* deprecated *)
  method out_channel : Netchannels.out_obj_channel

  method log_error : string -> unit
  method config : config
end



(* CGI object
 ***********************************************************************)

type other_url_spec = Netcgi_common.other_url_spec
type query_string_spec = Netcgi_common.query_string_spec
type cache_control = Netcgi_common.cache_control


class type cgi =
object
  method argument : string -> cgi_argument
  method argument_value : ?default:string -> string -> string
  method argument_exists : string -> bool
  method multiple_argument : string -> cgi_argument list
  method arguments : cgi_argument list

  method environment : cgi_environment
  method request_method :
    [`GET | `HEAD | `POST | `DELETE | `PUT of cgi_argument]
  method finalize  : unit -> unit

  method url : ?protocol:Nethttp.protocol ->
               ?with_authority:other_url_spec ->        (* default: `Env *)
               ?with_script_name:other_url_spec ->      (* default: `Env *)
               ?with_path_info:other_url_spec ->        (* default: `Env *)
               ?with_query_string:query_string_spec ->  (* default: `None *)
               unit -> string

  method set_header :
    ?status:Nethttp.http_status ->
    ?content_type:string ->
    ?content_length:int ->
    ?set_cookie:Nethttp.cookie list -> (* deprecated *)
    ?set_cookies:Cookie.t list ->
    ?cache:cache_control ->
    ?filename:string ->
    ?language:string ->
    ?script_type:string ->
    ?style_type:string ->
    ?fields:(string * string list) list ->
    unit -> unit

  method set_redirection_header :
    ?set_cookies:Cookie.t list ->
    ?fields:(string * string list) list ->
    string -> unit

  method output : Netchannels.trans_out_obj_channel (* deprecated *)
  method out_channel : Netchannels.trans_out_obj_channel

  method at_exit : (unit -> unit) -> unit
end


class type cgi_activation = cgi


(* Connectors *)

type output_type = Netcgi_common.output_type
type arg_store = Netcgi_common.arg_store
type exn_handler = cgi_environment -> (unit -> unit) -> unit

type connection_directive =
    [ `Conn_close | `Conn_close_linger | `Conn_keep_alive
    | `Conn_error of exn
    ]

let buffered_transactional_outtype =
  `Transactional (fun config ch -> new Netchannels.buffered_trans_channel ch)

let buffered_transactional_optype =
  buffered_transactional_outtype

let tempfile_transactional_outtype =
  `Transactional
    (fun config ch ->
       let tmp_directory = config.tmp_directory in
       let tmp_prefix = config.tmp_prefix in
       new Netchannels.tempfile_trans_channel ~tmp_directory ~tmp_prefix ch
    )

let tempfile_transactional_optype =
  tempfile_transactional_outtype
