(* 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 ;;