Ocaml/FAQ/CGI Programming

Материал из Wiki.crossplatform.ru

Перейти к: навигация, поиск

Содержание

19. CGI Programming

Introduction 

(* 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. *)

Writing a CGI Script 

#!/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
(* ... *)

Redirecting Error Messages 

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

Fixing a 500 Server Error 

#!/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

Writing a Safe CGI Program 

(* There is no feature in OCaml resembling Perl's "taint mode". *)

Making CGI Scripts Efficient 

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

Executing Commands Without Shell Escapes 

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

Formatting Lists and Tables with HTML Shortcuts 

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))

Redirecting to a Different Location 

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 creme" 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
*)

Debugging the Raw HTTP Exchange 

#!/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

Managing Cookies 

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

Creating Sticky Widgets 

#!/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

Writing a Multiscreen CGI Script 

#!/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

Saving a Form to a File or Mail Pipe 

#!/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

Program: chemiserie 

#!/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
Источник — «http://wiki.crossplatform.ru/index.php?title=Ocaml/FAQ/CGI_Programming»