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 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
  21   let dump_cgi () =
  22     out "\ncgi_properties\n";
  23     List.iter (fun (k,v) -> out "%s = %s\n" k v) env#cgi_properties;
  24     out "\ninput_header_fields\n";
  25     List.iter (fun (k,v) -> out "%s = %s\n" k v) env#input_header_fields;
  26     out "\ncgi_arguments\n";
  27     List.iter (fun x -> out "%s = %s\n" x#name x#value) cgi#arguments
  28   in
  29
  30   let path = try env#cgi_property "REQUEST_URI" with _ -> env#cgi_path_info in
  31   let path = match path with "" -> "/" | s -> s in
  32
  33   let prefix s url = if String.starts_with url "/" then sprintf "/%s%s" (String.strip ~chars:"/" s) url else url in
  34
  35   let main = new Page.main in
  36
  37   match catch (Page.resolve (main:>Page.base)) path with
  38   | Some page ->
  39     let is_cgi = try env#cgi_property "REQUEST_URI" >> ignore; false with _ -> true in
  40     let html = page#render (cgi#arguments:><name:string;value:string> list) in
  41     let html = if is_cgi then XHTML.M.rewrite_hrefs (prefix env#cgi_script_name) html else html in
  42     serve_html html
  43   | None ->
  44     match path with
  45     | "/dump" -> serve_text (); dump_cgi ()
  46     | _ ->
  47       cgi#set_header ~cache:`No_cache ~content_type:"text/plain" ~status:`Not_found ();
  48       out "Not found"
  49
  50 let main (cgi:cgi) =
  51   try
  52     main cgi;
  53     cgi#out_channel#commit_work ();
  54   with
  55     _ -> cgi#out_channel#rollback_work ()
  56