(* If you've never seen a URL before, here are a few examples. *) http://caml.inria.fr/ http://www.ocaml-tutorial.org/ http://en.wikipedia.org/wiki/Ocaml http://pleac.sourceforge.net/pleac_ocaml/index.html (* The URL for a form submission using the GET method will contain a query string (the sequence of characters after the '?') with named parameters of the form: key1=value1&key2=value2&... *) http://caml.inria.fr/cgi-bin/search.en.cgi?corpus=hump&words=cgi (* The URL for a form submission using POST will not usually contain a query string, so it will appear cleaner. *) http://caml.inria.fr/cgi-bin/hump.cgi (* GET requests are assumed to be "idempotent", meaning they can be requested many times without any different effect than if they were only requested once. This has the practical difference of making GET requests easy to cache, and POST requests nearly impossible (since there is no guarantee that a POST is non-destructive). It is considered best practice to use POST, not GET, for side-effecting operations such as deleting or modifying a record. *) |
#!/usr/bin/env ocaml (* hiweb - load CGI module to decode information given by web server *) #use "topfind";; (* Findlib *) #require "netcgi2";; (* Ocamlnet *) (* Create an HTML escaping function for the UTF-8 encoding. *) let escape_html = Netencoding.Html.encode ~in_enc:`Enc_utf8 () (* Construct the beginning of an (X)HTML document. *) let start_html title = Printf.sprintf "\ <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\"> <html xmlns=\"http://www.w3.org/1999/xhtml\"> <head> <title>%s</title> <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" /> </head> <body> " (escape_html title) (* Construct the end of an (X)HTML document. *) let end_html = " </body> </html> " (* Construct a few common elements. *) let p contents = Printf.sprintf "<p>%s</p>" (String.concat "" contents) let tt contents = Printf.sprintf "<tt>%s</tt>" (String.concat "" contents) (* Process a page request. *) let process (cgi : Netcgi.cgi) = (* Get a parameter from a form. *) let value = cgi#argument_value "PARAM_NAME" in (* Output a document. *) let out = cgi#out_channel#output_string in out (start_html "Howdy there!"); out (p ["You typed: "; tt [escape_html value]]); out end_html; (* Flush the output buffer. *) cgi#out_channel#commit_work () (* Initialize and run the Netcgi process. *) let () = let config = Netcgi.default_config in let buffered _ ch = new Netchannels.buffered_trans_channel ch in Netcgi_cgi.run ~config ~output_type:(`Transactional buffered) process (*-----------------------------*) (* Set the output mime-type and expiration time. *) cgi#set_header ~content_type:"text/html" ~cache:(`Max_age 3600) () (*-----------------------------*) (* Read multiple form fields, one containing multiple values. *) let who = cgi#argument_value "Name" in let phone = cgi#argument_value "Number" in let picks = List.map (fun arg -> arg#value) (cgi#multiple_argument "Choices") in (* ... *) |
(* The default Netcgi configuration sends all exceptions to the browser in nicely formatted error pages. This is helpful during development but may be inappropriate for production. The exception pages can be disabled by setting the "default_exn_handler" configuration field: *) let config = {Netcgi.default_config with Netcgi.default_exn_handler=false} (* Most web servers send standard error to the error log, which is typically /var/log/apache2/error.log for a default Apache 2 configuration. You can define a "warn" function to include the script name in warning messages: *) let warn = Printf.eprintf "%s: %s\n" (Filename.basename Sys.argv.(0)) let () = warn "This goes to the error log." (* You can also use Printf.kprintf to define a fancier warning function that supports Printf formatting. *) let warn = Printf.kprintf (Printf.eprintf "%s: %s\n" (Filename.basename Sys.argv.(0))) let () = warn "So does %s." "this" |
#!/usr/bin/env ocaml (* webwhoami - show web users id *) #use "topfind";; #require "netcgi2";; #require "unix";; let process (cgi : Netcgi.cgi) = cgi#set_header ~content_type:"text/plain" (); cgi#out_channel#output_string (Printf.sprintf "Running as %s\n" (Unix.getpwuid (Unix.geteuid ())).Unix.pw_name); cgi#out_channel#commit_work () let () = let config = Netcgi.default_config in let buffered _ ch = new Netchannels.buffered_trans_channel ch in Netcgi_cgi.run ~config ~output_type:(`Transactional buffered) process (*-----------------------------*) (* By using Netcgi_test.run instead of Netcgi_run, you can enable a command-line testing mechanism. *) let () = let config = Netcgi.default_config in let buffered _ ch = new Netchannels.buffered_trans_channel ch in let output_type = `Transactional buffered in if Unix.isatty Unix.stdin then Netcgi_test.run ~config ~output_type process else Netcgi_cgi.run ~config ~output_type process (* Now, you can run the CGI script from the command line to test for compilation and runtime errors. *) $ ./webwhoami -help ocaml [options] name1=value1 ... nameN=valueN -get Set the method to GET (the default) -head Set the method to HEAD -post Set the method to POST -put file Set the method to PUT with the file as argument -delete Set the method to DELETE -mimetype type Set the MIME type for the next file argument(s) (default: text/plain) -filename path Set the filename property for the next file argument(s) -filearg name=file Specify a file argument whose contents are in the file -user name Set REMOTE_USER to this name -prop name=value Set the environment property -header name=value Set the request header field -o file Set the output file (default: stdout) -help Display this list of options --help Display this list of options |
(* There is no feature in OCaml resembling Perl's "taint mode". *) |
(* Ocamlnet provides an Apache 2 module called netcgi_apache that allows Netcgi scripts to run inside the Apache process. To load the module, put something like the following in your Apache configuration file: *) LoadModule netcgi_module /usr/lib/apache2/modules/mod_netcgi_apache.so NetcgiLoad pcre/pcre.cma NetcgiLoad netsys/netsys.cma NetcgiLoad netstring/netstring.cma NetcgiLoad str.cma NetcgiLoad netcgi2/netcgi.cma NetcgiLoad netcgi_apache/netcgi_apache.cma (* Extra libraries can be added with additional "NetcgiLoad" directives. The following will enable netcgi_apache for *.cma files: *) NetcgiHandler Netcgi_apache.bytecode AddHandler ocaml-bytecode .cma (* Or, if you prefer, you can enable netcgi_apache for a directory: *) <Location /caml-bin> SetHandler ocaml-bytecode NetcgiHandler Netcgi_apache.bytecode Options ExecCGI Allow from all </Location> (* Each script contains code similar to other Netcgi examples but uses Netcgi_apache.run to run the process. *) let process (cgi : Netcgi_apache.cgi) = cgi#set_header ~content_type:"text/html" (); (* ... *) cgi#out_channel#commit_work () let () = let config = Netcgi.default_config in let buffered _ ch = new Netchannels.buffered_trans_channel ch in let output_type = `Transactional buffered in Netcgi_apache.run ~config ~output_type process (* Scripts need to be compiled into bytecode libraries before Apache can execute them. If you have findlib installed, you can compile them as follows: *) ocamlfind ocamlc -package netcgi_apache -c myscript.ml ocamlfind ocamlc -a -o myscript.cma myscript.cmo (* Here is a Makefile to automate the build process. *) RESULTS = myscript.cma another.cma PACKS = netcgi_apache,anotherlib %.cmo : %.ml ocamlfind ocamlc -package $(PACKS) -c $< %.cma : %.cmo ocamlfind ocamlc -a -o $@ $< all: $(RESULTS) clean: rm -f *.cma *.cmi *.cmo $(RESULTS) |
(* UNSAFE *) let status = Unix.system (command ^ " " ^ input ^ " " ^ String.concat " " files) (* safer *) let pid = Unix.create_process command (Array.of_list ([command; input] @ files)) Unix.stdin Unix.stdout Unix.stderr let _, status = Unix.waitpid [] pid |
open Printf (* Define some HTML helper functions. *) let ol contents = sprintf "<ol>%s</ol>" (String.concat "" contents) let ul contents = sprintf "<ul>%s</ul>" (String.concat "" contents) let li ?(typ="") content = if typ = "" then sprintf "<li>%s</li>" content else sprintf "<li type=\"%s\">%s</li>" typ content let tr contents = sprintf "<tr>%s</tr>" (String.concat "" contents) let th content = sprintf "<th>%s</th>" content let td content = sprintf "<td>%s</td>" content (* Main CGI process. *) let process (cgi : Netcgi.cgi) = (* Define a print function for convenience. *) let print s = cgi#out_channel#output_string s; cgi#out_channel#output_string "\n" in (* Print a numbered list. *) print (ol (List.map li ["red"; "blue"; "green"])); (* Print a bulleted list. *) let names = ["Larry"; "Moe"; "Curly"] in print (ul (List.map (li ~typ:"disc") names)); (* The "li" function gets applied to a single item. *) print (li "alpha"); (* If there are multiple items, use List.map. *) print (String.concat " " (List.map li ["alpha"; "omega"])); (* Build a table of states and their cities. *) let ( => ) k v = (k, v) in let state_cities = [ "Wisconsin" => [ "Superior"; "Lake Geneva"; "Madison" ]; "Colorado" => [ "Denver"; "Fort Collins"; "Boulder" ]; "Texas" => [ "Plano"; "Austin"; "Fort Stockton" ]; "California" => [ "Sebastopol"; "Santa Rosa"; "Berkeley" ]; ] in (* Print the table in sorted order. *) print "<TABLE> <CAPTION>Cities I Have Known</CAPTION>"; print (tr (List.map th ["State"; "Cities"])); List.iter (fun (state, cities) -> print (tr (th state :: List.map td (List.sort compare cities)))) (List.sort compare state_cities); print "</TABLE>"; (* Flush the output buffer. *) cgi#out_channel#commit_work () (*-----------------------------*) (* salcheck - check for salaries *) (* Requires ocaml-mysql, available here: http://raevnos.pennmush.org/code/ocaml-mysql/ For netcgi_apache, the following configuration directive is needed: NetcgiLoad mysql/mysql.cma *) open Printf let escape_html = Netencoding.Html.encode ~in_enc:`Enc_utf8 () let start_html title = sprintf "\ <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\"> <html xmlns=\"http://www.w3.org/1999/xhtml\"> <head> <title>%s</title> <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" /> </head> <body> " (escape_html title) let end_html = " </body> </html> " let start_form ?(action="") ?(method'="get") () = sprintf "<form action=\"%s\" method=\"%s\">" (escape_html action) (escape_html method') let end_form = "</form>" let p contents = sprintf "<p>%s</p>" (String.concat "" contents) let h1 contents = sprintf "<h1>%s</h1>" (String.concat "" contents) let textfield ?(name="") ?(value="") () = sprintf "<input type=\"text\" name=\"%s\" value=\"%s\" />" (escape_html name) (escape_html value) let submit ?(name="") ?(value="") () = sprintf "<input type=\"submit\" name=\"%s\" value=\"%s\" />" (escape_html name) (escape_html value) let tr contents = sprintf "<tr>%s</tr>" (String.concat "" contents) let td content = sprintf "<td>%s</td>" content let process (cgi : Netcgi.cgi) = let limit = cgi#argument_value "LIMIT" in cgi#set_header ~content_type:"text/html" (); let print s = cgi#out_channel#output_string s; cgi#out_channel#output_string "\n" in print (start_html "Salary Query"); print (h1 ["Search"]); print (start_form ()); print (p ["Enter minimum salary "; textfield ~name:"LIMIT" ~value:limit ()]); print (submit ~value:"Submit" ()); print end_form; if limit <> "" then begin let db = Mysql.quick_connect ~user:"username" ~password:"password" ~database:"somedb" ~host:"localhost" ~port:3306 () in let sql = sprintf " SELECT name, salary FROM employees WHERE salary > %s " (Mysql.ml2float (float_of_string limit)) in let result = Mysql.exec db sql in print (h1 ["Results"]); print "<table border=\"1\">"; print (String.concat "\n" (Mysql.map result (fun values -> tr [td (escape_html (Mysql.not_null Mysql.str2ml values.(0))); td (sprintf "%.2f" (Mysql.not_null Mysql.float2ml values.(1)))]))); print "</table>"; Mysql.disconnect db; end; print end_html; cgi#out_channel#commit_work () let () = let buffered _ ch = new Netchannels.buffered_trans_channel ch in Netcgi_apache.run ~output_type:(`Transactional buffered) (fun cgi -> process (cgi :> Netcgi.cgi)) |
let process (cgi : Netcgi.cgi) = let url = "http://caml.inria.fr/cgi-bin/hump.cgi" in cgi#set_redirection_header url; (* By default, the above will send a 302 Found. To instead send a 301 Moved Permanently, use the following command. *) cgi#set_header ~status:`Moved_permanently () (*-----------------------------*) (* oreobounce - set a cookie and redirect the browser *) let process (cgi : Netcgi.cgi) = let oreo = Netcgi_common.Cookie.make ~max_age:(60 * 60 * 24 * 30 * 3) (* 3 months *) ~domain:".sourceforge.nett" "filling" "vanilla crème" in let whither = "http://somewhere.sourceforge.net/nonesuch.html" in cgi#set_redirection_header ~set_cookies:[oreo] whither let () = let buffered _ ch = new Netchannels.buffered_trans_channel ch in Netcgi_apache.run ~output_type:(`Transactional buffered) (fun cgi -> process (cgi :> Netcgi.cgi)) (* HTTP/1.1 302 Found Date: Thu, 06 Nov 2008 04:39:53 GMT Server: Apache/2.2.9 (Debian) Netcgi_apache/2.2.9 PHP/5.2.6-5 with Suhosin-Patch Set-Cookie: filling=vanilla%20cr%E8me;Version=1;Domain=.sourceforge.nt;Max-Age=7776000;Expires=Wed, 04 Feb 2009 04:39:55 +0000 Location: http://somewhere.sourceforge.net/nonesuch.html Status: 302 Transfer-Encoding: chunked Content-Type: text/html *) (*-----------------------------*) (* os_snipe - redirect to a Jargon File entry about current OS *) let process (cgi : Netcgi.cgi) = let dir = "http://www.wins.uva.nl/%7Emes/jargon" in let page = match cgi#environment#user_agent with | s when Str.string_match (Str.regexp ".*Mac") s 0 -> "m/Macintrash.html" | s when Str.string_match (Str.regexp ".*Win\\(dows \\)?NT") s 0 -> "e/evilandrude.html" | s when Str.string_match (Str.regexp ".*\\(Win\\|MSIE\\|WebTV\\)") s 0 -> "m/MicroslothWindows.html" | s when Str.string_match (Str.regexp ".*Linux") s 0 -> "l/Linux.html" | s when Str.string_match (Str.regexp ".*HP-UX") s 0 -> "h/HP-SUX.html" | s when Str.string_match (Str.regexp ".*SunOS") s 0 -> "s/ScumOS.html" | _ -> "a/AppendixB.html" in cgi#set_redirection_header (dir ^ "/" ^ page) let () = let buffered _ ch = new Netchannels.buffered_trans_channel ch in Netcgi_apache.run ~output_type:(`Transactional buffered) (fun cgi -> process (cgi :> Netcgi.cgi)) (*-----------------------------*) let process (cgi : Netcgi.cgi) = cgi#environment#set_status `No_content (* HTTP/1.1 204 No Content Date: Thu, 06 Nov 2008 05:25:46 GMT Server: Apache/2.2.9 (Debian) Netcgi_apache/2.2.9 PHP/5.2.6-5 with Suhosin-Patch Status: 204 Content-Type: text/html *) |
#!/usr/bin/ocaml (* dummyhttpd - start an HTTP daemon and print what the client sends *) #load "unix.cma";; let host = "localhost" let port = 8989 let () = Printf.printf "Please contact me at: http://%s:%d/\n%!" host port; let addr = (Unix.gethostbyname host).Unix.h_addr_list.(0) in let server = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in Unix.setsockopt server Unix.SO_REUSEADDR true; Unix.bind server (Unix.ADDR_INET (addr, port)); Unix.listen server 10; while true do begin let client, sockaddr = Unix.accept server in let in_channel = Unix.in_channel_of_descr client in try while true do let line = input_line in_channel in print_endline line done with End_of_file -> print_endline "EOF"; close_in in_channel end done |
(* Read a cookie: *) Netcgi_common.Cookie.value (cgi#environment#cookie "preference name") (* Make a cookie: *) let cookie = Netcgi_common.Cookie.make ~max_age:(60 * 60 * 24 * 365 * 2) (* 2 years *) "preference name" (* name *) "whatever you'd like" (* value*) (* Write a cookie: *) cgi#set_header ~set_cookies:[cookie] () (*-----------------------------*) #!/usr/bin/env ocaml (* ic_cookies - sample CGI script that uses a cookie *) #use "topfind";; #require "netcgi2";; open Printf let escape_html = Netencoding.Html.encode ~in_enc:`Enc_utf8 () let start_html title = sprintf "\ <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\"> <html xmlns=\"http://www.w3.org/1999/xhtml\"> <head> <title>%s</title> <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" /> </head> <body> " (escape_html title) let end_html = " </body> </html> " let h1 contents = sprintf "<h1>%s</h1>" (String.concat "" contents) let hr = "<hr />" let p contents = sprintf "<p>%s</p>" (String.concat "" contents) let start_form ?(action="") ?(method'="get") () = sprintf "<form action=\"%s\" method=\"%s\">" (escape_html action) (escape_html method') let end_form = "</form>" let textfield ?(name="") ?(value="") () = sprintf "<input type=\"text\" name=\"%s\" value=\"%s\" />" (escape_html name) (escape_html value) let process (cgi : Netcgi.cgi) = let cookname = "favorite ice cream" in let favorite = cgi#argument_value "flavor" in let tasty = try Netcgi_common.Cookie.value (cgi#environment#cookie cookname) with Not_found -> "mint" in let print s = cgi#out_channel#output_string s; cgi#out_channel#output_string "\n" in cgi#set_header ~content_type:"text/html" (); if favorite = "" then begin print (start_html "Ice Cookies"); print (h1 ["Hello Ice Cream"]); print hr; print (start_form ~method':"post" ()); print (p ["Please select a flavor: "; textfield ~name:"flavor" ~value:tasty ()]); print end_form; print hr; print end_html; end else begin let cookie = Netcgi_common.Cookie.make ~max_age:(60 * 60 * 24 * 365 * 2) (* 2 years *) cookname favorite in cgi#set_header ~set_cookies:[cookie] (); print (start_html "Ice Cookies, #2"); print (h1 ["Hello Ice Cream"]); print (p ["You chose as your favorite flavor `"; escape_html favorite; "'."]); print end_html; end; cgi#out_channel#commit_work () let () = let config = Netcgi.default_config in let buffered _ ch = new Netchannels.buffered_trans_channel ch in let output_type = `Transactional buffered in if Unix.isatty Unix.stdin then Netcgi_test.run ~config ~output_type process else Netcgi_cgi.run ~config ~output_type process |
#!/usr/bin/env ocaml (* who.cgi - run who(1) on a user and format the results nicely *) #use "topfind";; #require "netcgi2";; #require "str";; open Printf let escape_html = Netencoding.Html.encode ~in_enc:`Enc_utf8 () let start_html title = sprintf "\ <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\"> <html xmlns=\"http://www.w3.org/1999/xhtml\"> <head> <title>%s</title> <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" /> </head> <body> " (escape_html title) let end_html = " </body> </html> " let h1 contents = sprintf "<h1>%s</h1>" (String.concat "" contents) let p contents = sprintf "<p>%s</p>" (String.concat "" contents) let pre contents = sprintf "<pre>%s</pre>" (String.concat "" contents) let start_form ?(action="") ?(method'="get") () = sprintf "<form action=\"%s\" method=\"%s\">" (escape_html action) (escape_html method') let end_form = "</form>" let textfield ?(name="") ?(value="") () = sprintf "<input type=\"text\" name=\"%s\" value=\"%s\" />" (escape_html name) (escape_html value) let submit ?(name="") ?(value="") () = sprintf "<input type=\"submit\" name=\"%s\" value=\"%s\" />" (escape_html name) (escape_html value) let process (cgi : Netcgi.cgi) = let print s = cgi#out_channel#output_string s; cgi#out_channel#output_string "\n" in let name = cgi#argument_value "WHO" in (* print search form *) cgi#set_header ~content_type:"text/html" (); print (start_html "Query Users"); print (h1 ["Search"]); print (start_form ~method':"post" ()); print (p ["Which user? "; textfield ~name:"WHO" ~value:name ()]); print (submit ~value:"Query" ()); print end_form; (* print results of the query if we have someone to look for *) if name <> "" then begin print (h1 ["Results"]); let regexp = Str.regexp name in let proc = Unix.open_process_in "who" in let found = ref false in let html = Buffer.create 0 in begin (* call who and build up text of response *) try while true do let line = input_line proc in (* only lines matching [name] *) if Str.string_match regexp line 0 then begin Buffer.add_string html (escape_html line ^ "\n"); found := true; end done with End_of_file -> close_in proc; (* nice message if we didn't find anyone by that name *) if not !found then Buffer.add_string html (escape_html name ^ " is not logged in"); end; print (pre [Buffer.contents html]); end; print end_html let () = let config = Netcgi.default_config in let buffered _ ch = new Netchannels.buffered_trans_channel ch in let output_type = `Transactional buffered in if Unix.isatty Unix.stdin then Netcgi_test.run ~config ~output_type process else Netcgi_cgi.run ~config ~output_type process |
#!/usr/bin/env ocaml #use "topfind";; #require "netcgi2";; open Printf let ( => ) k v = (k, v) let escape_html = Netencoding.Html.encode ~in_enc:`Enc_utf8 () let start_html title = sprintf "\ <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\"> <html xmlns=\"http://www.w3.org/1999/xhtml\"> <head> <title>%s</title> <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" /> </head> <body> " (escape_html title) let end_html = " </body> </html> " let h1 contents = sprintf "<h1>%s</h1>" (String.concat "" contents) let p contents = sprintf "<p>%s</p>" (String.concat "" contents) let pre contents = sprintf "<pre>%s</pre>" (String.concat "" contents) let start_form ?(action="") ?(method'="get") () = sprintf "<form action=\"%s\" method=\"%s\">" (escape_html action) (escape_html method') let end_form = "</form>" let hidden ?(name="") ?(value="") () = sprintf "<input type=\"hidden\" name=\"%s\" value=\"%s\" />" (escape_html name) (escape_html value) let submit ?(name="") ?(value="") () = sprintf "<input type=\"submit\" name=\"%s\" value=\"%s\" />" (escape_html name) (escape_html value) let popup_menu ?(name="") ?(value="") values = let options = List.map (fun (value', label) -> sprintf "<option %s value=\"%s\">%s</option>" (if value = value' then "selected=\"selected\"" else "") (escape_html value') (escape_html label)) values in sprintf "<select name=\"%s\">\n%s\n</select>" (escape_html name) (String.concat "\n" options) let standard_header () = h1 ["Program Title"] let standard_footer () = "<hr />" let to_page value = submit ~name:".State" ~value () (* when we get a .State that doesn't exist *) let no_such_page (cgi : Netcgi.cgi) print = () let front_page (cgi : Netcgi.cgi) print active = () let sweater (cgi : Netcgi.cgi) print active = () let checkout (cgi : Netcgi.cgi) print active = () let credit_card (cgi : Netcgi.cgi) print active = () let order (cgi : Netcgi.cgi) print active = () let t_shirt (cgi : Netcgi.cgi) print active = let size = cgi#argument_value "size" in let color = cgi#argument_value "color" in if active then begin print (p ["You want to buy a t-shirt?"]); print (p ["Size: "; popup_menu ~name:"size" ~value:size ["XL" => "X-Large"; "L" => "Large"; "M" => "Medium"; "S" => "Small"; "XS" => "X-Small"]]); print (p ["Color: "; popup_menu ~name:"color" ~value:color ["Black" => "Black"; "White" => "White"]]); print (p [to_page "Shoes"; to_page "Checkout"]); end else begin print (hidden ~name:"size" ~value:size ()); print (hidden ~name:"color" ~value:color ()); end let states = [ "Default" => front_page; "Shirt" => t_shirt; "Sweater" => sweater; "Checkout" => checkout; "Card" => credit_card; "Order" => order; "Cancel" => front_page; ] let process (cgi : Netcgi.cgi) = let page = cgi#argument_value ~default:"Default" ".State" in cgi#set_header ~content_type:"text/html" (); let print s = cgi#out_channel#output_string s; cgi#out_channel#output_string "\n" in print (start_html "Program Title"); print (standard_header ()); print (start_form ()); if List.mem_assoc page states then List.iter (fun (state, sub) -> sub cgi print (page = state)) states else no_such_page cgi print; print (standard_footer ()); print end_form; print end_html; cgi#out_channel#commit_work () let () = let config = Netcgi.default_config in let buffered _ ch = new Netchannels.buffered_trans_channel ch in let output_type = `Transactional buffered in if Unix.isatty Unix.stdin then Netcgi_test.run ~config ~output_type process else Netcgi_cgi.run ~config ~output_type process |
#!/usr/bin/env ocaml #use "topfind";; #require "netcgi2";; let escape = Netencoding.Url.encode ~plus:false let unescape = Netencoding.Url.decode ~plus:false let save_arguments (ch : Netchannels.out_obj_channel) args = List.iter (fun arg -> ch#output_string (escape arg#name); ch#output_char '='; ch#output_string (escape arg#value); ch#output_char '\n') args; ch#output_string "=\n" let process (cgi : Netcgi.cgi) = (* first open and exclusively lock the file *) let ch = open_out_gen [Open_append; Open_creat] 0o666 "/tmp/formlog" in Unix.lockf (Unix.descr_of_out_channel ch) Unix.F_LOCK 0; (* locally set some additional arguments *) let arguments = Netcgi.Argument.set [ Netcgi.Argument.simple "_timestamp" (string_of_float (Unix.time ())); Netcgi.Argument.simple "_environs" (String.concat "\n" (Array.to_list (Unix.environment ()))); ] cgi#arguments in (* wrap output in a Netchannel and save *) let ch = new Netchannels.output_channel ch in save_arguments ch arguments; ch#close_out (); (* send in an email *) let body = Buffer.create 256 in let ch = new Netchannels.output_buffer body in save_arguments ch arguments; Netsendmail.sendmail (Netsendmail.compose ~from_addr:("your cgi script", Sys.argv.(0)) ~to_addrs:[("hisname", "hisname@hishost.com")] ~subject:"mailed form submission" (Buffer.contents body)) let () = let config = Netcgi.default_config in let buffered _ ch = new Netchannels.buffered_trans_channel ch in let output_type = `Transactional buffered in if Unix.isatty Unix.stdin then Netcgi_test.run ~config ~output_type process else Netcgi_cgi.run ~config ~output_type process (*-----------------------------*) #!/usr/bin/ocaml #use "topfind";; #require "str";; #require "unix";; #require "netstring";; let escape = Netencoding.Url.encode ~plus:false let unescape = Netencoding.Url.decode ~plus:false let parse_env data = let result = Hashtbl.create 16 in List.iter (fun line -> try let index = String.index line '=' in Hashtbl.add result (String.sub line 0 index) (String.sub line (index + 1) (String.length line - index - 1)) with Not_found -> ()) (Str.split (Str.regexp "\n") data); result let ends_with suffix s = try Str.last_chars s (String.length suffix) = suffix with Invalid_argument _ -> false let () = let forms = open_in "/tmp/formlog" in let args = Hashtbl.create 8 in let count = ref 0 in Unix.lockf (Unix.descr_of_in_channel forms) Unix.F_RLOCK 0; try while true do let line = input_line forms in if line = "=" then begin let his_env = parse_env (Hashtbl.find args "_environs") in let host = try Hashtbl.find his_env "REMOTE_HOST" with Not_found -> "" in if host <> "perl.com" && not (ends_with ".perl.com" host) then (count := (!count + int_of_string (try Hashtbl.find args "items requested" with Not_found -> "0"))); Hashtbl.clear args end else begin let index = String.index line '=' in Hashtbl.add args (unescape (String.sub line 0 index)) (unescape (String.sub line (index + 1) (String.length line - index - 1))) end done with End_of_file -> close_in forms; Printf.printf "Total orders: %d\n" !count |
#!/usr/bin/env ocaml (* chemiserie - simple CGI shopping for shirts and sweaters *) #use "topfind";; #require "netcgi2";; open Printf let ( => ) k v = (k, v) let escape_html = Netencoding.Html.encode ~in_enc:`Enc_utf8 () let start_html title = sprintf "\ <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\"> <html xmlns=\"http://www.w3.org/1999/xhtml\"> <head> <title>%s</title> <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" /> </head> <body> " (escape_html title) let end_html = " </body> </html> " let h1 contents = sprintf "<h1>%s</h1>" (String.concat "" contents) let h2 contents = sprintf "<h2>%s</h2>" (String.concat "" contents) let p contents = sprintf "<p>%s</p>" (String.concat "" contents) let pre contents = sprintf "<pre>%s</pre>" (String.concat "" contents) let start_form ?(action="") ?(method'="get") () = sprintf "<form action=\"%s\" method=\"%s\">" (escape_html action) (escape_html method') let end_form = "</form>" let hidden ?(name="") ?(value="") () = sprintf "<input type=\"hidden\" name=\"%s\" value=\"%s\" />" (escape_html name) (escape_html value) let submit ?(name="") ?(value="") () = sprintf "<input type=\"submit\" name=\"%s\" value=\"%s\" />" (escape_html name) (escape_html value) let textfield ?(name="") ?(value="") () = sprintf "<input type=\"text\" name=\"%s\" value=\"%s\" />" (escape_html name) (escape_html value) let popup_menu ?(name="") ?(value="") values = let options = List.map (fun (value', label) -> sprintf "<option %s value=\"%s\">%s</option>" (if value = value' then "selected=\"selected\"" else "") (escape_html value') (escape_html label)) values in sprintf "<select name=\"%s\">\n%s\n</select>" (escape_html name) (String.concat "\n" options) let defaults label = sprintf "<input type=\"button\" value=\"%s\" onclick=\"%s\" />" (escape_html label) "javascript:location.href='?'" let to_page value = submit ~name:".State" ~value () (******************************** * header, footer, menu functions ********************************) let standard_header print = print (start_html "Shirts"); print (start_form ()) let standard_footer print = print end_form; print end_html let shop_menu print = print (p [defaults "Empty My Shopping Cart"; to_page "Shirt"; to_page "Sweater"; to_page "Checkout"]) (***************************** * subroutines for each screen *****************************) (* The default page. *) let front_page cgi print active = if active then begin print (h1 ["Hi!"]); print "Welcome to our Shirt Shop! Please make your selection "; print "from the menu below."; shop_menu print; end (* Page to order a shirt from. *) let shirt (cgi : Netcgi.cgi) print active = let sizes = ["XL" => "X-Large"; "L" => "Large"; "M" => "Medium"; "S" => "Small"; "XS" => "X-Small"] in let colors = ["Black" => "Black"; "White" => "White"] in let size, color, count = cgi#argument_value "shirt_size", cgi#argument_value "shirt_color", cgi#argument_value "shirt_count" in (* sanity check *) let size = if List.mem_assoc size sizes then size else fst (List.hd sizes) in let color = if List.mem_assoc color colors then color else fst (List.hd colors) in if active then begin print (h1 ["T-Shirt"]); print (p ["What a shirt! This baby is decked out with all the "; "options. It comes with full luxury interior, cotton "; "trim, and a collar to make your eyes water! "; "Unit price: $33.00"]); print (h2 ["Options"]); print (p ["How Many? "; textfield ~name:"shirt_count" ~value:count ()]); print (p ["Size? "; popup_menu ~name:"shirt_size" ~value:size sizes]); print (p ["Color? "; popup_menu ~name:"shirt_color" ~value:color colors]); shop_menu print; end else begin if size <> "" then print (hidden ~name:"shirt_size" ~value:size ()); if color <> "" then print (hidden ~name:"shirt_color" ~value:color ()); if count <> "" then print (hidden ~name:"shirt_count" ~value:count ()); end (* Page to order a sweater from. *) let sweater (cgi : Netcgi.cgi) print active = let sizes = ["XL" => "X-Large"; "L" => "Large"; "M" => "Medium"] in let colors = ["Chartreuse" => "Chartreuse"; "Puce" => "Puce"; "Lavender" => "Lavender"] in let size, color, count = cgi#argument_value "sweater_size", cgi#argument_value "sweater_color", cgi#argument_value "sweater_count" in (* sanity check *) let size = if List.mem_assoc size sizes then size else fst (List.hd sizes) in let color = if List.mem_assoc color colors then color else fst (List.hd colors) in if active then begin print (h1 ["Sweater"]); print (p ["Nothing implies preppy elegance more than this fine "; "sweater. Made by peasant workers from black market "; "silk, it slides onto your lean form and cries out "; "``Take me, for I am a god!''. Unit price: $49.99."]); print (h2 ["Options"]); print (p ["How Many? "; textfield ~name:"sweater_count" ~value:count ()]); print (p ["Size? "; popup_menu ~name:"sweater_size" ~value:size sizes]); print (p ["Color? "; popup_menu ~name:"sweater_color" ~value:color colors]); shop_menu print; end else begin if size <> "" then print (hidden ~name:"sweater_size" ~value:size ()); if color <> "" then print (hidden ~name:"sweater_color" ~value:color ()); if count <> "" then print (hidden ~name:"sweater_count" ~value:count ()); end let calculate_price (cgi : Netcgi.cgi) = let shirts = try int_of_string (cgi#argument_value "shirt_count") with Failure _ -> 0 in let sweaters = try int_of_string (cgi#argument_value "shirt_count") with Failure _ -> 0 in sprintf "$%.2f" (float shirts *. 33.0 +. float sweaters *. 49.99) (* Returns HTML for the current order ("You have ordered ...") *) let order_text (cgi : Netcgi.cgi) = let shirt_count = cgi#argument_value "shirt_count" in let shirt_size = cgi#argument_value "shirt_size" in let shirt_color = cgi#argument_value "shirt_color" in let sweater_count = cgi#argument_value "sweater_count" in let sweater_size = cgi#argument_value "sweater_size" in let sweater_color = cgi#argument_value "sweater_color" in let html = Buffer.create 0 in if not (List.mem shirt_count [""; "0"]) then Buffer.add_string html (p ["You have ordered "; escape_html shirt_count; " shirts of size "; escape_html shirt_size; " and color "; escape_html shirt_color; "."]); if not (List.mem sweater_count [""; "0"]) then Buffer.add_string html (p ["You have ordered "; escape_html sweater_count; " sweaters of size "; escape_html sweater_size; " and color "; escape_html sweater_color; "."]); let html = Buffer.contents html in match html with | "" -> p ["Nothing!"] | html -> html ^ p ["For a total cost of "; calculate_price cgi] (* Page to display current order for confirmation. *) let checkout (cgi : Netcgi.cgi) print active = if active then begin print (h1 ["Order Confirmation"]); print (p ["You ordered the following:"]); print (order_text cgi); print (p ["Is this right? Select 'Card' to pay for the items "; "or 'Shirt' or 'Sweater' to continue shopping."]); print (p [to_page "Card"; to_page "Shirt"; to_page "Sweater"]); end (* Page to gather credit-card information. *) let credit_card (cgi : Netcgi.cgi) print active = let widgets = ["Name"; "Address1"; "Address2"; "City"; "Zip"; "State"; "Phone"; "Card"; "Expiry"] in if active then begin print (pre [p ["Name: "; textfield ~name:"Name" ~value:(cgi#argument_value "Name") ()]; p ["Address: "; textfield ~name:"Address1" ~value:(cgi#argument_value "Address1") ()]; p [" "; textfield ~name:"Address2" ~value:(cgi#argument_value "Address2") ()]; p ["City: "; textfield ~name:"City" ~value:(cgi#argument_value "City") ()]; p ["Zip: "; textfield ~name:"Zip" ~value:(cgi#argument_value "Zip") ()]; p ["State: "; textfield ~name:"State" ~value:(cgi#argument_value "State") ()]; p ["Phone: "; textfield ~name:"Phone" ~value:(cgi#argument_value "Phone") ()]; p ["Credit Card *: "; textfield ~name:"Card" ~value:(cgi#argument_value "Card") ()]; p ["Expiry: "; textfield ~name:"Expiry" ~value:(cgi#argument_value "Expiry") ()]]); print (p ["Click on 'Order' to order the items. "; "Click on 'Cancel' to return shopping."]); print (p [to_page "Order"; to_page "Cancel"]); end else begin List.iter (fun widget -> print (hidden ~name:widget ~value:(cgi#argument_value widget) ())) widgets end (* Page to complete an order. *) let order cgi print active = if active then begin (* you'd check credit card values here *) print (h1 ["Ordered!"]); print (p ["You have ordered the following toppings:"]); print (order_text cgi); print (p [defaults "Begin Again"]); end (* state table mapping pages to functions *) type page = Netcgi.cgi -> (string -> unit) -> bool -> unit let (states : (string * page) list) = [ "Default" => front_page; "Shirt" => shirt; "Sweater" => sweater; "Checkout" => checkout; "Card" => credit_card; "Order" => order; "Cancel" => front_page; ] let no_such_page (cgi : Netcgi.cgi) print current_screen = print ("No screen for " ^ current_screen) let process (cgi : Netcgi.cgi) = let current_screen = cgi#argument_value ~default:"Default" ".State" in let print s = cgi#out_channel#output_string s; cgi#out_channel#output_string "\n" in (* Generate the current page. *) cgi#set_header ~content_type:"text/html" (); standard_header print; if List.mem_assoc current_screen states then List.iter (fun (state, sub) -> sub cgi print (current_screen = state)) states else no_such_page cgi print current_screen; standard_footer print; cgi#out_channel#commit_work () let () = let config = Netcgi.default_config in let buffered _ ch = new Netchannels.buffered_trans_channel ch in let output_type = `Transactional buffered in if Unix.isatty Unix.stdin then Netcgi_test.run ~config ~output_type process else Netcgi_cgi.run ~config ~output_type process |