request.ml

   1
   2 open Printf
   3 open Netcgi
   4
   5 module Page = struct
   6
   7 open XHTML.M
   8
   9 let t = pcdata
  10
  11 let document heading extra x =
  12   html ~a:[a_xmlns `W3_org_1999_xhtml; a_xml_lang "en"]
  13   (head (title (t heading)) extra)
  14   (body x)
  15
  16 let doc heading x = document heading [] x
  17
  18 let main () =
  19   doc "Main page" [p [t"hello"]]
  20
  21 end
  22
  23 let encode = Netencoding.Html.encode ~in_enc:`Enc_utf8 ~out_enc:`Enc_utf8 ()
  24
  25 let main (cgi:cgi) =
  26   let env = cgi#environment in
  27 (*   let cgi_arg name = try Some (cgi#argument name)#value with _ -> None in *)
  28   let outs = cgi#out_channel#output_string in
  29   let out fmt = ksprintf outs fmt in
  30   let serve_text () = cgi#set_header ~cache:`No_cache ~content_type:"text/plain" () in
  31   let serve_html html =
  32     cgi#set_header ~cache:`No_cache ~content_type:"text/html" ();
  33     XHTML.M.output ~encode ~encoding:"utf-8" outs html
  34   in
  35
  36   let dump_cgi () =
  37     out "\ncgi_properties\n";
  38     List.iter (fun (k,v) -> out "%s = %s\n" k v) env#cgi_properties;
  39     out "\ninput_header_fields\n";
  40     List.iter (fun (k,v) -> out "%s = %s\n" k v) env#input_header_fields;
  41     out "\ncgi_arguments\n";
  42     List.iter (fun x -> out "%s = %s\n" x#name x#value) cgi#arguments
  43   in
  44
  45   let path = match env#cgi_path_info with "" -> env#cgi_property ~default:"" "REQUEST_URI" | s -> s in
  46
  47   match path with
  48   | "/" -> serve_html (Page.main ());
  49   | "/dump" -> serve_text (); dump_cgi ()
  50   | _ ->
  51     cgi#set_header ~cache:`No_cache ~content_type:"text/plain" ~status:`Not_found ();
  52     out "Not found"
  53
  54 let main (cgi:cgi) =
  55   try
  56     main cgi;
  57     cgi#out_channel#commit_work ();
  58   with
  59     _ -> cgi#out_channel#rollback_work ()
  60