(* Simple example for event-based engines *)
open Printf
let generate (cgi : Netcgi.cgi_activation) =
(* A Netcgi-based content provider *)
cgi # set_header
~cache:`No_cache
~content_type:"text/html; charset=\"iso-8859-1\""
();
let data =
"<html>\n" ^
" <head><title>Easy Engine</title></head>\n" ^
" <body>\n" ^
" <a href='foo'>GET something</a><br>\n" ^
" <form method=POST encoding='form-data'>\n" ^
" <input type=hidden name=sample value='sample'>\n" ^
" <input type=submit value='POST something'>\n" ^
" </form>\n" ^
" </body>\n" ^
"</html>" in
cgi # output # output_string data;
cgi # output # commit_work();
;;
let on_request notification =
(* This function is called when the full HTTP request has been received. For
* simplicity, we create a [std_activation] to serve the request.
*
* An advanced implementation could set up further notifications to get informed
* whenever there is space in the response buffer for additional output.
* Currently, data is fully buffered (first
* in the transactional buffer, then in the response buffer), and only when
* the message is complete, the transmission to the client starts.
* By generating only the next part of the response when there is space in
* the response buffer, the advanced implementation can prevent that the
* buffers become large.
*)
printf "Received HTTP request\n";
flush stdout;
( try
let env = notification # environment in
let cgi =
Netcgi_common.cgi_with_args
(new Netcgi_common.cgi)
(env :> Netcgi.cgi_environment)
Netcgi.buffered_transactional_outtype
env#input_channel
(fun _ _ _ -> `Automatic) in
generate cgi;
with
e ->
printf "Uncaught exception: %s\n" (Printexc.to_string e);
flush stdout
);
notification # schedule_finish()
;;
let on_request_header (notification : Nethttpd_engine.http_request_header_notification) =
(* After receiving the HTTP header: We always decide to accept the HTTP body, if any
* is following. We do not set up special processing of this body, it is just
* buffered until complete. Then [on_request] will be called.
*
* An advanced server could set up a further notification for the HTTP body. This
* additional function would be called whenever new body data arrives. (Do so by
* calling [notification # environment # input_ch_async # request_notification].)
*)
printf "Received HTTP header\n";
flush stdout;
notification # schedule_accept_body ~on_request ()
;;
let serve_connection ues fd =
(* Creates the http engine for the connection [fd]. When a HTTP header is received
* the function [on_request_header] is called.
*)
printf "Connected\n";
flush stdout;
let config = Nethttpd_engine.default_http_engine_config in
Unix.set_nonblock fd;
let http_engine =
new Nethttpd_engine.http_engine ~on_request_header () config fd ues in
()
;;
let rec accept ues srv_sock_acc =
(* This function accepts the next connection using the [acc_engine]. After the
* connection has been accepted, it is served by [serve_connection], and the
* next connection will be waited for (recursive call of [accept]). Because
* [server_connection] returns immediately (it only sets the callbacks needed
* for serving), the recursive call is also done immediately.
*)
let acc_engine = srv_sock_acc # accept() in
Uq_engines.when_state ~is_done:(fun (fd,fd_spec) ->
if srv_sock_acc # multiple_connections then (
serve_connection ues fd;
accept ues srv_sock_acc
) else
srv_sock_acc # shut_down())
~is_error:(fun _ -> srv_sock_acc # shut_down())
acc_engine;
;;
let start() =
(* We set up [lstn_engine] whose only purpose is to create a server socket listening
* on the specified port. When the socket is set up, [accept] is called.
*)
printf "Listening on port 8765\n";
flush stdout;
let ues = Unixqueue.create_unix_event_system () in
(* Unixqueue.set_debug_mode true; *)
let opts = { Uq_server.default_listen_options with
Uq_server.lstn_backlog = 20;
Uq_server.lstn_reuseaddr = true } in
let lstn_engine =
Uq_server.listener
(`Socket(`Sock_inet(Unix.SOCK_STREAM, Unix.inet_addr_any, 8765) ,opts)) ues in
Uq_engines.when_state ~is_done:(accept ues) lstn_engine;
(* Start the main event loop. *)
Unixqueue.run ues
;;
let conf_debug() =
(* Set the environment variable DEBUG to either:
- a list of Netlog module names
- the keyword "ALL" to output all messages
- the keyword "LIST" to output a list of modules
By setting DEBUG_WIN32 additional debugging for Win32 is enabled.
*)
let debug = try Sys.getenv "DEBUG" with Not_found -> "" in
if debug = "ALL" then
Netlog.Debug.enable_all()
else if debug = "LIST" then (
List.iter print_endline (Netlog.Debug.names());
exit 0
)
else (
let l = Netstring_str.split (Netstring_str.regexp "[ \t\r\n]+") debug in
List.iter
(fun m -> Netlog.Debug.enable_module m)
l
);
if (try ignore(Sys.getenv "DEBUG_WIN32"); true with Not_found -> false) then
Netsys_win32.Debug.debug_c_wrapper true
;;
Netsys_signal.init();
conf_debug();
start();;
