(* netcgi_fcgi.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.
*)
(* FIXME: how do we handle SIGTERM ? *)
(* FastCGI protocol (version 1) according to the specification found
at http://www.fastcgi.com/devkit/doc/fcgi-spec.html
*)
(** There is a bug in mod_fastcgi with the following symptom:
"If the answer to a request to the server has more than 8192 Bytes
and less then about 16000 Bytes of payload, the HTTP header is not
counted, the request will fail with an idle timeout. But the FCGI
server has delivered the complete response to the apache server in
time."
A fix is to close the socket at the end of the request -- in
addition the spec. sec. 3.5 says "A simple application gets a
significant performance boost by closing the transport connection
when it has finished writing its response."
This of course disallows the multiplexing of requests. As moreover
this library will deal with 1 request at a time, there is no much
point in queuing the packets for the other requests, better
DISALLOW MULTIPLEXING.
TODO: If the need is felt, a multithreaded connector running
requests in separated threads makes sense.
*)
(* Monomorphic version for speed *)
let min (i:int) j = if i <= j then i else j
open Netcgi_common
let fcgi_version = '\001'
let fcgi_listensock = Unix.stdin
(* FCGI record types *)
type fcgi_type = char
let fcgi_begin_request = '\001'
let fcgi_abort_request = '\002'
let fcgi_end_request = '\003'
let fcgi_params = '\004'
let fcgi_stdin = '\005'
let fcgi_stdout = '\006'
let fcgi_stderr = '\007'
let fcgi_data = '\008'
let fcgi_get_values = '\009'
let fcgi_get_values_result = '\010'
let fcgi_unknown_type = '\011'
type role = [`Responder | `Authorizer | `Filter]
(* Values for protocolStatus component of FCGI_EndRequestBody *)
type protocol_status =
| REQUEST_COMPLETE
| CANT_MPX_CONN
| OVERLOADED
| UNKNOWN_ROLE
exception Abort of int
(* [Abort id] is raised when a FCGI_ABORT_REQUEST record is
received. *)
let fcgi_keep_conn = 0x1
(* Mask for flags component of FCGI_BeginRequestBody *)
(* Get the list of valid IP addresses for the Web server or [] if not set. *)
let fcgi_web_server_addrs =
try
let is_comma c = (c = ',') in
let addrs = rev_split is_comma (Unix.getenv "FCGI_WEB_SERVER_ADDRS") in
List.map Unix.inet_addr_of_string addrs
with
Not_found | Failure _ -> []
(************************************************************************)
(* Output *)
let set_length4 s ofs n =
(* 4 bytes encoding of the length [n] in the string [s] from
position [ofs]. *)
Bytes.set s (ofs+3) (Char.unsafe_chr(n land 0xFF));
let n = n lsr 8 in
Bytes.set s (ofs+2) (Char.unsafe_chr(n land 0xFF));
let n = n lsr 8 in
Bytes.set s (ofs+1) (Char.unsafe_chr(n land 0xFF));
Bytes.set s ofs (Char.chr((n lsr 8) lor 0x80))
(* [lengths_of_key_val k v] returns a string encoding the lengths
of the key-value pair [(k,v)] according to fcgi spec: 3.4
Name-Value Pairs. *)
let lengths_of_key_val k v =
let klen = String.length k
and vlen = String.length v in
if klen < 128 then
if vlen < 128 then begin
let s = Bytes.create 2 in
Bytes.set s 0 (Char.chr klen);
Bytes.set s 1 (Char.chr vlen);
s
end
else begin
let s = Bytes.create 5 in
Bytes.set s 0 (Char.chr klen);
set_length4 s 1 vlen;
s
end
else
if vlen < 128 then begin
let s = Bytes.create 5 in
set_length4 s 0 klen;
Bytes.set s 4 (Char.chr vlen);
s
end
else begin
let s = Bytes.create 8 in
set_length4 s 0 klen;
set_length4 s 4 vlen;
s
end
(* Add the key-value pair [k], [v] to the buffer [buf]. *)
let add_key_val buf k v =
Netbuffer.add_bytes buf (lengths_of_key_val k v);
Netbuffer.add_string buf k;
Netbuffer.add_string buf v
(* In the following, we stack several netchannels. The goal is to reduce
* the number of system calls (Unix.write) as much as possible. These
* calls are much more expensive than the additional overhead of stacking.
*
* In particular, the stack looks as follows:
*
* - TOP: user_out_channel
* Data written to this channel is encoded as fcgi packet. No buffer.
* Maybe it would be better to have another buffer before the encoding
* happens to make the packets as large as possible. However, we usually
* have already a transactional buffer on top of the user_out_channel.
* - fcgi_out_channel
* Data written to this channel must already be formatted as fcgi packets.
* Auxiliary methods generate such packets from user data. No buffer.
* - Netchannels.buffered_raw_out_channel
* Implements a buffer.
* - prim_out_channel
* Only purpose is to disable close_out. The file descriptor is not
* closed by the channel stack
* - BOTTOM: Netchannels.output_descr
* Maps channel methods to system calls. No buffer.
*
* For the input direction stacking is similar.
*)
(* This channel writes to the descriptor, but does not forward the
* close request (fd is kept open)
*)
class prim_out_channel fd =
object(self)
inherit Netchannels.output_descr fd
method close_out() = ()
(* don't close fd *)
end
(* This channel includes a buffer and some additional fcgi primitives *)
class fcgi_out_channel fd =
let prim_ch = new prim_out_channel fd in
object (self)
inherit Netchannels.buffered_raw_out_channel
~buffer_size:8192
prim_ch
inherit Netchannels.augment_raw_out_channel
(* reduces additional methods like really_output to the more
primitive ones from Netchannels.buffered_raw_out_channel
*)
(* [output_packet ty id s ofs len] sends a request [id],
a record of type [ty] whose data is the substring [s.[ofs .. ofs +
len - 1]] where [len <= 65535]. *)
method output_packet ty id ts ofs len =
assert(len <= 0xFFFF);
let padding_len =
let r = len mod 8 in
if r = 0 then 0 else 8 - r in
(* We keep total size a multiple of 8 bytes so the web server can
easily align the data for efficency. *)
let r = Bytes.create 8 in
Bytes.set r 0 fcgi_version;
Bytes.set r 1 ty;
Bytes.set r 2 (Char.chr(id lsr 8));
Bytes.set r 3 (Char.chr(id land 0xFF)); (* requestId *)
Bytes.set r 4 (Char.chr(len lsr 8));
Bytes.set r 5 (Char.chr(len land 0xFF)); (* contentLength *)
Bytes.set r 6 (Char.chr(padding_len)); (* paddingLength *)
Bytes.set r 7 '\000';
self # output_bytes r;
( match ts with
| `String s -> self # really_output_string s ofs len
| `Bytes s -> self # really_output s ofs len
);
self # really_output r 0 padding_len (* Padding (garbage) *)
(* [send_user_data ty id s pos len] sends a request [id],
a record of type [ty] whose data is [s]. If necessary, data is split
into several packets
*)
method send_user_data ty id s pos len =
let s_len =
match s with
| `String s -> String.length s
| `Bytes s -> Bytes.length s in
let rec loop pos len =
let l = min (min len (s_len - pos)) 0xFFFF in
if l > 0 then (
self # output_packet ty id s pos l;
loop (pos+l) (len-l)
)
in
if len > 0 then
loop pos len
(* End the request, either because the handling script ended or
because it was rejected. [exit_code] is an application-level
status code (the meaning depends on the role). [status] is a
protocol-level status code. *)
method send_end_request id exit_code status =
let r = Bytes.make 8 '\000' in
Bytes.set r 3 (Char.chr(exit_code land 0xFF)); (* appStatus (4 bytes) *)
let exit_code = exit_code lsr 8 in
Bytes.set r 2 (Char.chr(exit_code land 0xFF));
let exit_code = exit_code lsr 8 in
Bytes.set r 1 (Char.chr(exit_code land 0xFF));
Bytes.set r 0 (Char.chr(exit_code lsr 8));
Bytes.set r 4 (Char.chr(match status with
| REQUEST_COMPLETE -> 0
| CANT_MPX_CONN -> 1
| OVERLOADED -> 2
| UNKNOWN_ROLE -> 3)); (* protocolStatus *)
self # output_packet fcgi_end_request id (`Bytes r) 0 8
(* Response to a managment record of type [t] that this library does
not understand. *)
method send_unknown_type t =
let r = Bytes.make 8 '\000' in
Bytes.set r 0 t;
self # output_packet fcgi_unknown_type 0 (`Bytes r) 0 8
method send_stdout_end_response id =
(* Close the stream FCGI_STDOUT by sending an empty record *)
self # output_packet fcgi_stdout id (`String "") 0 0
method send_stderr_end_response id =
(* Close the stream FCGI_STDERR by sending an empty record *)
self # output_packet fcgi_stderr id (`String "") 0 0
(* [send_values props ~max_conns] send back (on [fd])
an appropriate FCGI_GET_VALUES_RESULT response for a
FCGI_GET_VALUES record [r]. *)
method send_values (props : (string * string) list) ~max_conns =
let buf = Netbuffer.create 64 in
if List.mem_assoc "FCGI_MAX_CONNS" props then
add_key_val buf "FCGI_MAX_CONNS" (string_of_int max_conns);
if List.mem_assoc "FCGI_MAX_REQS" props then
add_key_val buf "FCGI_MAX_REQS" "1"; (* no multiplexing! *)
if List.mem_assoc "FCGI_MPXS_CONNS" props then
add_key_val buf "FCGI_MPXS_CONNS" "0"; (* no multiplexing! *)
let s = Netbuffer.to_bytes buf in
self # output_packet fcgi_get_values_result 0 (`Bytes s) 0 (Bytes.length s)
end
(* This channel wraps user payload into fcgi packets. The [id] comes from
the previously received request
*)
class user_out_channel fcgi_ch id =
object(self)
val mutable pos_out = 0
inherit Netchannels.augment_raw_out_channel
(* reduces additional methods like really_output to the more
primitive ones implemented below
*)
method output s pos len =
fcgi_ch # send_user_data fcgi_stdout id (`Bytes s) pos len;
pos_out <- pos_out + len;
len
method flush() =
fcgi_ch # flush()
method close_out() =
try
fcgi_ch # flush()
with
| error ->
Netlog.logf `Err
"Netcgi_fcgi: Suppressed error in close_out: %s"
(Netexn.to_string error);
method pos_out = pos_out
end
(************************************************************************)
(* Input *)
(* FCGI dialog takes the form of records (spec. section 3.3). The
incoming ones will be decoded to the following structure. *)
type record = {
version : int; (* at present = 1 *)
ty : char; (* type, see the constants above *)
id : int; (* FastCGI request id; 0 = management *)
length : int;
(* length (<= 65535) is the number of bytes of data. The data
itself is not part of this record, input functions will take a
buffer [data] and return the record. [data.[0 .. length-1]] will
be the actual data read. This scheme has been chosen in order to
be able to reuse a given string as buffer. *)
}
(* [get_length data ofs] returns the [(l, o)] where [l] is length at
offset [ofs] encoded according to the Name-Value Pairs specs
(section 3.4) and [o] is the next offset.
It is assumed that [0 <= ofs < String.length s].
@raise Failure if the spec is not respected. *)
let get_length data ofs =
let b = Char.code(Bytes.get data ofs) in
if b lsr 7 = 0 then
(b, ofs + 1)
else begin
if ofs + 3 >= Bytes.length data then
failwith "Netcgi_fcgi.update_props_inheader";
let b2 = Char.code(Bytes.get data (ofs + 1))
and b1 = Char.code(Bytes.get data (ofs + 2))
and b0 = Char.code(Bytes.get data (ofs + 3)) in
(* Note: this must also work on 64 bit platforms! *)
(((b land 0x7F) lsl 24) + (b2 lsl 16) + (b1 lsl 8) + b0, ofs + 4)
end
(** [get_props_inheader data datalen props_inheader] adds to
[props_inheader] the key-value pairs contained in [data]. The
keys are uppercased (CGI/1.1 says they must be treated case
insensitively).
@raise Failure if the key or val lengths exceed the length of the
string [data]. *)
let get_props_inheader =
let rec add data ofs datalen props_inheader =
if ofs < datalen then begin
let namelen, ofs = get_length data ofs in
if ofs >= datalen then failwith "Netcgi_fcgi.get_props_inheader";
let valuelen, ofs = get_length data ofs in
let ofs_value = ofs + namelen in
let ofs_next = ofs_value + valuelen in
if ofs_next > datalen then failwith "Netcgi_fcgi.get_props_inheader";
let name = STRING_UPPERCASE (Bytes.sub_string data ofs namelen)
and value = Bytes.sub_string data ofs_value valuelen in
let props_inheader =
Netcgi_common.update_props_inheader (name, value) props_inheader in
add data ofs_next datalen props_inheader
end
else props_inheader
in
(fun data datalen props_inheader ->
add data 0 datalen props_inheader
)
(* This channel reads from the descriptor, but does not forward the
* close request (fd is kept open)
*)
class prim_in_channel fd =
object(self)
inherit Netchannels.input_descr fd
method close_in() = ()
(* don't close fd *)
end
(* On the input side, this channel includes a buffer and some additional
fcgi primitives. The output side is inherited from fcgi_out_channel,
i.e. this channel is bidirectional.
*)
class fcgi_channel fd =
let prim_ch = new prim_in_channel fd in
object(self)
inherit fcgi_out_channel fd
(* This is both an input and output channel *)
inherit Netchannels.buffered_raw_in_channel
~buffer_size:8192
prim_ch
inherit Netchannels.augment_raw_in_channel
(* reduces additional methods like really_input to the more
primitive ones from Netchannels.buffered_raw_in_channel.
Note that input_line is slow (but not used here)
*)
val padding_buffer = Bytes.create 0xFF
method input_padding len =
self # really_input padding_buffer 0 len
val record_buffer = Bytes.create 65536 (* 64K *)
method record_buffer = record_buffer
(** [let r = input_record ()] reads the next record from the socket [fd],
returns the information as a record [r] and puts the data into
[record_buffer]
*)
method input_record() =
let header = Bytes.create 8 in
self # really_input header 0 8;
let version = Char.code(Bytes.get header 0)
and id = Char.code(Bytes.get header 2) lsl 8 +
Char.code(Bytes.get header 3)
and len = Char.code(Bytes.get header 4) lsl 8 +
Char.code(Bytes.get header 5)
and padding = Char.code(Bytes.get header 6) in
self # really_input record_buffer 0 len;
self # input_padding padding;
{ version = version;
ty = Bytes.get header 1;
id = id;
length = len }
(* This function returns the next application record. Management
records (of id=0) are dealt with automatically. (This is very
useful to get them out of the way for several functions below.) *)
method input_app_record ~max_conns =
let r = self # input_record () in
if r.id = 0 then (
(* null request ID => management record *)
if r.ty = fcgi_get_values then (
let props =
try fst(get_props_inheader record_buffer r.length ([], []))
with Failure _ -> [] in
self # send_values props ~max_conns;
self # input_app_record ~max_conns
)
else (
self # send_unknown_type r.ty;
self # input_app_record ~max_conns
)
)
else r
(* Get the next input record of type [ty] and id [id], put the data
into [record_buffer] and return the record.
@raise Abort if th server send a FCGI_ABORT_REQUEST for the current
request id.
This function is useful because we do not allow multiplexing and
because the protocol is nearly sequential.
BEWARE: you should not call this function after receiving an empty
record (indicating that the stream is closed), otherwise it will
loop indefinitely waiting for a record that will never come.
*)
method input_stream_record ty id ~max_conns =
let r = self # input_app_record ~max_conns in
if r.id <> id then (
(* Another id -- and not a management record. Close the new
request and try again. *)
self # send_end_request r.id 0 CANT_MPX_CONN;
self # input_stream_record ty id ~max_conns
)
else if r.ty = fcgi_abort_request then
raise(Abort id)
else if r.ty <> ty then
(* Not the expected type; ignore the record (who knows, it may be
some filter data that we never read). *)
self # input_stream_record ty id ~max_conns
else
r (* Record of the desired type *)
(* [input_begin_request ~max_conns] handles management records and
skip the other ones till a FCGI_BEGIN_REQUEST is received, in which
case [(id, role, flags)] is returned. *)
method input_begin_request ~max_conns : (int * role * int) =
let r = self # input_app_record ~max_conns in
if r.ty = fcgi_begin_request && r.length = 8 then (
let role =
Char.code(Bytes.get record_buffer 0) lsl 8 +
Char.code(Bytes.get record_buffer 1)
and flags =
Char.code(Bytes.get record_buffer 2) in
match role with
| 1 -> (r.id, `Responder, flags)
| 2 -> (r.id, `Authorizer, flags)
| 3 -> (r.id, `Filter, flags)
| _ ->
(* Rejecting this request that has an unknown role and waiting
for the next one. *)
self # send_end_request r.id 0 UNKNOWN_ROLE;
self # input_begin_request ~max_conns
)
else
self # input_begin_request ~max_conns
(* Accumulate the stream of params into a list of properties and
input_header. *)
method input_props_inheader id ~max_conns props_inheader =
let r = self # input_stream_record fcgi_params id ~max_conns in
if r.length = 0 then
(* End of stream *)
props_inheader
else
let props_inheader =
get_props_inheader record_buffer r.length props_inheader in
self # input_props_inheader id ~max_conns props_inheader
end
(* This channel unwraps user payload from fcgi packets of type [ty]
(either fcgi_stdin or fcgi_data).
*)
class user_in_channel fcgi_ch ty id ~max_conns =
object(self)
inherit Netchannels.augment_raw_in_channel
(* Define derived methods. Note that input_line is slow. This is ok
because the MIME scanner does not rely on it.
*)
val mutable buf_pos = 0
val mutable buf_len = 0
val mutable pos_in = 0
method input s pos len =
if buf_len <= 0 then (
let r = fcgi_ch # input_stream_record ty id ~max_conns in
if r.length = 0 then
raise End_of_file;
buf_pos <- 0;
buf_len <- r.length
);
let l = min len buf_len in
Bytes.blit (fcgi_ch # record_buffer) buf_pos s pos l;
buf_pos <- buf_pos + l;
buf_len <- buf_len - l;
pos_in <- pos_in + l;
l
method close_in() = ()
method pos_in = pos_in
end
(* When no input of FCGI_DATA is required, we need a dummy object to
play the input channel role. *)
class closed_in_obj : Netchannels.in_obj_channel =
object
method input (_:Bytes.t) (_:int) (_:int) = raise Netchannels.Closed_channel
method close_in () = ()
method pos_in = raise Netchannels.Closed_channel
method really_input (_:Bytes.t) (_:int) (_:int) =
raise Netchannels.Closed_channel
method really_input_string (_:int) =
raise Netchannels.Closed_channel
method input_char () = raise Netchannels.Closed_channel
method input_byte () = raise Netchannels.Closed_channel
method input_line () = raise Netchannels.Closed_channel
end
(************************************************************************)
(** Environment *)
(* Creates the environment including the output channel *)
class fcgi_environment ?log_error ~config ~properties ~input_header fcgi_ch id
: Netcgi_common.cgi_environment =
let user_ch = new user_out_channel fcgi_ch id in
let fcgi_log_error id msg : unit =
fcgi_ch # send_user_data
fcgi_stderr id (`String msg) 0 (String.length msg) in
object
inherit cgi_environment ~config ~properties ~input_header user_ch
(* Override to use the correct channel *)
method log_error msg =
match log_error with
| None -> fcgi_log_error id msg
| Some f -> f msg
end
(************************************************************************)
(** CGI abstraction and request handling *)
class type cgi =
object
inherit Netcgi.cgi
method role : role
method data : Netchannels.in_obj_channel
method data_length : int
method data_mtime : float
end
class fcgi (role:role) id data_ch ~max_conns env op req_meth args : cgi =
object
inherit Netcgi_common.cgi env op req_meth args
val data_stream = data_ch
val role = role
val data_length =
try int_of_string(env#cgi_property "FCGI_DATA_LENGTH") with _ -> 0
val data_mtime =
try float_of_string(env#cgi_property "FCGI_DATA_LAST_MOD") with _ -> 0.
method role = role
method data = data_stream
method data_length = data_length
method data_mtime = data_mtime
end
let handle_request config
output_type arg_store exn_handler f ~max_conns ~log fd =
let fcgi_ch = new fcgi_channel fd in
try
let (id, role, flags) =
fcgi_ch # input_begin_request ~max_conns in
let (properties, input_header) =
fcgi_ch # input_props_inheader id ~max_conns ( [], [] ) in
let env =
new fcgi_environment
?log_error:log ~config ~properties ~input_header fcgi_ch id in
(* Now that one knows the environment, one can deal with exn. *)
exn_handler_default env ~exn_handler
(fun () ->
try
let input_ch =
new user_in_channel fcgi_ch fcgi_stdin id ~max_conns in
let data_ch =
if role = `Filter then
new user_in_channel fcgi_ch fcgi_data id ~max_conns
else
new closed_in_obj in
(* Note that this will read [input_ch] before [data_ch] *)
let cgi =
cgi_with_args
(new fcgi role id data_ch ~max_conns)
env output_type input_ch arg_store in
(try
f cgi;
cgi#out_channel#commit_work();
cgi#finalize()
with e when config.default_exn_handler ->
cgi#finalize(); raise e);
None
with
| Abort _ as e -> Some e
| End_of_file as e -> Some e
)
~finally:
(fun () ->
fcgi_ch # send_stderr_end_response id;
fcgi_ch # send_stdout_end_response id;
fcgi_ch # send_end_request id 0 REQUEST_COMPLETE;
fcgi_ch # flush()
);
if flags land fcgi_keep_conn = 0 then
`Conn_close_linger
else
`Conn_keep_alive
with
| Abort id ->
(* FCGI_ABORT_REQUEST received. The exit_status should come from
the application the spec says. However, in general, the
application will not have yet started, so just return 0.
(Since we so not allow multiplexed requests, it is more likely
that the web server just closes the connection but we handle it
anyway.) *)
`Conn_close
| End_of_file ->
`Conn_close
| error ->
`Conn_error error
(* [handle_connection fd .. f] handle an accept()ed connection,
reading incoming records on the file descriptor [fd] and running
[f] for each incoming request. *)
let rec handle_connection_1 config output_type arg_store exn_handler f
~max_conns ~one_shot fd =
let fd_cmd =
handle_request config output_type arg_store exn_handler f ~max_conns
~log:None fd in
(* FIXME: because of the bug explained in the beginning of this
file, we would like to close the file descriptor when the request
is complete.
If we do nothing, one sees the entire output but get an "idle
timeout". If we close [fd], one sometimes get "Broken pipe:
... write failed"! So we just shutdown. Do we risk fd
shortage???
[gerd]: We need to do a lingering close.
*)
let fd_cmd' =
if not one_shot then
fd_cmd
else
if fd_cmd = `Conn_keep_alive then
`Conn_close_linger (* Close anyway in this case *)
else
fd_cmd in
match fd_cmd' with
| `Conn_close ->
(try Unix.shutdown fd Unix.SHUTDOWN_ALL with _ -> ());
Netlog.Debug.release_fd fd;
Unix.close fd
| `Conn_close_linger ->
Unix.setsockopt_optint fd Unix.SO_LINGER (Some 15);
(try Unix.shutdown fd Unix.SHUTDOWN_ALL with _ -> ());
Netlog.Debug.release_fd fd;
Unix.close fd
| `Conn_keep_alive ->
(* The server is supposed to take care of closing [fd]. (Tail
recursiveness is important as many requests may be handled by
this fun.) *)
handle_connection_1
config output_type arg_store exn_handler f
~max_conns ~one_shot fd
| `Conn_error e ->
(try Unix.shutdown fd Unix.SHUTDOWN_ALL with _ -> ());
Netlog.Debug.release_fd fd;
Unix.close fd;
raise e
let handle_connection config output_type arg_store exn_handler f
~max_conns ~one_shot fd =
Netlog.Debug.track_fd
~owner:"Netcgi_fcgi"
~descr:("connection from " ^
try Netsys.string_of_sockaddr(Netsys.getpeername fd)
with _ -> "(noaddr)")
fd;
handle_connection_1
config output_type arg_store exn_handler f
~max_conns ~one_shot fd
let default_allow server =
match server with
| Unix.ADDR_UNIX _ -> true
| Unix.ADDR_INET(addr,_) ->
fcgi_web_server_addrs = [] || List.mem addr fcgi_web_server_addrs
let run ?(config=Netcgi.default_config)
?(allow=default_allow)
?(output_type=(`Direct "":Netcgi.output_type))
?(arg_store=(fun _ _ _ -> `Automatic))
?(exn_handler=(fun _ f -> f()))
?socket
?sockaddr
?port
f =
(* FIXME: Under M$win, the web server communicates with a FCGI script
that it launches by means of a named pipe [fd] (contrarily to the
spec). The requests are all sent through that pipe. Thus there is
a single connection. *)
let sock = match (socket, sockaddr, port) with
| (Some s, _, _) -> s
| (None, None, None) ->
(* FastCGI launched by the web server *)
fcgi_listensock
| (None, Some _, _)
| (None, _, Some _) ->
let saddr = match (sockaddr, port) with
| (Some sa, _) -> sa
| (None, Some p) -> Unix.ADDR_INET(Unix.inet_addr_loopback, p)
| _ -> failwith "not reached"
in
(* FastCGI on a distant machine, listen on the given socket. *)
let sock =
Unix.socket (Unix.domain_of_sockaddr saddr) Unix.SOCK_STREAM 0 in
Unix.setsockopt sock Unix.SO_REUSEADDR true;
Unix.bind sock saddr;
Unix.listen sock 5;
Netlog.Debug.track_fd
~owner:"Netcgi_fcgi"
~descr:("master " ^ Netsys.string_of_sockaddr saddr)
sock;
sock
in
let max_conns = 1 (* single process/thread *) in
while true do
let (fd, server) = Netsys.restart Unix.accept sock in
try
if allow server then (
let one_shot = (match server with
| Unix.ADDR_UNIX _ -> true
| Unix.ADDR_INET _ -> false) in
handle_connection
config output_type arg_store exn_handler f
~max_conns ~one_shot fd
);
with
| e when config.default_exn_handler ->
(* We cannot log the error because [fd] is already closed, and
we can assume anyway that the connection has crashed before.
Don't do anything.
*)
()
done
(* To ckeck:
http://mapserver.gis.umn.edu/cgi-bin/wiki.pl?FastCGIOnWin32
*)
