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 is_cgi (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     match html with
  18     | `Redirect url -> cgi#set_redirection_header url
  19     | `Content html ->
  20       cgi#set_header ~cache:`No_cache ~content_type:"text/html" ();
  21       XHTML.M.output ~encode ~encoding:"utf-8" outs html
  22   in
  23   let prefix s url = if String.starts_with url "/" then sprintf "/%s%s" (String.strip ~chars:"/" s) url else url in
  24   let render page =
  25     try
  26       let html = page#render (cgi#arguments:><name:string;value:string> list) in
  27       `Content (if is_cgi then XHTML.M.rewrite_hrefs (prefix env#cgi_script_name) html else html)
  28     with
  29       Page.Redirect path -> `Redirect (sprintf "%s%s" (cgi#url ~with_path_info:`None ~with_query_string:`None ()) path)
  30   in
  31
  32   let dump_cgi () =
  33     out "cwd : %s\n" (Unix.getcwd ());
  34     out "\ncgi_properties\n";
  35     List.iter (fun (k,v) -> out "%s = %s\n" k v) env#cgi_properties;
  36     out "\ninput_header_fields\n";
  37     List.iter (fun (k,v) -> out "%s = %s\n" k v) env#input_header_fields;
  38     out "\ncgi_arguments\n";
  39     List.iter (fun x -> out "%s = %s\n" x#name x#value) cgi#arguments
  40   in
  41
  42   let path = if is_cgi then env#cgi_path_info else env#cgi_property "REQUEST_URI" in
  43   let path = match path with "" -> "/" | s -> s in
  44
  45   match catch (Page.resolve (Page.main:>Page.base)) path with
  46   | Some page -> page >> render >> serve_html
  47   | None ->
  48     match path with
  49     | "/dump" -> serve_text (); dump_cgi ()
  50     | _ -> new Page.not_found path >> render >> serve_html ~status:`Not_found
  51
  52 let main is_cgi cgi =
  53   try
  54     main is_cgi (cgi:>Netcgi.cgi);
  55     cgi#out_channel#commit_work ();
  56   with
  57     e ->
  58     cgi#out_channel#rollback_work ();
  59     cgi#set_header ~cache:`No_cache ~content_type:"text/plain" ~status:`Internal_server_error ();
  60     cgi#out_channel#output_string (Printexc.to_string e);
  61     cgi#out_channel#commit_work ()
  62