(* netcgi_common.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.
*)
(* module Url = Netencoding.Url *)
open Netchannels
open Printf
(* TODO: Get rid of all the unsafe_get and unsafe_set, or prove that
their usage is correct. Until then, we enforce using the safe variants
(for strings). There are also calls to Array.unsafe_(get/set) and
Char.unsafe_chr
*)
let unsafe_get s k = s.[k]
let unsafe_set s k c = s.[k] <- c
(* Exceptions and signals
***********************************************************************)
exception HTTP of Nethttp.http_status * string
let () =
Netexn.register_printer
(HTTP(`Continue, ""))
(fun e ->
match e with
| HTTP(status, text) ->
"Netcgi_common.HTTP(" ^
Nethttp.string_of_http_status status ^ ", " ^
"\"" ^ String.escaped text ^ "\")"
| _ -> assert false
)
(* If the socket connection is closed on the client end, the SIGPIPE
signal will be triggered, aborting the program. We want to see the
unix error [EPIPE], so disable the signal (if it exists for the OS)
The Netsys_signal framework disables this signal by default, so we
simply initialize the framework.
. *)
let () =
Netsys_signal.init()
(* Useful functions
***********************************************************************)
(* Specialize [min] to integers for performance reasons (> 150% faster). *)
let min x y = if (x:int) <= y then x else y
let is_prefix =
let rec is_pre i len pre s =
if i < len then
(unsafe_get pre i = unsafe_get s i)
&& is_pre (i+1) len pre s
else true in
fun prefix s ->
(String.length prefix <= String.length s)
&& is_pre 0 (String.length prefix) prefix s
let rev_split =
Nethttp.rev_split
(* [rm_htspace s] returns the substring [s.[low .. up - 1]] stripped
of heading and trailing spaces. *)
let rm_htspace is_space =
let rec trailing_spaces s j = (* assume there is i s.t. s.[i] <> ' ' *)
if is_space(unsafe_get s j) then trailing_spaces s (j - 1)
else j + 1 (* first trailing space *) in
let rec rm_spaces s i up =
if i >= up then "" else begin
if is_space(unsafe_get s i) then rm_spaces s (i + 1) up
else
(* s.[i] <> space so trailing_spaces will stop and return j >= i. *)
String.sub s i (trailing_spaces s (up - 1) - i)
end in
fun s low up ->
if low < 0 || up > String.length s
then invalid_arg "Netcgi_common.rm_htspace"
else rm_spaces s low up
(* Quote all problematic characters to put the filename in a header
and to save it on the disk and surround it by '"'. *)
let is_printable c =
(* TODO: We must not assume any charset here. The world has got larger *)
(* Latin-1 *)
(Char.code c >= 32 && Char.code c <= 127) || Char.code c >= 160
let filename_quote s =
(* Compute the length of the new string. *)
let n = ref 2 (* the quotes *) in
for i = 0 to String.length s - 1 do
n := !n + (match unsafe_get s i with
| '"' | '\\' | '\n' | '\t' -> 2
| c -> if is_printable c then 1 else 4)
done;
let s' = String.create !n in
unsafe_set s' 0 '\"';
n := 1;
for i = 0 to String.length s - 1 do
(match unsafe_get s i with
| ('"' | '\\') as c ->
unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c
| '\n' ->
unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'n'
| '\t' ->
unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 't'
| c ->
if is_printable c then unsafe_set s' !n c
else (
let a = Char.code c in
unsafe_set s' !n '\\';
incr n; unsafe_set s' !n (Char.chr (48 + a / 100));
incr n; unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10));
incr n; unsafe_set s' !n (Char.chr (48 + a mod 10))
)
);
incr n
done;
unsafe_set s' !n '\"';
s'
type http_method =
[`GET | `HEAD | `POST | `DELETE | `PUT]
let string_of_http_method =
function
| `GET -> "GET"
| `HEAD -> "HEAD"
| `PUT -> "PUT"
| `POST -> "POST"
| `DELETE -> "DELETE"
(* Knuth-Morris-Pratt algorithm
***********************************************************************)
(* TODO: Get rid of this. It is only used to search in short strings anyway.
There is an alternate implementation in Netaux.
*)
(** Substring search functions using the Knuth-Morris-Pratt algorithm. *)
module type KMP_TYPE =
sig
val search : string -> (string -> int -> int -> int)
(** [search pat] define a search function [f] such that [f s i0
i1] search the string [pat] in [s.[i0 .. i1-1]] and return the
position of the first match.
@raise Not_found if [pat] is not found.
@raise Invalid_argument if [i0 < 0] or [i1 > String.length s]. *)
val search_case_fold : string -> (string -> int -> int -> int)
(** [search_case_fold] is the same as [search] except that the
search is case insensitive. *)
end
module KMP : KMP_TYPE =
struct
(* Preprocess the pattern *)
let preprocess pat len =
let b = Array.make (len + 1) (-1) in
(* [b.(i)] = width of the widest border of [pat.[0 .. i-1]]. *)
let j = ref(-1) in
for i = 0 to len - 1 do
while !j >= 0
&& unsafe_get pat !j <> unsafe_get pat i do
j := Array.unsafe_get b !j
done;
incr j;
Array.(*unsafe_*)set b (i+1) !j
done;
b
(* [search pat s i0 i1] search the string [pat] in [s.[i0 .. i1-1]]
and return the position of the first match.
@raise Not_found if [pat] is not found. *)
(* We favored the following imperative code because it is the fastest. *)
exception Found of int
let search pat =
let m = String.length pat in
let b = preprocess pat m in
fun s i0 i1 ->
if i0 < 0 || i1 > String.length s then
invalid_arg "Netcgi_common.KMP.search";
let i = ref i0
and j = ref 0 in
try
while !i < i1 do
while !j >= 0
&& unsafe_get s !i <> unsafe_get pat !j do
j := Array.(*unsafe_*)get b !j
done;
incr i;
incr j;
if !j = m then raise(Found(!i - !j))
done;
raise Not_found
with Found i -> i
(* [search_case_fold pat s i0 i1] does the same as [search pat s i0
i1] but in a case insensitive manner. *)
let search_case_fold pat =
let m = String.length pat in
let pat = String.lowercase pat in
let b = preprocess pat m in
fun s i0 i1 ->
if i0 < 0 || i1 > String.length s then
invalid_arg "Netcgi_common.KMP.search";
let i = ref i0
and j = ref 0 in
try
while !i < i1 do
while !j >= 0 && Char.lowercase(unsafe_get s !i)
<> unsafe_get pat !j do
j := Array.(*unsafe_*)get b !j
done;
incr i;
incr j;
if !j = m then raise(Found(!i - !j))
done;
raise Not_found
with Found i -> i
end
(* Arguments
***********************************************************************)
type representation = [ `Simple of Netmime.mime_body
| `MIME of Netmime.mime_message ]
type store = [`Memory | `File of string]
class type cgi_argument =
object
method name : string
method value : string
method open_value_rd : unit -> Netchannels.in_obj_channel
method store : store
method content_type : unit -> string * (string * Netmime_string.s_param) list
(* [content_type] changed from the previous version to be uniform
with Netmime. *)
method charset : string
method filename : string option
method representation : representation
method finalize : unit -> unit
end
class type rw_cgi_argument =
object
inherit cgi_argument
method ro : bool
method set_value : string -> unit
method open_value_wr : unit -> Netchannels.out_obj_channel
end
(* Breaking with the old Netcgi module, the default for [ro] is
[true]. This is because the standard arguments are read-only. *)
class simple_arg ?(ro=true) (name0:string) value =
object(self)
inherit Netmime.memory_mime_body value
method! ro = ro
val name = name0
method name = name
method content_type () = ("text/plain",
([] : (string * Netmime_string.s_param) list))
method charset = ""
method filename = (None: string option)
method representation = (`Simple(self :> Netmime.mime_body): representation)
end
exception Oversized
class oversized_arg name =
object
inherit simple_arg name ""
method value = raise Oversized
method open_value_rd () = raise Oversized
end
class mime_arg ?(work_around_backslash_bug=true) ?(name: string option)
((hdr0, `Body body0) : Netmime.mime_message) =
let options =
if work_around_backslash_bug then [ Netmime_string.No_backslash_escaping ]
else [] in
let name0 = match name with
| Some n -> n
| None ->
(* Try to extract it from the MIME header; it is the "name"
parameter of the "Content-Disposition" field. *)
try
let s = hdr0#field "content-disposition" in
let _, params = Netmime_string.scan_value_with_parameters_ep s options in
Netmime_string.param_value(List.assoc "name" params)
with Not_found -> "" in
object(self)
val hdr = hdr0
val body = body0
val name = name0
method name = name
method value = body#value
method open_value_rd = body#open_value_rd
method store = body#store
method content_type () =
try Netmime_header.get_content_type hdr with Not_found -> ("text/plain", [])
method charset =
let _, params = self#content_type() in
try Netmime_string.param_value(List.assoc "charset" params)
with Not_found -> ""
method filename =
try
let s = hdr#field "content-disposition" in
let _, params = Netmime_string.scan_value_with_parameters_ep s options in
Some(Netmime_string.param_value(List.assoc "filename" params))
with Not_found ->
None
method representation = (`MIME(hdr, `Body body) : representation)
method finalize = body#finalize
method ro = body#ro
method set_value = body#set_value
method open_value_wr = body#open_value_wr
end
(* Cookies
***********************************************************************)
(* The cookie implementation has been moved to nethttp.ml *)
module Cookie = struct
include Nethttp.Cookie
let set = Nethttp.Header.set_set_cookie_ct
let get header =
Nethttp.Header.get_cookie_ct
(header : #Nethttp.http_header :> Nethttp.http_header_ro)
let of_record =
of_netscape_cookie
let to_record =
to_netscape_cookie
end
(* Environment
***********************************************************************)
type config = {
tmp_directory : string;
tmp_prefix : string;
permitted_http_methods : [`GET | `HEAD | `POST | `DELETE | `PUT] 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;
}
(* Microsoft Internet Explorer: When used with SSL connections, this
browser sometimes produces CONTENT_TYPEs like "multipart/form-data;
boundary=..., multipart/form-data; boundary=...".
Workaround: Throw away everything after ", ". We must take care
that, however unlikely, ',' is allowed in the boundary provided it
is a quoted string (RFC 2045).
*)
let fix_MSIE_Content_type_bug =
let bd = KMP.search "boundary" in
let lenbd = String.length "boundary" in
fun ct ->
try
let len = String.length ct in
let i = lenbd + bd ct 0 len (* char after "boundary" *) in
let another_bd = (try ignore(bd ct i len); true
with Not_found -> false) in
if another_bd then (
(* Assume the boundary is not quoted *)
try
let j = String.index_from ct i ',' in
String.sub ct 0 j (* cut as ',' *)
with _ -> ct
)
else ct (* fine as is *)
with Not_found -> ct (* No "boundary" parameter, maybe just a
application/x-www-form-urlencoded POST.
Leave unchanged. *)
let is_MSIE =
let search = KMP.search "MSIE" in
fun u ->
try ignore(search u 0 (String.length u)); true
with Not_found -> false
(* This is a good place to deal with the MSIE bug as we have all args
thus can check the browser -- plus it must be done for all
connectors. *)
class cgi_environment ~config ~(properties:(string * string) list)
~input_header (out_obj:out_obj_channel)
=
(* Work around MSIE Content-Type bug *)
let work_around =
(List.mem `MSIE_Content_type_bug config.workarounds
|| List.mem `Work_around_MSIE_Content_type_bug config.workarounds)
&& (try is_MSIE(List.assoc "user-agent" input_header)
with Not_found -> false) in
let input_header =
if work_around then
List.map (fun ((n,v) as p) ->
if n = "content-type" then (n, fix_MSIE_Content_type_bug v)
else p
) input_header
else input_header in
(* It seems some web servers set SERVER_NAME as name:port. If so,
split the value into the two properties. *)
let properties =
try
let server_name = List.assoc "SERVER_NAME" properties in
let (host,port) =
(* socksymbol_of_string can also handle IPv6 addresses *)
match Netsockaddr.socksymbol_of_string server_name with
| `Inet(addr,port) ->
(Unix.string_of_inet_addr addr, port)
| `Inet_byname(host,port) ->
(host,port)
| `Unix _ ->
failwith "unsupported" in
let prop_name = ("SERVER_NAME", host) in
let prop_port = ("SERVER_PORT", string_of_int port) in
let properties =
List.filter
(fun (n,_) -> n <> "SERVER_NAME")
properties in
(try
ignore(int_of_string(List.assoc "SERVER_PORT" properties));
(* A port number is already given -- leave it *)
prop_name :: properties
with Not_found | Failure _ ->
prop_name :: prop_port :: properties)
with Not_found | Failure _ -> properties in
object(self)
val config = config
val properties_list = properties
val properties = (Hashtbl.create 20 : (string,string) Hashtbl.t)
val input_header =
Netmime.wrap_mime_header_ro
(Netmime.basic_mime_header input_header)
val output_header =
(* The user is supposed to call [cgi#set_header] and that will set
the Content-Type. Thus one can set a default one in case he
forgot -- we use the same default as [cgi#set_header] by the
principle of leat surprise. *)
new Netmime.basic_mime_header [("Content-Type", "text/html")]
val out_channel = out_obj
val mutable input_content_type = lazy(assert false)
val mutable cookies = lazy(assert false)
val mutable header_not_sent = true
initializer
(* Build the hashtable for faster access to CGI properties.
Properties come in no specific order. We use the
[properties_list] given at creation instead of
[self#properties] because this class may be inherited and the
latter be only initialized then. *)
List.iter (fun (n,v) -> Hashtbl.add properties n v) properties_list;
(* To avoid reparsing again and again Content-Type, we do it here.
However, some request do not have a Content-Type (e.g. GET) and
this parsing can raise exceptions (which we do not want at the
creation of this object), thus we do it only on demand. *)
input_content_type <- lazy(
Netmime_string.scan_mime_type_ep (self#input_header_field "content-type") []
);
(* Cache the extracted cookies *)
cookies <- lazy(Nethttp.Header.get_cookie_ct self#input_header)
(* CGI properties *)
method cgi_properties = properties_list
method cgi_property ?default name =
match default with
| None -> Hashtbl.find properties name
| Some d -> try Hashtbl.find properties name with Not_found -> d
method cgi_gateway_interface =
self#cgi_property ~default:"" "GATEWAY_INTERFACE"
method cgi_server_name =
self#cgi_property ~default:"" "SERVER_NAME"
method cgi_server_port =
try Some(int_of_string(self#cgi_property "SERVER_PORT"))
with Not_found | Failure _ -> None
method cgi_server_protocol = self#cgi_property ~default:"" "SERVER_PROTOCOL"
method cgi_server_software = self#cgi_property ~default:"" "SERVER_SOFTWARE"
method cgi_request_method = self#cgi_property ~default:"" "REQUEST_METHOD"
method cgi_script_name = self#cgi_property ~default:"" "SCRIPT_NAME"
method cgi_path_info = self#cgi_property ~default:"" "PATH_INFO"
method cgi_path_translated = self#cgi_property ~default:"" "PATH_TRANSLATED"
method cgi_auth_type = self#cgi_property ~default:"" "AUTH_TYPE"
method cgi_remote_addr = self#cgi_property ~default:"" "REMOTE_ADDR"
method cgi_remote_host = self#cgi_property ~default:"" "REMOTE_HOST"
method cgi_remote_user = self#cgi_property ~default:"" "REMOTE_USER"
method cgi_remote_ident = self#cgi_property ~default:"" "REMOTE_IDENT"
method cgi_query_string = self#cgi_property ~default:"" "QUERY_STRING"
method protocol : Nethttp.protocol =
let proto = self#cgi_server_protocol in
if is_prefix "HTTP/" proto then
try
let dot = String.index_from proto 5 '.' in
let dot1 = dot + 1 in
let len = String.length proto in
let version = (int_of_string(String.sub proto 5 (dot - 5)),
int_of_string(String.sub proto dot1 (len - dot1))) in
`Http(version, if self#cgi_https then [`Secure_https] else [])
with _ ->
`Other
else `Other
method cgi_https =
match String.lowercase(self#cgi_property ~default:"" "HTTPS") with
| "on" -> true
| "off" | "" -> false
| p -> raise(HTTP(`Bad_request,
"Cannot interpret HTTPS property: " ^ p))
(* Input *)
method input_header = input_header
method input_header_field ?default name =
try self#input_header#field name
with Not_found -> (match default with
| None -> raise Not_found
| Some d -> d)
method multiple_input_header_field name =
self#input_header#multiple_field name
method input_header_fields =
self#input_header#fields
method cookies = Lazy.force cookies (* init => fun of self#input_header *)
method cookie name =
List.find (fun c -> Nethttp.Cookie.name c = name) self#cookies
method user_agent =
self#input_header_field ~default:"" "USER-AGENT"
method input_content_length =
try int_of_string(self#input_header_field "CONTENT-LENGTH")
with Failure _ ->
raise(HTTP(`Bad_request, "Content-Length is not an integer!"))
method input_content_type_string =
self#input_header_field ~default:"" "CONTENT-TYPE"
method input_content_type () = Lazy.force input_content_type
(* Output *)
method output_header = output_header
method output_header_field ?default name =
try self#output_header#field name
with Not_found -> (match default with
| None -> raise Not_found
| Some d -> d)
method multiple_output_header_field name =
self#output_header#multiple_field name
method output_header_fields =
self#output_header#fields
method set_output_header_field name value =
self#output_header#update_field name value
method set_multiple_output_header_field name values =
self#output_header#update_multiple_field name values
method set_output_header_fields fields =
self#output_header#set_fields fields
method set_status st =
let status = string_of_int(Nethttp.int_of_http_status st) in
self#output_header#update_field "Status" status
method send_output_header () =
(* In transactional mode, some body may have been outputted before
we (re)set the header, thus the header is sent directly to the
"raw" channel. Moreover, to set the Content-Length header, one
would like only the DATA to be sent to the transactional
[cgi#out_channel].
Since it is not unreasonable that the user calls
[send_output_header] before [commit_work], we make sure the
header is sent only once. *)
if header_not_sent then (
(* Note: ~soft_eol:"" because linear whitespace is illegal in CGI
responses. *)
Netmime_string.write_header ~soft_eol:"" ~eol:"\r\n"
out_obj self#output_header#fields;
header_not_sent <- false (* One output header per request *)
)
method output_ch = out_channel
method out_channel = out_channel
method private format_error msg =
let zone = Netdate.localzone (* log local time *) in
"[" ^ Netdate.format "%c" (Netdate.create ~zone (Unix.gettimeofday()))
^ "] [OcamlNet] " ^ msg
method log_error msg = prerr_endline (self#format_error msg)
(* Rough default but works most of the time. *)
method config = config
end
(* Creating transactional channels and CGI objects
***********************************************************************)
(* Direct & transactional channels. *)
type output_type =
[ `Direct of string
| `Transactional of config -> out_obj_channel -> trans_out_obj_channel ]
(* Channel that discards everything written to it. *)
class discarding_channel (before: unit -> unit) : trans_out_obj_channel =
object
inherit Netchannels.output_null() as super
val before_commit = before
val mutable pos_commit = 0 (* position of last "commit" *)
val mutable pos_delta = 0 (* how much data has been "rollbacked"
-- to substract from position *)
method pos_out = super#pos_out - pos_delta
method commit_work() =
before_commit();
pos_commit <- super#pos_out
method rollback_work() =
(* "rollback" can be emulated by increasing the pos_delta value,
such that pos_out will return the position of the last commit
operation *)
pos_delta <- pos_delta + (super#pos_out - pos_commit)
end
(* Has the interface of a transactional channel but in fact, it is not. *)
class no_trans_channel sep (before: unit -> unit) (ch:out_obj_channel)
: trans_out_obj_channel =
object
val sep = sep
val before_commit = before
val ch = ch
method output = ch#output
method flush = ch#flush
method close_out = ch#close_out
method pos_out = ch#pos_out
method really_output = ch#really_output
method output_char = ch#output_char
method output_string = ch#output_string
method output_byte = ch#output_byte
method output_buffer = ch#output_buffer
method output_channel = ch#output_channel
method commit_work () = before_commit(); ch#flush()
method rollback_work() = ch#output_string sep
end
class on_commit_channel (before: unit -> unit) (ch: trans_out_obj_channel)
: trans_out_obj_channel =
object
val before_commit = before
val ch = ch
method output = ch#output
method flush = ch#flush
method close_out = ch#close_out
method pos_out = ch#pos_out
method really_output = ch#really_output
method output_char = ch#output_char
method output_string = ch#output_string
method output_byte = ch#output_byte
method output_buffer = ch#output_buffer
method output_channel = ch#output_channel
method commit_work () = before_commit(); ch#commit_work()
method rollback_work = ch#rollback_work
end
type other_url_spec = [ `Env | `This of string | `None ]
type query_string_spec = [ `Env | `This of cgi_argument list | `None
| `Args of rw_cgi_argument list ]
type cache_control = [ `No_cache | `Max_age of int | `Unspecified ]
type request_method = [`GET | `HEAD | `POST | `DELETE | `PUT of cgi_argument]
let string_of_request_method = function
| `GET -> "GET"
| `HEAD -> "HEAD"
| `POST -> "POST"
| `DELETE -> "DELETE"
| `PUT _ -> "PUT"
let last_char s =
if s = "" then failwith "last_char";
s.[ String.length s - 1 ]
exception Too_many_arguments
(* CGI abstractions independent of the connector. *)
class cgi (env:cgi_environment) (op:output_type)
(request_method:request_method) (args:cgi_argument list)
=
(* Called just before the out_channel is committed *)
let before_commit () =
(* We can call [env#send_output_header] without harm even in
`Direct mode since it checks the header is sent at most one
time. If [#set_header] was not called before, the default
environment header will be sent. *)
env#send_output_header()
in
object(self)
val args = args (* list of arguments *)
val arguments = (Hashtbl.create 15 : (string, cgi_argument) Hashtbl.t)
val out_channel =
(* Initialize the output channel from the arguments: *)
if request_method = `HEAD then
(* For HEAD requests, no body has to be sent. *)
new discarding_channel before_commit
else (
match op with
| `Direct sep ->
new no_trans_channel sep before_commit env#out_channel
| `Transactional f ->
new on_commit_channel before_commit (f env#config env#out_channel)
)
val request_method = request_method
val env = env
val mutable do_at_exit = []
initializer
(* Add the arguments in the reverse order for [find_all] to give
expected results. Allow a redefinition of [#arguments].
Security note: It is essential for preventing DoS attacks that
we use here Hashtbl.add and not Hashtbl.replace. Otherwise a
malicious user could craft arguments specially so that the
argument names cause lots of collisions in the hash table,
and the performance of Hashtbl.replace would decrease dramatically
(to O(n) per operation, leading to O(n^2) for the whole iteration).
*)
if List.length args > env#config.max_arguments then
raise Too_many_arguments;
List.iter (fun a -> Hashtbl.add arguments a#name a)
(List.rev self#arguments)
method argument name = Hashtbl.find arguments name
method argument_value ?(default="") name =
try (Hashtbl.find arguments name)#value
with Not_found -> default
method argument_exists name = Hashtbl.mem arguments name
method multiple_argument name = Hashtbl.find_all arguments name
method arguments = args
method environment = env
method request_method = request_method
method finalize () =
List.iter (fun a -> a#finalize()) self#arguments;
(match self#request_method with
| `PUT a -> a#finalize()
| _ -> ());
List.iter (fun f -> f()) do_at_exit
method url ?(protocol=env#protocol)
?(with_authority=(`Env:other_url_spec))
?(with_script_name=(`Env:other_url_spec))
?(with_path_info=(`Env:other_url_spec))
?(with_query_string=(`None:query_string_spec)) () =
let serv = match with_authority with
| `This s -> s
| `None -> ""
| `Env ->
let p_scheme, p_port =
match protocol with
| `Http(_, atts) ->
if List.mem `Secure_https atts then "https", 443
else "http", 80
| `Other ->
raise(HTTP(`Not_implemented,
"Netcgi.cgi#url: Cannot cope with the protocol"))
in
p_scheme ^ "://" ^ env#cgi_server_name
^ (match env#cgi_server_port with
| None -> ""
| Some port ->
if port = p_port then "" else ":" ^ string_of_int port)
and script = match with_script_name with
| `Env -> env#cgi_script_name
| `This s -> s
| `None -> "" in
let before_path = serv ^ script in
let path = match with_path_info with
| `Env -> env#cgi_path_info
| `This s ->
(* the path-info MUST be separated by "/" *)
if (s <> "" && s.[0] <> '/') &&
(before_path = "" || last_char before_path <> '/' )
then "/" ^ s
else s
| `None -> ""
and args = match with_query_string with
| `None -> []
| `Env -> self#arguments
| `This args -> args
| `Args args -> (args :> cgi_argument list) (* deprecated *) in
let args = (* consider only `Memory args *)
List.filter
(fun a -> match a#store with `Memory -> true | _ -> false) args in
let url = before_path ^ path in
if args= [] then url else
url ^ "?" ^
(String.concat "&"
(List.map (fun a ->
Netencoding.Url.encode(a#name) ^ "=" ^
Netencoding.Url.encode(a#value)) args
))
method set_header
?status ?(content_type="text/html") ?content_length
?(set_cookie=[]) ?(set_cookies=[])
?(cache=(`Unspecified:cache_control)) ?(filename="") ?(language="")
?(script_type="") ?(style_type="") ?(fields=[])
() =
env#set_output_header_fields []; (* reset *)
env#set_output_header_field "Content-Type" content_type;
(match content_length with
| None -> ()
| Some size ->
env#set_output_header_field "Content-Length" (string_of_int size));
(match status with
| None -> ()
| Some s -> env#set_status s);
(match cache with
| `Unspecified -> ()
| `No_cache ->
env#set_output_header_field "Cache-control" "no-cache";
env#set_output_header_field "Pragma" "no-cache";
let past = Netdate.mk_mail_date(Unix.time() -. 1.0) in
env#set_output_header_field "Expires" past;
| `Max_age n ->
env#set_multiple_output_header_field "Cache-control"
[ "max-age=" ^ string_of_int n; "must-revalidate" ];
let secs = Netdate.mk_mail_date(Unix.time() +. float n) in
env#set_output_header_field "Expires" secs;
);
if filename <> "" then begin
env#set_output_header_field "Content-disposition"
("attachment; filename=" ^ filename_quote filename);
end;
if language <> "" then
env#set_output_header_field "Content-language" language;
if script_type <> "" then
env#set_output_header_field "Content-script-type" script_type;
if style_type <> "" then
env#set_output_header_field "Content-style-type" style_type;
(* Convert the deprecated [set_cookie] to the new format. *)
let cookies =
List.fold_left (fun l c -> Nethttp.Cookie.of_netscape_cookie c :: l)
set_cookies set_cookie in
Nethttp.Header.set_set_cookie_ct env#output_header cookies;
List.iter (fun (n,v) -> env#set_multiple_output_header_field n v) fields;
match op with
| `Direct _ -> env#send_output_header() (* before any other output! *)
| _ -> () (* For transactional output channels, it must be
possible to call this function several times. Thus
no data must be actually written now. *)
method set_redirection_header ?(set_cookies=[]) ?(fields=[]) loc =
env#set_output_header_fields [];
Nethttp.Header.set_set_cookie_ct env#output_header set_cookies;
List.iter (fun (n,v) -> env#set_multiple_output_header_field n v) fields;
env#set_output_header_field "Location" loc;
env#set_status `Found; (* be precise -- necessary for some connectors *)
match op with
| `Direct _ -> env#send_output_header()
| _ -> ()
method output = out_channel
method out_channel = out_channel
method at_exit f = do_at_exit <- f :: do_at_exit
end
(* Reading arguments
***********************************************************************)
(* We believe it is better to deal here with the size of arguments --
instead of leaving it to the user -- because 1. oversized argument
will not live longer than necessary allowing space for the
following ones; 2. it is a reminder to the user to think about this
issue; 3. it is likely to show up in many apps, so having it here
factors the code and is convenient. *)
type arg_store_type =
[`Memory | `File | `Automatic | `Discard
| `Memory_max of float | `File_max of float | `Automatic_max of float]
type arg_store = cgi_environment -> string -> Netmime.mime_header_ro ->
arg_store_type
(* [temp_file env] returns a function [unit -> string] to create
temporary files according to the preferences in [config]. *)
let temp_file_fun config =
let tmp_directory = config.tmp_directory in
let tmp_prefix = config.tmp_prefix in
fun () ->
let (name, in_chan, out_chan) =
Netchannels.make_temporary_file ~tmp_directory ~tmp_prefix () in
close_in in_chan;
close_out out_chan;
name
(* Remove all [None] from the list and "flatten" the [Some], keeping
the order of arguments. We could avoid this if
[Netmime_string.read_multipart_body] had a "fold" form. *)
let rec remove_discarded_args = function
| [] -> []
| None :: tl -> remove_discarded_args tl
| (Some a) :: tl -> a :: remove_discarded_args tl
let mime_header_string_arg =
(new Netmime.basic_mime_header ["content-type", "text/plain"]
:> Netmime.mime_header_ro)
(* Given a query string like [qs], return [None] is the argument is
oversized or [Some arg]. *)
let args_of_string env arg_store qs =
let name_val = Netencoding.Url.dest_url_encoded_parameters qs in
let mk_arg (name, value) =
let store = (try arg_store env name mime_header_string_arg
with _ -> `Discard) in
if store = `Discard then None
else begin
let max_bytes = match store with
| `Discard -> assert(false)
| `Memory | `File | `Automatic -> infinity
| `Memory_max size | `File_max size | `Automatic_max size -> size in
if float(String.length value) > max_bytes then
Some(new oversized_arg name :> cgi_argument)
else
Some(new simple_arg name value :> cgi_argument)
end in
remove_discarded_args (List.map mk_arg name_val)
;;
(* Given the [name] and header [hdr] of an argument, return [None] if
the argument is discarded or [Some arg] otherwise where [arg]
body is read from [stream] (the header, if any, is supposed to
have been read already). *)
let arg_body_of_stream env (arg_store:arg_store) name hdr ~has_filename
~work_around_backslash_bug temp_file (stream:Netstream.in_obj_stream) =
let store = (try arg_store env name (hdr :> Netmime.mime_header_ro)
with _ -> `Discard) in
if store = `Discard then None
else begin
let store, max_bytes = match store with
| `Discard -> assert(false)
| `Memory -> `Memory, infinity
| `Memory_max size -> `Memory, size
| `File -> `File(temp_file()), infinity
| `File_max size -> `File(temp_file()), size
| `Automatic ->
(if has_filename then `File(temp_file()) else `Memory), infinity
| `Automatic_max size ->
(if has_filename then `File(temp_file()) else `Memory), size in
let body, body_ch = Netmime_channels.storage ~fin:true store in
try
Netchannels.with_out_obj_channel
(Netmime_channels.decode_mime_body hdr body_ch)
(fun body_ch' ->
body_ch'#output_channel(stream :> Netchannels.in_obj_channel));
(* check size *)
(* FIXME: Unfortunately this check can be done after the whole
argument has been saved. Doing otherwise would require
modifications to Netmime to allow an optional size argument *)
let size = match store with
| `Memory -> String.length(body#value)
| `File temp -> (Unix.stat temp).Unix.st_size in
if float size > max_bytes then (
body#finalize(); (* delete file *)
Some(new oversized_arg name :> cgi_argument)
)
else
let body = Netmime.wrap_mime_body_ro body in
Some(new mime_arg ~work_around_backslash_bug ~name (hdr, `Body body)
:> cgi_argument)
with
| Invalid_argument "String.create" (* string too large *)
| Unix.Unix_error(Unix.ENOSPC,_,_)
| Sys_error _ ->
body#finalize();
Some(new oversized_arg name :> cgi_argument)
| e ->
(* Other exceptions are also treated as "oversized" (so we
keep a trace of the argument existence) but the exn is
strange so log it. *)
env#log_error(sprintf "While reading the body of the CGI argument %S,\
the exception %S was raised. The argument has been treated as \
oversized."
name (Netexn.to_string e));
body#finalize();
Some(new oversized_arg name :> cgi_argument)
end
(* Returns [Some arg] created by reading the [stream], or [None] if
[arg_store] decides that the argument must be discarded. It is
made to be called by {!Netmime_string.read_multipart_body} on each
part. *)
let arg_of_stream env (arg_store:arg_store) temp_file
~work_around_backslash_bug (stream:Netstream.in_obj_stream) =
let hdr = Netmime_channels.read_mime_header ~ro:true stream in
(* FIXME: Unfortunately raising the exceptions below can leave the
files of the previous arguments on the disk. The easier would be
to have [Netmime_string.fold_multipart_body] wich would give access
to the previous args. (Incidentally, it would also remove the
need for [remove_discarded_args].) *)
let disposition, disp_params =
try Netmime_header.get_content_disposition hdr
with
| Not_found ->
raise(HTTP(`Bad_request,
"Content-Disposition field is missing from POST data"))
| Failure _ ->
raise(HTTP(`Bad_request,
"The browser sent the invalid Content-Disposition field: "
^ hdr#field "Content-Disposition")) in
if disposition <> "form-data" then
raise(HTTP(`Bad_request, "Unknown Content-disposition " ^ disposition
^ " in POST request body"));
let name =
try Netmime_string.param_value(List.assoc "name" disp_params)
with Not_found ->
raise(HTTP(`Bad_request,
"\"name\" parameter mandatory in Content-Disposition field"))
in
let has_filename = List.mem_assoc "filename" disp_params in
arg_body_of_stream env arg_store name hdr temp_file ~has_filename
~work_around_backslash_bug stream
(* Do not care about thread safety of [discard_buffer] -- contains garbage. *)
let discard_buffer = String.create 0x2000
(** [discard_bytes in_obj len] discard at most [len] bytes ([len]
bytes or until the end of file is reached). *)
let discard_bytes (in_obj: Netchannels.in_obj_channel) len =
let len = ref len in
try
while !len > 0 do
let r = in_obj#input discard_buffer 0 (min !len 0x2000) in
if r = 0 then len := 0 (* FIXME: Sys_blocked_io ?? *)
else len := !len - r
done
with End_of_file -> ()
let cgi_with_args new_cgi (env:cgi_environment) (op:output_type)
in_obj arg_store =
(* Check that the request method is allowed and get the parameters *)
let config = env#config in
(* Get the request-method in the same form it is specified in
{!config.permitted_http_methods}. *)
let request_method =
match env#cgi_request_method with
| "GET" -> `GET
| "HEAD" -> `HEAD
| "POST" -> `POST
| "DELETE" -> `DELETE
| "PUT" -> `PUT
| r ->
if r = "" then
raise(HTTP(`Bad_request, "Empty request method!\n\
If you are running this program from a shell to test it, use Netcgi_test.run\n\
to execute your main function. It will help you passing information and\n\
seeing the result."))
else
raise(HTTP(`Not_implemented, "Unknown request method: " ^ r))
in
if not(List.mem request_method config.permitted_http_methods) then
(* Behavior mandated by RFC 2068, section 5.1.1 *)
raise(HTTP(`Method_not_allowed,
"The request method " ^ env#cgi_request_method
^ " is not allowed"));
(match request_method with
| `GET | `HEAD | `DELETE as request_method ->
(* Read the arguments from QUERY_STRING. Normally DELETE does
not receive parameters, but it does not harm. *)
let args = args_of_string env arg_store env#cgi_query_string in
new_cgi env op (request_method: request_method) args
| `POST | `PUT as request_method ->
(* Check Content-Length *)
let len =
try env#input_content_length
with
| Not_found -> raise(HTTP(`Length_required,
"Content-Length field is mandatory"))
| Failure _ -> raise(HTTP(`Bad_request,
"Erroneous Content-Length format")) in
if len > config.input_content_length_limit then (
(* Ok, the content is too big but we need to read it and
discard it to get it out of the way. Some connectors
complain if we don't (e.g. SCGI). *)
discard_bytes in_obj len;
raise(HTTP(`Request_entity_too_large,
"Content-Length=" ^ string_of_int len
^ " bytes is bigger that the allowed limit of "
^ string_of_int config.input_content_length_limit));
);
(* Check the Content-Type *)
let content_type, _ =
try env#input_content_type()
with
| Not_found -> raise(HTTP(`Bad_request,
"Content-Type field is required"))
| Failure _ -> raise(HTTP(`Bad_request,
"Erroneous Content-Type format")) in
let permitted = config.permitted_input_content_types in
if permitted <> [] && not(List.mem content_type permitted) then (
discard_bytes in_obj len;
raise(HTTP(`Unsupported_media_type,
"Content-Type \"" ^ content_type ^ "\" is not authorized"));
);
(* Get CGI arguments *)
begin match request_method with
| `POST ->
(* Read the arguments from the input channel. *)
begin match env#input_content_type() with
| "application/x-www-form-urlencoded", _ ->
(* As the data is supposed to be quite small (like
QUERY_STRING), we will read it entirely into a string.
We check the string size limit however. *)
if len > Sys.max_string_length then (
discard_bytes in_obj len;
raise(HTTP(`Request_entity_too_large,
"A maximum of "
^ string_of_int Sys.max_string_length
^ " bytes is allowed for urlencoded forms"));
);
let qs = String.create len in
( try
in_obj#really_input qs 0 len
with End_of_file ->
raise(HTTP(`Bad_request,
"Request body is shorter than announced in \
Content-Length"));
);
let args = args_of_string env arg_store qs in
new_cgi env op `POST args
| "multipart/form-data", params ->
let boundary =
try Netmime_string.param_value(List.assoc "boundary" params)
with Not_found ->
raise(HTTP(`Bad_request,
"Content-Type multipart/form-data needs to \
contain a \"boundary\" parameter")) in
(* How to create temporary files *)
let temp_file = temp_file_fun config in
let in_stream = new Netstream.input_stream ~len in_obj in
let work_around_backslash_bug =
List.mem `Backslash_bug config.workarounds
|| List.mem `Work_around_backslash_bug config.workarounds in
(* Make a list of args by applying [mk_arg] to each part. *)
let mk_arg stream = (arg_of_stream env arg_store temp_file
~work_around_backslash_bug stream) in
let args = remove_discarded_args
(Netmime_string.read_multipart_body mk_arg boundary in_stream)
in
new_cgi env op `POST args
| _ ->
(* For example [content_type] may be
- application/vnd.fdf: Acrobat Reader
- multipart/related, application/xml: XForms 1.0
- application/x-www-form+xml, text/plain:
WHATWG Web Forms 2.0
Create a unique argument "BODY" containing all the
data available on the input channel (not processing). *)
let temp_file = temp_file_fun config in
let in_stream = new Netstream.input_stream ~len in_obj in
let arg =
arg_body_of_stream env arg_store "BODY" env#input_header
~has_filename:true (* thus `Automatic -> `File *)
~work_around_backslash_bug:false temp_file in_stream in
new_cgi env op `POST (remove_discarded_args [arg])
end
| `PUT ->
(* Read the normal arguments from QUERY_STRING *)
let args = args_of_string env arg_store env#cgi_query_string in
(* How to create the possible temporary file (at most one) *)
let temp_file = temp_file_fun config in
(* Read _the_ PUT argument from stdin. There is no header. *)
let in_stream = new Netstream.input_stream ~len in_obj in
let work_around_backslash_bug =
List.mem `Backslash_bug config.workarounds
|| List.mem `Work_around_backslash_bug config.workarounds in
(* PUT arg does not have name but we use "BODY" for
backward compatibility. *)
let hdr = env#input_header in
let name = "BODY" in
let put_arg =
arg_body_of_stream env arg_store name hdr temp_file
~has_filename:true ~work_around_backslash_bug in_stream in
match put_arg with
| Some a -> new_cgi env op (`PUT(a)) args
| None -> raise(HTTP(`Not_implemented,
"PUT request body rejected"))
end
)
(* Handling exceptions
***********************************************************************)
let error_page (env:cgi_environment) status fields msg html =
(* We do not need to rollback the work because either (1) it has
been commited (and it is too late), or (2) it has not and then is
still in the buffer of [cgi#out_channel] and we shall use the raw
channel. *)
try
(* Log the error *)
let script_name = env#cgi_script_name in
let code = Nethttp.int_of_http_status status in
let info = Nethttp.string_of_http_status status in
env#log_error (sprintf "%s: %s (Status %i)" script_name msg code);
(* Header
We have no idea whether a previous header has been sent, so we
try our luck. At worst, it will appear within the current
output. *)
env#set_output_header_fields []; (* reset *)
env#set_output_header_field "Content-type" "text/html";
env#set_status status;
(* Cache 1h *)
let now = Unix.time() in
env#set_multiple_output_header_field "Cache-control"
[ "max-age=3600"; (* secs *)
"must-revalidate" ];
let secs = Netdate.mk_mail_date(now +. 3600.) in
env#set_output_header_field "Expires" secs;
(* Additional fields *)
List.iter (fun (n,v) -> env#set_multiple_output_header_field n v) fields;
env#send_output_header();
(* Body -- unless it is a HEAD request.
Description of the problem.
*)
if env#cgi_request_method <> "HEAD" then (
let out = env#out_channel#output_string in
let printf fmt = kprintf out fmt in
out "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.0//EN\" \
\"http://www.w3.org/TR/REC-html40/strict.dtd\">\n";
out "<html xmlns=\"http://www.w3.org/1999/xhtml\" \
xml:lang=\"en\" lang=\"en\">
<head>
<meta name=\"generator\" content=\"OCamlNet (http://ocamlnet.sf.net)\">
<style>
p.msg { color: black; background-color: #cccccc; padding: 1ex; }
h2 { font-size: large; }
</style>
</head>
<body>\n";
printf "<h1>%i — %s</h1>\n" code info;
out "<h2>Cause of the error:</h2>";
out "<p class=\"msg\">";
out msg;
out "</p>\n";
out "<h2>Additional information:</h2>";
out "<p>";
out html;
out "</p>\n<p>";
let date = Netdate.create ~zone:Netdate.localzone now in
printf "Date: %s<br />\n" (Netdate.format "%c" date);
printf "Script: %s<br />\n" script_name;
printf "Request method: <tt>%s</tt><br />\n" env#cgi_request_method;
printf "Query string: <tt>%s</tt><br />\n" env#cgi_query_string;
printf "Browser: <tt>%s</tt><br />\n" (String.escaped env#user_agent);
out "</p>\n";
(try
let referer = env#input_header_field "referer" in
printf "<a href=\"%s\">Go back</a>\n" referer (* FIXME: escape *)
with Not_found -> ());
out "</body>\n</html>\n";
env#out_channel#flush();
env#out_channel#close_out()
)
with _ -> ()
(* We were supposed to report the error but if that itself raised
an exception (e.g. the output channel was closed), there is not
much we can do... *)
let handle_uncaught_exn (env:cgi_environment) = function
| HTTP(`Continue, _)
| HTTP(`Switching_protocols, _)
(* 2xx: (successful) *)
| HTTP(`Ok, _)
| HTTP(`Created, _)
| HTTP(`Accepted, _)
| HTTP(`Non_authoritative, _)
| HTTP(`No_content, _)
| HTTP(`Reset_content, _)
| HTTP(`Partial_content, _)
(* 3xx: (redirection) *)
| HTTP(`Multiple_choices, _)
| HTTP(`Moved_permanently, _)
| HTTP(`Found, _)
| HTTP(`See_other, _)
| HTTP(`Not_modified, _)
| HTTP(`Use_proxy, _)
| HTTP(`Temporary_redirect, _) ->
(* It is s a bit funny to raise an exception not indicating a
failure (this library does not do it). We interpret it as a
normal but early termination of the response *)
env#out_channel#close_out();
(* 4xx: (client error) *)
| HTTP(`Bad_request, s) ->
error_page env `Bad_request [] s
"You <i>should not</i> repeat the request without modifications."
| HTTP(`Unauthorized, s) ->
let challenge = "" in
error_page env `Unauthorized ["WWW-Authenticate", [challenge]] s ""
| HTTP(`Payment_required, s) ->
error_page env `Payment_required [] s ""
| HTTP(`Forbidden, s) ->
error_page env `Forbidden [] s
"The request <i>should not</i> be repeated."
| HTTP(`Not_found, s) ->
error_page env `Not_found [] s
"The server has not found anything matching the Request-URI."
| HTTP(`Method_not_allowed, s) ->
(* Allow header must be sent *)
let meths =
List.map
string_of_http_method
env#config.permitted_http_methods in
let allow = String.concat ", " meths in
error_page env `Method_not_allowed ["Allow", [allow]] s
("Only the following methods are allowed: " ^ allow)
| HTTP(`Not_acceptable, s) ->
error_page env `Not_acceptable [] s
"The resource identified by the request is only capable of
generating response entities which have content characteristics
not acceptable according to the accept headers sent in the request."
| HTTP(`Proxy_auth_required, s) ->
error_page env `Proxy_auth_required [] s
"Your browser <i>must</i> first authenticate itself with the proxy."
| HTTP(`Request_timeout, s) ->
error_page env `Request_timeout [] s
"Your browser waited too long to send the data. You can repeat
the request without modifications at any later time."
| HTTP(`Conflict, s) ->
error_page env `Bad_request [] s
"The request could not be completed due to a conflict with the
current state of the resource. Please resolve the conflict and
resubmit the request. "
| HTTP(`Gone, s) ->
error_page env `Bad_request [] s
"The requested resource is no longer available at the server and no
forwarding address is known."
| HTTP(`Length_required, s) ->
error_page env `Bad_request [] s
"Content-Length is <i>required. You <i>may</i> repeat the request
with a valid Content-Length."
| HTTP(`Precondition_failed, s) ->
error_page env `Bad_request [] s
"The precondition given in one or more of the request-header fields
evaluated to false when it was tested on the server. "
| HTTP(`Request_entity_too_large, s) ->
error_page env `Request_entity_too_large [] s
"Please try again with smaller files!"
| HTTP(`Request_uri_too_long, s) ->
error_page env `Request_uri_too_long [] s
"The server is refusing to service the request because the
Request-URI is bigger than 4Mb."
| HTTP(`Unsupported_media_type, s) ->
let ct =
String.concat ", " env#config.permitted_input_content_types in
error_page env `Unsupported_media_type [] s
("The following Content-Type are authorized: " ^ ct)
| HTTP(`Requested_range_not_satisfiable, s) ->
error_page env `Requested_range_not_satisfiable [] s ""
| HTTP(`Expectation_failed, s) ->
error_page env `Expectation_failed [] s ""
(* 5xx: (server error) *)
| HTTP(`Internal_server_error, s) ->
error_page env `Internal_server_error [] s
"Please write to the author of the application to tell him!"
| HTTP(`Not_implemented, s) ->
error_page env `Not_implemented [] s
"The server does not support the functionality required to fulfill
the request."
| HTTP(`Bad_gateway, s) ->
error_page env `Bad_gateway [] s
"The server, while acting as a gateway or proxy, received an invalid
response from the upstream server it accessed in attempting to
fulfill the request."
| HTTP(`Service_unavailable, s) ->
error_page env `Service_unavailable [] s
"The server is currently unable to handle the request due to a
temporary overloading or maintenance of the server.
Please try again later."
| HTTP(`Gateway_timeout, s) ->
error_page env `Gateway_timeout [] s
"The server, while acting as a gateway or proxy, did not receive a
timely response from the upstream server it accessed in attempting to
complete the request."
| HTTP(`Http_version_not_supported, s) ->
error_page env `Http_version_not_supported [] s
"The server does not support, or refuses to support, the HTTP
protocol version that was used in the request message."
(* Other exceptions *)
| Exit ->
(* FIXME: This is seen as an acceptable way to terminate early. *)
env#out_channel#close_out()
| exn ->
error_page env `Internal_server_error []
(Netexn.to_string exn)
"This indicates an error in the application (not in the supporting
library). Please report it to the author or company that runs this
software."
(* REMARK: With this choice of [exn_handler], the user may add some
code before and after the execution of [run_cgi] but does not have
to re-raise exceptions it does not care about (as is the case if
[exn_handler] is passed all exceptions as arg). *)
let exn_handler_default (env:cgi_environment) ~exn_handler ~finally run_cgi =
let special_exn = ref None in
(try
exn_handler env (fun () -> special_exn := run_cgi());
finally()
with
| Exit ->
(* [Exit] is considered as a proper way to terminate early *)
finally()
| exn when env#config.default_exn_handler ->
(* exception not handled (or raised) by the user provided
[exn_handler] *)
handle_uncaught_exn env exn;
finally()
);
match !special_exn with None -> () | Some e -> raise e
(* Accumulate input header and CGI properties
***********************************************************************)
(* The MSIE Content-Type bug is dealt with when the environment object
is created. The field names of [inheader] MUST be lowercased to
input to the class [environment]. *)
let shift_to_lowercase = Char.code 'a' - Char.code 'A'
let update_props_inheader ((name, value) as nv) (props, inheader) =
if name = "CONTENT_TYPE" then
(props, ("content-type", value) :: inheader)
else if name = "CONTENT_LENGTH" then
(props, ("content-length", value) :: inheader)
else if is_prefix "HTTP_" name then (
(* Remove the "HTTP_" from the name, lowercase, and convert any
'_' to '-'. *)
let len = String.length name - 5 in
let hname = String.sub name 5 len in
for i = 0 to len - 1 do
unsafe_set hname i
(match unsafe_get hname i with
| '_' -> '-'
| 'A' .. 'Z' as c -> (* ASCII *)
Char.unsafe_chr(Char.code c + shift_to_lowercase)
| c -> c)
done;
(props, (hname, value) :: inheader)
)
else
(nv :: props, inheader)
