(* This is a port of the "adder" of the Ocamlnet examples to Nethttpd,
* using only the reactor module.
*)
open Netcgi;;
open Nethttpd_reactor;;
open Printf;;
let rec service_loop reactor netcgi_processor =
match reactor # next_request () with
| Some req ->
( try
req # accept_body(); (* Always! *)
let env =
req # 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
netcgi_processor cgi
with
e ->
printf "Uncaught exception: %s\n" (Printexc.to_string e);
flush stdout
);
req # finish();
service_loop reactor netcgi_processor
| None ->
()
;;
let serve fd netcgi_processor =
let config = Nethttpd_reactor.default_http_reactor_config in
let reactor = new http_reactor config fd in
service_loop reactor netcgi_processor;
reactor # close()
;;
let start netcgi_processor =
let master_sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Unix.setsockopt master_sock Unix.SO_REUSEADDR true;
Unix.bind master_sock (Unix.ADDR_INET(Unix.inet_addr_any, 8765));
Unix.listen master_sock 100;
printf "Listening on port 8765\n";
flush stdout;
while true do
try
let conn_sock, _ = Unix.accept master_sock in
Unix.set_nonblock conn_sock;
serve conn_sock netcgi_processor
with
Unix.Unix_error(Unix.EINTR,_,_) -> () (* ignore *)
done
;;
(**********************************************************************
* The following is copied, almost verbatim, from add.ml
**********************************************************************)
(***********************************************************************
* This example demonstrates a very simple CGI page that refers to itself
* using the GET method.
***********************************************************************)
let text = Netencoding.Html.encode_from_latin1;;
(* This function encodes "<", ">", "&", double quotes, and Latin 1 characters
* as character entities. E.g. text "<" = "<", and text "ä" = "ä"
*)
let begin_page cgi title =
(* Output the beginning of the page with the passed [title]. *)
let out = cgi # output # output_string in
out "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0//EN\" \"http://www.w3.org/TR/REC-html40/strict.dtd\">\n";
out "<HTML>\n";
out "<HEAD>\n";
out ("<TITLE>" ^ text title ^ "</TITLE>\n");
out ("<STYLE TYPE=\"text/css\">\n");
out "body { background: white; color: black; }\n";
out "</STYLE>\n";
out "</HEAD>\n";
out "<BODY>\n";
out ("<H1>" ^ text title ^ "</H1>\n")
;;
let end_page cgi =
let out = cgi # output # output_string in
out "</BODY>\n";
out "</HTML>\n"
;;
let generate_query_page (cgi : cgi_activation) =
(* Display the query form. *)
begin_page cgi "Add Two Numbers";
let out = cgi # output # output_string in
out "<P>This CGI page can perform additions. Please enter two integers,\n";
out "and press the button!\n";
out (sprintf "<P>GET: <FORM METHOD=GET ACTION=\"%s\">\n"
(text (cgi#url())));
(* Note that cgi#url() returns the URL of this script (without ? clause).
* We pass this string through the text function to avoid problems with
* some characters.
*)
out "<INPUT TYPE=TEXT NAME=\"x\"> + <INPUT TYPE=TEXT NAME=\"y\"> = ";
out "<INPUT TYPE=SUBMIT NAME=\"button\" VALUE=\"Go!\">\n";
(* The hidden field only indicates that now the result page should
* be consulted.
*)
out "<INPUT TYPE=HIDDEN NAME=\"page\" VALUE=\"result\">\n";
out "</FORM>\n";
out (sprintf "<P>POST: <FORM METHOD=POST ACTION=\"%s\">\n"
(text (cgi#url())));
out "<INPUT TYPE=TEXT NAME=\"x\"> + <INPUT TYPE=TEXT NAME=\"y\"> = ";
out "<INPUT TYPE=SUBMIT NAME=\"button\" VALUE=\"Go!\">\n";
out "<INPUT TYPE=HIDDEN NAME=\"page\" VALUE=\"result\">\n";
out "</FORM>\n";
end_page cgi
;;
let generate_result_page (cgi : cgi_activation) =
(* Compute the result, and display it *)
begin_page cgi "Sum";
let out = cgi # output # output_string in
out "<P>The result is:\n";
let x = cgi # argument_value "x" in
let y = cgi # argument_value "y" in
let sum = (int_of_string x) + (int_of_string y) in
out (sprintf "<P>%s + %s = %d\n" x y sum);
out (sprintf "<P><A HREF=\"%s\">Add further numbers</A>\n"
(text (cgi#url
~with_query_string:
(`Args [new simple_argument "page" "query"])
()
)));
(* Here, the URL contains the CGI argument "page", but no other arguments. *)
end_page cgi
;;
let generate_page (cgi : cgi_activation) =
(* Check which page is to be displayed. This is contained in the CGI
* argument "page".
*)
match cgi # argument_value "page" with
"" ->
(* The argument is the empty string, or the argument is missing.
* This is the same like the page "query".
*)
generate_query_page cgi
| "query" ->
generate_query_page cgi
| "result" ->
generate_result_page cgi
| _ ->
assert false
;;
let process (cgi : cgi_activation) =
(* A [cgi_activation] is an object that allows us to program pages
* in a quite abstract way. By creating the [std_activation] object
* the CGI/1.1 protocol is used to communicate with the outer world.
* The CGI arguments are read in, and further properties of the protocol
* are available by method calls.
*
* The parameter [~operating_type] specifies that the generated HTML
* page is buffered, and sent to the browser when it is complete. This
* has the advantage that you can catch errors while the page is generated,
* and can output error messages. Other [~operating_type]s make it
* possible that the HTML page is buffered in a temporary file, and it
* can also be specified that the HTML page is not buffered at all.
*)
(* The [try] block catches errors during the page generation. *)
try
(* Set the header. The header specifies that the page must not be
* cached. This is important for dynamic pages called by the GET
* method, otherwise the browser might display an old version of
* the page.
* Furthermore, we set the content type and the character set.
* Note that the header is not sent immediately to the browser because
* we have enabled HTML buffering.
*)
cgi # set_header
~cache:`No_cache
~content_type:"text/html; charset=\"iso-8859-1\""
();
generate_page cgi;
(* After the page has been fully generated, we can send it to the
* browser.
*)
cgi # output # commit_work();
with
error ->
(* An error has happened. Generate now an error page instead of
* the current page. By rolling back the output buffer, any
* uncomitted material is deleted.
*)
cgi # output # rollback_work();
(* We change the header here only to demonstrate that this is
* possible.
*)
cgi # set_header
~status:`Forbidden (* Indicate the error *)
~cache:`No_cache
~content_type:"text/html; charset=\"iso-8859-1\""
();
begin_page cgi "Software error";
cgi # output # output_string "While processing the request an O'Caml exception has been raised:<BR>";
cgi # output # output_string ("<TT>" ^ text(Printexc.to_string error) ^ "</TT><BR>");
end_page cgi;
(* Now commit the error page: *)
cgi # output # commit_work()
;;
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
;;
(* main: *)
conf_debug();
start process ;;
