request.ml

   1
   2 open Printf
   3 open Netcgi
   4 open ExtLib
   5
   6 open Prelude
   7
   8 let encode = Netencoding.Html.encode ~in_enc:`Enc_utf8 ~out_enc:`Enc_utf8 ()
   9
  10 let main (cgi:cgi) =
  11   let env = cgi#environment in
  12 (*   let cgi_arg name = try Some (cgi#argument name)#value with _ -> None in *)
  13   let outs = cgi#out_channel#output_string in
  14   let out fmt = ksprintf outs fmt in
  15   let serve_text () = cgi#set_header ~cache:`No_cache ~content_type:"text/plain" () in
  16   let serve_html ?(status=`Ok) html =
  17     cgi#set_header ~cache:`No_cache ~content_type:"text/html" ();
  18     XHTML.M.output ~encode ~encoding:"utf-8" outs html
  19   in
  20   let prefix s url = if String.starts_with url "/" then sprintf "/%s%s" (String.strip ~chars:"/" s) url else url in
  21   let render page =
  22     let is_cgi = try env#cgi_property "REQUEST_URI" >> ignore; false with _ -> true in
  23     let html = page#render (cgi#arguments:><name:string;value:string> list) in
  24     if is_cgi then XHTML.M.rewrite_hrefs (prefix env#cgi_script_name) html else html
  25   in
  26
  27   let dump_cgi () =
  28     out "\ncgi_properties\n";
  29     List.iter (fun (k,v) -> out "%s = %s\n" k v) env#cgi_properties;
  30     out "\ninput_header_fields\n";
  31     List.iter (fun (k,v) -> out "%s = %s\n" k v) env#input_header_fields;
  32     out "\ncgi_arguments\n";
  33     List.iter (fun x -> out "%s = %s\n" x#name x#value) cgi#arguments
  34   in
  35
  36   let path = try env#cgi_property "REQUEST_URI" with _ -> env#cgi_path_info in
  37   let path = match path with "" -> "/" | s -> s in
  38
  39   match catch (Page.resolve (Page.main:>Page.base)) path with
  40   | Some page -> page >> render >> serve_html
  41   | None ->
  42     match path with
  43     | "/dump" -> serve_text (); dump_cgi ()
  44     | _ -> new Page.not_found path >> render >> serve_html ~status:`Not_found
  45
  46 let main (cgi:cgi) =
  47   try
  48     main cgi;
  49     cgi#out_channel#commit_work ();
  50   with
  51     _ -> cgi#out_channel#rollback_work ()
  52