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 ->
  30         `Redirect (sprintf "%s%s"
  31           (cgi#url ~with_script_name:(if is_cgi then `Env else `None) ~with_path_info:`None ~with_query_string:`None ())
  32           path)
  33   in
  34
  35   let dump_cgi () =
  36     out "cwd : %s\n" (Unix.getcwd ());
  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 = if is_cgi then env#cgi_path_info else env#cgi_script_name in
  46   let path = match path with "" -> "/" | s -> s in
  47
  48   match catch (Page.resolve (Page.main:>Page.base)) path with
  49   | Some page -> page >> render >> serve_html
  50   | None ->
  51     match path with
  52     | "/dump" -> serve_text (); dump_cgi ()
  53     | _ -> new Page.not_found path >> render >> serve_html ~status:`Not_found
  54
  55 let main is_cgi cgi =
  56   try
  57     main is_cgi (cgi:>Netcgi.cgi);
  58     cgi#out_channel#commit_work ();
  59   with
  60     e ->
  61     cgi#out_channel#rollback_work ();
  62     cgi#set_header ~cache:`No_cache ~content_type:"text/plain" ~status:`Internal_server_error ();
  63     cgi#out_channel#output_string (Printexc.to_string e);
  64     cgi#out_channel#commit_work ()
  65