(* netcgi_compat.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.
*)
(* $Id: netcgi_compat.ml,v 1.12 2005/11/04 00:52:05 chris_77 Exp $ *)
exception Not_implemented of string
module Netcgi_env =
struct
type input_mode = [ `Standard (* | `Direct *) ]
type input_state =
[ `Start
| `Receiving_header | `Received_header
| `Receiving_body | `Received_body ]
type output_mode = [ `Standard (* | `Direct *) ]
type output_state =
[ `Start
| `Sending_header | `Sent_header
| `Sending_body | `Sent_body
| `Sending_part_header | `Sent_part_header
| `Sending_part_body | `Sent_part_body
| `End
]
type protocol_version = Nethttp.protocol_version
type protocol_attribute = Nethttp.protocol_attribute
type protocol = Nethttp.protocol
type workaround =
[ `Work_around_MSIE_Content_type_bug | `Work_around_backslash_bug ]
type cgi_config = {
tmp_directory : string;
tmp_prefix : string;
permitted_http_methods : string list;
permitted_input_content_types : string list;
input_content_length_limit : int;
workarounds : workaround list;
}
let default_config =
let default_tmp_directory = Netsys_tmp.tmp_directory() in
{
tmp_directory = default_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;
workarounds = [ `Work_around_MSIE_Content_type_bug;
`Work_around_backslash_bug ]
}
let meth_of_string = function
| "GET" -> `GET
| "HEAD" -> `HEAD
| "POST" -> `POST
| "DELETE" -> `DELETE
| "PUT" -> `PUT
| m -> raise(Not_implemented ("Netcgi_env.of_compat_config: HTTP method name not convertible: " ^ m))
let string_of_meth = function
| `GET -> "GET"
| `HEAD -> "HEAD"
| `POST -> "POST"
| `DELETE -> "DELETE"
| `PUT -> "PUT"
let of_compat_config c = {
Netcgi.tmp_directory = c.tmp_directory;
Netcgi.tmp_prefix = c.tmp_prefix;
Netcgi.permitted_http_methods =
List.map meth_of_string c.permitted_http_methods;
Netcgi.permitted_input_content_types = c.permitted_input_content_types;
Netcgi.input_content_length_limit = c.input_content_length_limit;
Netcgi.max_arguments = 10000;
Netcgi.workarounds =
List.map (function
| `Work_around_MSIE_Content_type_bug -> `MSIE_Content_type_bug
| `Work_around_backslash_bug -> `Backslash_bug
) c.workarounds;
Netcgi.default_exn_handler = false
}
let to_compat_config c = {
tmp_directory = c.Netcgi.tmp_directory;
tmp_prefix = c.Netcgi.tmp_prefix;
permitted_http_methods =
List.map string_of_meth c.Netcgi.permitted_http_methods;
permitted_input_content_types = c.Netcgi.permitted_input_content_types;
input_content_length_limit = c.Netcgi.input_content_length_limit;
workarounds =
List.map (function
| `MSIE_Content_type_bug -> `Work_around_MSIE_Content_type_bug
| `Backslash_bug -> `Work_around_backslash_bug
| ( `Work_around_MSIE_Content_type_bug
| `Work_around_backslash_bug ) as x -> x
) c.Netcgi.workarounds
}
class type cgi_environment =
object
method config : cgi_config
method cgi_gateway_interface : string
method cgi_server_software : string
method cgi_server_name : string
method cgi_server_protocol : string
method cgi_server_port : int option
method cgi_request_method : string
method cgi_path_info : string
method cgi_path_translated : string
method cgi_script_name : string
method cgi_query_string : string
method cgi_remote_host : string
method cgi_remote_addr : string
method cgi_auth_type : string
method cgi_remote_user : string
method cgi_remote_ident : string
method cgi_property : ?default:string -> string -> string
method cgi_properties : (string * string) list
method cgi_https : bool
method cgi_request_uri : string
method protocol : protocol
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 user_agent : string
method cookies : (string * string) list
method input_content_length : int
method input_content_type_string : string
method input_content_type : (string * (string * Mimestring.s_param) list)
method input_ch : Netchannels.in_obj_channel
method input_state : input_state
method set_input_state : input_state -> unit
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
method output_state : output_state
method set_output_state : output_state -> unit
method log_error : string -> unit
end
class to_compat_environment (env:Netcgi.cgi_environment) =
let config = to_compat_config env#config in
object
val env = env
method config = config
method cgi_gateway_interface = env#cgi_gateway_interface
method cgi_server_software = env#cgi_server_software
method cgi_server_name = env#cgi_server_name
method cgi_server_protocol = env#cgi_server_protocol
method cgi_server_port = env#cgi_server_port
method cgi_request_method = env#cgi_request_method
method cgi_path_info = env#cgi_path_info
method cgi_path_translated = env#cgi_path_translated
method cgi_script_name = env#cgi_script_name
method cgi_query_string = env#cgi_query_string
method cgi_remote_host = env#cgi_remote_host
method cgi_remote_addr = env#cgi_remote_addr
method cgi_auth_type = env#cgi_auth_type
method cgi_remote_user = env#cgi_remote_user
method cgi_remote_ident = env#cgi_remote_ident
method cgi_property = env#cgi_property
method cgi_properties = env#cgi_properties
method cgi_https = env#cgi_https
method cgi_request_uri = env#cgi_property ~default:"" "REQUEST_URI"
method protocol = env#protocol
method input_header = env#input_header
method input_header_field = env#input_header_field
method multiple_input_header_field = env#multiple_input_header_field
method input_header_fields = env#input_header_fields
method user_agent = env#user_agent
method cookies =
List.map (fun c -> (Netcgi.Cookie.name c, Netcgi.Cookie.value c))
env#cookies
method input_content_length = env#input_content_length
method input_content_type_string = env#input_content_type_string
method input_content_type = env#input_content_type()
method input_ch =
(raise (Not_implemented "input_ch (of cgi_environment)")
: Netchannels.in_obj_channel)
method input_state =
(raise (Not_implemented "input_state (of cgi_environment)")
: input_state)
method set_input_state =
(raise (Not_implemented "set_input_state (of cgi_environment)")
: input_state -> unit)
method output_header = env#output_header
method output_header_field = env#output_header_field
method multiple_output_header_field = env#multiple_output_header_field
method output_header_fields = env#output_header_fields
method set_output_header_field = env#set_output_header_field
method set_multiple_output_header_field =
env#set_multiple_output_header_field
method set_output_header_fields = env#set_output_header_fields
method set_status = env#set_status
method send_output_header = env#send_output_header
method output_ch = env#out_channel
method output_state =
(raise (Not_implemented "output_state (of cgi_environment)")
: output_state)
method set_output_state =
(raise (Not_implemented "set_output_state (of cgi_environment)")
: output_state -> unit)
method log_error = env#log_error
end
let to_compat_environment =
new to_compat_environment
let of_compat_environment (env:cgi_environment) : Netcgi.cgi_environment =
object(self)
method config = of_compat_config env#config
method cgi_gateway_interface = env#cgi_gateway_interface
method cgi_server_software = env#cgi_server_software
method cgi_server_name = env#cgi_server_name
method cgi_server_protocol = env#cgi_server_protocol
method cgi_server_port = env#cgi_server_port
method cgi_request_method = env#cgi_request_method
method cgi_path_info = env#cgi_path_info
method cgi_path_translated = env#cgi_path_translated
method cgi_script_name = env#cgi_script_name
method cgi_query_string = env#cgi_query_string
method cgi_remote_host = env#cgi_remote_host
method cgi_remote_addr = env#cgi_remote_addr
method cgi_auth_type = env#cgi_auth_type
method cgi_remote_user = env#cgi_remote_user
method cgi_remote_ident = env#cgi_remote_ident
method cgi_property = env#cgi_property
method cgi_properties = env#cgi_properties
method cgi_https = env#cgi_https
method protocol = env#protocol
method input_header = env#input_header
method input_header_field = env#input_header_field
method multiple_input_header_field = env#multiple_input_header_field
method input_header_fields = env#input_header_fields
method user_agent = env#user_agent
method input_content_length = env#input_content_length
method input_content_type_string = env#input_content_type_string
method input_content_type() = env#input_content_type
method output_header = env#output_header
method output_header_field = env#output_header_field
method multiple_output_header_field = env#multiple_output_header_field
method output_header_fields = env#output_header_fields
method set_output_header_field = env#set_output_header_field
method set_multiple_output_header_field =
env#set_multiple_output_header_field
method set_output_header_fields = env#set_output_header_fields
method set_status = env#set_status
val mutable header_sent = false
method send_output_header() =
if not header_sent then (
env#send_output_header();
header_sent <- true
)
method output_ch = env#output_ch
method out_channel = env#output_ch
method log_error = env#log_error
method cookies =
List.map
(fun (n,v) -> Netcgi_common.Cookie.make n v)
env#cookies
method cookie n =
List.find (fun c -> Netcgi_common.Cookie.name c = n) self#cookies
end
end
module Netcgi_types =
struct
class type simple_message = Netmime.mime_body
type store = [ `Memory | `File of string ]
type representation =
[ `Simple of simple_message | `MIME of Netmime.mime_message ]
class type cgi_argument =
object
method name : string
method value : string
method open_value_rd : unit -> Netchannels.in_obj_channel
method ro : bool
method store : store
method content_type : string
method content_type_params : (string * Mimestring.s_param) list
method charset : string
method filename : string option
method representation : representation
method finalize : unit -> unit
method set_value : string -> unit
method open_value_wr : unit -> Netchannels.out_obj_channel
end
let to_compat_argument (arg:Netcgi.cgi_argument) =
object
val arg = arg
method name = arg#name
method value = arg#value
method open_value_rd = arg#open_value_rd
method ro = true
method store = arg#store
method content_type = fst(arg#content_type())
method content_type_params = snd(arg#content_type())
method charset = arg#charset
method filename = arg#filename
method representation = arg#representation
method finalize = arg#finalize
method set_value =
(raise(Netmime.Immutable "Netcgi_types.cgi_argument"): string -> unit)
method open_value_wr =
(raise(Netmime.Immutable "Netcgi_types.cgi_argument"):
unit -> Netchannels.out_obj_channel)
end
let of_compat_argument (arg:cgi_argument) : Netcgi.cgi_argument =
object
val arg = arg
method name = arg#name
method value = arg#value
method open_value_rd = arg#open_value_rd
method store = arg#store
method content_type () = (arg#content_type, arg#content_type_params)
method charset = arg#charset
method filename = arg#filename
method representation = arg#representation
method finalize = arg#finalize
end
type cgi_cookie = Nethttp.netscape_cookie = {
cookie_name : string;
cookie_value : string;
cookie_expires : float option;
cookie_domain : string option;
cookie_path : string option;
cookie_secure : bool;
}
type status = Nethttp.http_status
type request_method = [ `GET | `HEAD | `POST | `DELETE
| `PUT of cgi_argument ]
type cache_control = [ `No_cache | `Max_age of int | `Unspecified ]
type query_string_spec =
[ `Initial | `Current | `Args of cgi_argument list | `None ]
type other_url_spec = [ `Env | `This of string | `None ]
class type cgi_activation =
object
method environment : Netcgi_env.cgi_environment
method request_method : request_method
method initial_arguments : (string * cgi_argument) list
method initial_argument : string -> cgi_argument
method initial_argument_value : ?default:string -> string -> string
method initial_multiple_argument : string -> cgi_argument list
method arguments : (string * cgi_argument) list
method argument : string -> cgi_argument
method argument_value : ?default:string -> string -> string
method multiple_argument : string -> cgi_argument list
method set_arguments : ?fin:bool -> cgi_argument list -> unit
method update_argument : ?fin:bool -> cgi_argument -> unit
method update_multiple_argument : ?fin:bool -> cgi_argument list -> unit
method delete_argument : ?fin:bool -> string -> unit
method url :
?protocol:Netcgi_env.protocol ->
?with_authority:other_url_spec ->
?with_script_name:other_url_spec ->
?with_path_info:other_url_spec ->
?with_query_string:query_string_spec ->
unit -> string
method output : Netchannels.trans_out_obj_channel
method set_header :
?status:status ->
?content_type:string ->
?cache:cache_control ->
?filename:string ->
?language:string ->
?script_type:string ->
?style_type:string ->
?set_cookie:cgi_cookie list ->
?fields:(string * string list) list ->
unit -> unit
method set_redirection_header : string -> unit
method finalize : unit -> unit
end
class to_compat_activation (cgi:Netcgi.cgi) =
object
val env = Netcgi_env.to_compat_environment cgi#environment
val args = List.map to_compat_argument cgi#arguments
(* FIXME: the curr_args should duplicate the body and header of
initial ones -- need to duplicate the files... :( *)
val mutable curr_args =
List.map to_compat_argument cgi#arguments
val cgi = cgi
method environment = env
method request_method : request_method =
match cgi#request_method with
| `GET | `HEAD | `POST | `DELETE as m -> m
| `PUT cgi -> `PUT(to_compat_argument cgi)
method initial_arguments = List.map (fun a -> (a#name, a)) args
method initial_argument name =
List.find (fun a -> a#name = name) args
method initial_argument_value ?default name =
try (List.find (fun a -> a#name = name) args)#value
with Not_found -> (match default with
| None -> raise Not_found
| Some d -> d)
method initial_multiple_argument name =
List.filter (fun a -> a#name = name) args
method arguments = List.map (fun a -> (a#name, a)) curr_args
method argument name =
List.find (fun a -> a#name = name) curr_args
method argument_value ?default name =
try (List.find (fun a -> a#name = name) curr_args)#value
with Not_found -> (match default with
| None -> raise Not_found
| Some d -> d)
method multiple_argument name =
List.filter (fun a -> a#name = name) curr_args
method set_arguments ?(fin=true) new_args =
if fin then
List.iter (fun a -> if not(List.mem a new_args) then a#finalize())
curr_args;
curr_args <- new_args
method update_argument ?(fin=true) new_arg =
let name = new_arg#name in
let keep a =
if fin && a#name = name && a <> new_arg then (a#finalize(); false)
else a#name <> name in
curr_args <- new_arg :: (List.filter keep curr_args)
(* All arguments in [arglist] must have the same name. *)
method update_multiple_argument ?(fin=true) arglist =
match arglist with
| [] -> ()
| a0 :: tl ->
let name = a0#name in
if List.exists (fun a -> a#name <> name) tl then
invalid_arg "update_multiple_argument";
let keep a =
if fin && a#name = name && not(List.mem a arglist) then
(a#finalize(); false)
else a#name <> name in
curr_args <- arglist @ List.filter keep curr_args
method delete_argument ?(fin=true) name =
let keep a =
if fin && a#name = name then (a#finalize(); false)
else a#name <> name in
curr_args <- List.filter keep curr_args
method url ?protocol ?with_authority ?with_script_name ?with_path_info
?(with_query_string=(`None: query_string_spec)) () =
cgi#url ?protocol ?with_authority ?with_script_name
?with_path_info
~with_query_string:(
match with_query_string with
| `Initial -> `Env
| `Current -> `This(List.map of_compat_argument curr_args)
| `Args args -> `This(List.map of_compat_argument args)
| `None -> `None)
()
method output = cgi#out_channel
method set_header ?status ?content_type ?cache ?filename
?language ?script_type ?style_type ?(set_cookie=[]) ?fields () =
let now = Unix.time() in
let make_cookie c =
Netcgi.Cookie.make
?domain:c.cookie_domain
?max_age:(match c.cookie_expires with
| None -> None
| Some t -> Some(truncate(t -. now)))
?path:c.cookie_path
~secure:c.cookie_secure
c.cookie_name c.cookie_value in
cgi#set_header ?status ?content_type
~set_cookies:(List.map make_cookie set_cookie)
?cache ?filename ?language ?script_type ?style_type ?fields ()
method set_redirection_header loc =
cgi#set_redirection_header loc
method finalize () =
List.iter (fun a -> a#finalize()) args;
List.iter (fun a -> a#finalize()) curr_args;
cgi#finalize()
end
let to_compat_activation = new to_compat_activation
let of_compat_activation (cgi_act:cgi_activation) =
let env = Netcgi_env.of_compat_environment(cgi_act#environment) in
object(self)
(* We have no idea of the output_type of [cgi_act] so we
initialize with [`Direct] and override [out_channel]. *)
inherit Netcgi_common.cgi env (`Direct "")
(match cgi_act#request_method with
| `GET | `HEAD | `POST | `DELETE as m -> m
| `PUT a -> `PUT(of_compat_argument a))
(List.map (fun (_, a) -> of_compat_argument a) cgi_act#initial_arguments)
(* Override methods that depend on the unknown output_type *)
method out_channel = cgi_act#output
method set_header ?status ?content_type ?content_length
?(set_cookie=[]) ?(set_cookies=[])
?cache ?filename ?language ?script_type ?style_type ?(fields=[])
() =
let now = Unix.time() in
let old_cookie c =
{ cookie_name = Netcgi_common.Cookie.name c;
cookie_value = Netcgi_common.Cookie.value c;
cookie_expires = (match Netcgi_common.Cookie.max_age c with
| None -> None
| Some t -> Some(float t +. now));
cookie_domain = Netcgi_common.Cookie.domain c;
cookie_path = Netcgi_common.Cookie.path c;
cookie_secure = Netcgi_common.Cookie.secure c;
} in
let fields =
match content_length with
| None -> fields
| Some size ->
("content-length", [string_of_int size]) ::
(List.filter
(fun (n,_) -> String.lowercase n <> "content-length")
fields) in
(* The old [set_header] knows whether the output is
transactional or not. *)
cgi_act#set_header ?status ?content_type ?cache ?filename
?language ?script_type ?style_type ~fields
~set_cookie:(set_cookie @ (List.map old_cookie set_cookies))
()
method set_redirection_header ?set_cookies ?(fields=[]) loc =
(* There is no way of getting the old set_redirection_header to
accept to set other fields. Thus, use [set_header]. *)
self#set_header ?set_cookies
~fields:(fields @ [("Location", [loc])] )
()
end
end
module Netcgi =
struct
type argument_processing =
[ `Memory
| `File
| `Automatic ]
type operating_type =
[ `Direct of string (* separator *)
| `Transactional of
(Netcgi_env.cgi_config -> Netchannels.out_obj_channel ->
Netchannels.trans_out_obj_channel)
]
let buffered_transactional_optype =
`Transactional (fun config ch -> new Netchannels.buffered_trans_channel ch)
let tempfile_transactional_optype =
`Transactional
(fun config ch ->
let tmp_directory = config.Netcgi_env.tmp_directory in
let tmp_prefix = config.Netcgi_env.tmp_prefix in
new Netchannels.tempfile_trans_channel ~tmp_directory ~tmp_prefix ch
)
class simple_argument ?(ro=true) name value =
object
val super = new Netcgi_common.simple_arg name value
method name = super#name
method value = super#value
method open_value_rd = super#open_value_rd
method ro = super#ro
method store = super#store
method content_type = fst(super#content_type())
method content_type_params = snd(super#content_type())
method charset = super#charset
method filename = super#filename
method representation = super#representation
method finalize = super#finalize
method set_value = super#set_value
method open_value_wr = super#open_value_wr
end
class mime_argument ?work_around_backslash_bug name mime =
object
val super =
new Netcgi_common.mime_arg ?work_around_backslash_bug ~name mime
method name = super#name
method value = super#value
method open_value_rd = super#open_value_rd
method ro = super#ro
method store = super#store
method content_type = fst(super#content_type())
method content_type_params = snd(super#content_type())
method charset = super#charset
method filename = super#filename
method representation = super#representation
method finalize = super#finalize
method set_value = super#set_value
method open_value_wr = super#open_value_wr
end
let split_name_val s = (* Same as in Netcgi_cgi *)
try
let i = String.index s '=' in
(String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1))
with Not_found ->
(s, "")
class std_activation
?env ?(processing =
fun _ _ -> `Automatic)
?(operating_type = ( `Direct "" : operating_type ) ) () =
let (new_env, in_obj) =
match env with
| None ->
if Netcgi_cgi.is_cgi() then
(* Following is stolen from Netcgi_cgi: *)
let (properties, input_header) =
Array.fold_left
(fun l e ->
Netcgi_common.update_props_inheader (split_name_val e) l)
([], []) (Unix.environment()) in
let in_obj = new Netchannels.input_channel stdin in
let out_obj = new Netchannels.output_channel stdout in
let new_env =
new Netcgi_common.cgi_environment
~config:Netcgi.default_config
~properties ~input_header out_obj in
(new_env, in_obj)
else
raise(Not_implemented "class std_activation: The environment is not CGI")
(* [cgi] enters test mode in this case *)
| Some e ->
if e # input_state <> `Received_header then
failwith "Netcgi.std_activation: environment indicates the wrong input state";
if e # output_state <> `Start then
failwith "Netcgi.std_activation: environment indicates the wrong output state";
(Netcgi_env.of_compat_environment e,
e # input_ch) in
let new_arg_store n_env arg_name n_arg_hdr =
let arg_hdr = new Netmime.basic_mime_header n_arg_hdr#fields in
let p = processing arg_name arg_hdr in
(p : argument_processing :> Netcgi_common.arg_store_type) in
let new_output_type =
match operating_type with
| `Direct s -> `Direct s
| `Transactional f ->
`Transactional
(fun n_config out_obj ->
let o_config = Netcgi_env.to_compat_config n_config in
f o_config out_obj
) in
let new_cgi =
Netcgi_common.cgi_with_args
(new Netcgi_common.cgi)
new_env new_output_type in_obj new_arg_store in
let () =
match env with
| None -> ()
| Some e ->
e # set_input_state `Received_body in
Netcgi_types.to_compat_activation new_cgi
end
