(**************************************************************************)
(*  The CDuce compiler                                                    *)
(*  Alain Frisch <Alain.Frisch@inria.fr> and the CDuce team               *)
(*  Copyright CNRS,INRIA, 2003,2004 (see LICENSE for details)             *)
(**************************************************************************)

(* TODO:
   - HTML design, logo
*)

open Netcgi
exception Timeout

let operating_type = Netcgi.buffered_transactional_optype
let cgi = new Netcgi.std_activation ~operating_type ()

let fatal_error title s =
  cgi # output # rollback_work();
  cgi # set_header 
    ~content_type:"text/html; charset=\"iso-8859-1\""
    ~cache:`No_cache 
    ();
  cgi # output # output_string ("<h1>" ^ title ^ "</h1>");
  cgi # output # output_string s;
  cgi # output # output_string "\n";
  cgi # output # commit_work();
  cgi # finalize ();
  exit 0


(* Configuration *)

let session_dir = <:symbol<session_dir>>

let () =
  if not (Sys.file_exists session_dir) then
    try Unix.mkdir session_dir 0o755
    with Unix.Unix_error(_,_,_)-> fatal_error "Fatal error" "Cannot create session directory"

let timeout = 60 * 5  (* seconds *)
let max_sess = 10

(*****************)


(* Loading examples *)

let example code = 
  try List.assoc code Examples.examples
  with Not_found -> ""

let begin_table = "<div class=\"box\">"
let end_table = "</div>"

let persistant = ref false
let session_id = ref ""

let (|||) p x = p x; p
let (||=) p () = ()

let html_header p =
  p "
<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>
<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
  \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
<html>
<head>
  <meta content=\"text/html; charset=iso-8859-1\" 
        http-equiv=\"Content-Type\"/>
  <link type=\"text/css\" href=\"/cduce.css\" rel=\"stylesheet\"/>
  <title>CDuce online prototype</title>
</head>
<body>
 <div class=\"title\"> <h1>CDuce online prototype</h1> </div>
 <div id=\"Sidelog\">
   <div class=\"box\">
    <ul>
     <li><a href=\"http://www.cduce.org/\">Main page</a></li>
     <li><a href=\"http://www.cduce.org/manual.html\">User's manual</a></li>
     <li><a href=\"http://www.cduce.org/memento.html\">Quick Reference</a></li>
    </ul>
   </div>
";

  if !persistant then 
    p "
  </div>
<div id=\"Content\">
<div class=\"box\">
 <p>You're running the CDuce prototype in session mode: values and
types accepted by CDuce when you click 'Submit' will be available
for subsequent requests.</p>
</div>
"
  else
    p ||| "
<div class=\"box\">
<br/><center><b style=\"font-size:120&#37;; color: #008000\">Sample programs</b></center>
<p>
You can start from one of the predefined examples below or try 
with you own program...</p>
" ||| Examples.present ||| "</div></div><div id=\"Content\">" 
  ||= ()


let html_form p content =
  p "
<div class=\"box\">
 <h2>Input</h2>
   <form name=\"main\" method=\"post\" action=\"/cgi-bin/cduce\">
   <p><input type=\"submit\" name=\"exec\" value=\"Submit to CDuce\"/>" ;
  if !persistant then
    p ||| "
  <input type=\"submit\" name=\"dump\" value=\"Show current environment\"/>
  <input type=\"submit\" name=\"close\" value=\"Close session\"/>
  <input type=\"hidden\" name=\"session\" value=\"" ||| !session_id
    ||| "\"/>" ||= ()
  else
    p "<input type=\"submit\" name=\"open\" value=\"Initiate session\"/>
   <small>
     (The session mode remembers CDuce definitions across requests)
   </small>";
  p
   "<br />
   <input type=\"button\" value=\"Clear\" onClick=\"main.prog.value=''\"/>
   <input type=\"reset\" value=\"Revert changes\"/>
";

  p ||| "</p><p><textarea name=\"prog\" cols=\"80\" rows=\"25\">"
    ||| content
    ||| "</textarea></p></form></div>"
    ||= ()


let html_footer p =
  p "
 </div>
</body>
</html>
"


let () =
  Random.self_init (); 
  State.close ()

let session_file sid =
  Filename.concat session_dir sid

let gen_session_id () =  string_of_int (Random.bits ())

let check_session_id sid =
  try ignore (int_of_string sid)
  with _ -> failwith "Invalid session id"

let close_session sid =
  check_session_id sid;
  try Unix.unlink (session_file sid)
  with Unix.Unix_error (_,_,_) -> ()

let flush_sessions () =
  let time = Unix.time () -. (float timeout) in
  let n = ref 0 in
  let dir = Unix.opendir session_dir in 
  try while true do
    let f = session_file (Unix.readdir dir) in
    let st = Unix.stat f in
    if (st.Unix.st_kind = Unix.S_REG) then
      if  (st.Unix.st_mtime < time) 
      then Unix.unlink f
      else incr n
  done; assert false with End_of_file ->
    Unix.closedir dir;
    !n


let cmds = [ "open", `Open;
	     "close", `Close;
	     "dump", `Dump;
	     "exec", `Exec;
	     "example", `Example;
	     "new", `New;
	   ]

let cut p w s =
  let rec aux i x =
    if i < String.length s then
      match s.[i] with
	| '\n' -> p '\n'; aux (i + 1) 0
	| '\r' -> aux (i + 1) 0
	| '<' ->
	    let rec tag i =
	      p s.[i];
	      if (s.[i] = '>') then aux (i + 1) x else tag (i + 1) in
	    tag i
	| c -> 
	    let x = if x = w then (p '\\'; p '\n'; p ':'; 2) else (x + 1) in
	    p c; 
	    if c = '&' then
	      let rec ent i =
		p s.[i];
		if (s.[i] = ';') then aux (i + 1) x else ent (i + 1) in
	      ent (i + 1)
	    else
	      aux (i + 1) x
  in
  aux 0 0

let main (cgi : Netcgi.std_activation) =
  let p = cgi # output # output_string in
  let clicked s = cgi # argument_value s <> "" in
  try
    let nb_sessions = flush_sessions () in
    cgi # set_header
(*      ~content_type:"text/html; charset=\"iso-8859-1\"" *)
      ();

    let cmd = 
      try snd (List.find (fun (x,y) -> clicked x) cmds)
      with Not_found -> `New in

    let sid = match cmd with
      | `Open ->
	  if (nb_sessions >= max_sess) then
	    failwith "Too many open sessions ...";
	  let sid = gen_session_id () in
	  (* touch the session file ... *)
	  let chan = open_out_bin (session_file sid) in
	  close_out chan;
	  sid
      | `Close -> close_session (cgi # argument_value "session"); ""
      | `New ->  ""
      | _ -> cgi # argument_value "session"
    in
    session_id := sid;
    persistant := !session_id <> "";
    if !persistant then check_session_id !session_id;
      
    let dialog content = html_form p content in

    let load_state () =
      if !persistant then
	try
	  let chan = open_in_bin (session_file !session_id) in
	  if in_channel_length chan > 0 then
	    (let s = Marshal.from_channel chan in
	     State.set s);
	  close_in chan;
	with Sys_error _ ->
	  fatal_error "Fatal error" "This session has expired ..."
    in

    let store_state () =
      if !persistant then
	let s = State.get () in
	let chan = open_out_bin (session_file !session_id) in
	Marshal.to_channel chan s [ Marshal.Closures ];
	close_out chan
    in
    
    let exec src =
      let v = Location.get_viewport () in
      let ppf = Html.ppf v
      and input = Stream.of_string src in
      Location.push_source (`String src);
      Location.set_protected true;
      
      let ok = Cduce.script ppf ppf input in
      if ok then Format.fprintf ppf "@\nOk.@\n";
      let res = Html.get v in
      p "<div class=\"box\"><h2>Results</h2><pre>"; 
      cut (cgi # output # output_char) 80 res;  p "</pre></div>";
      dialog (if !persistant then "" else src);
      if ok then store_state ()
    in

    let dump src =
      let ppf = Format.str_formatter in

      Cduce.dump_env ppf;

      let res = Format.flush_str_formatter () in
      p "<div class=\"box\"><h2>Current session environment</h2>";
      p ("<pre>" ^ res ^ "</pre></div>");
      dialog src
    in

    Location.set_viewport (Html.create true);
    load_state ();
    store_state ();  (* Just touch the file ... *)
    html_header p;
    let prog = cgi # argument_value "prog" in
    (match cmd with
       | `Exec -> exec prog
       | `Open -> dialog prog
       | `New -> dialog ""
       | `Dump -> dump prog
       | `Close -> dialog ""
       | `Example -> dialog (example (cgi # argument_value "example"))
    );
    p ("
<div class=\"box\"><h2>About the prototype</h2>
<p>
CDuce is under active development; some features may not work properly.
The prototype is written in 
<a href='http://www.caml.inria.fr'>Objective Caml</a>, 
and uses several OCaml packages: 
<a href='http://caml.inria.fr/camlp4'>Camlp4</a>, 
<a href='http://ocamlnet.sourceforge.net/'>OCamlnet</a>, 
<a href='http://www.ocaml-programming.de/programming/pxp.html'>PXP</a>, 
<a href='http://www.eleves.ens.fr/home/frisch/soft#wlex'>wlex</a>.</p>
<p><a href='mailto:Alain.Frisch@ens.fr'>Webmaster</a></p>
<p>Prototype version "^ <:symbol<cduce_version>> ^",
 built on "^ <:symbol<build_date>> ^".</p></div>");
    html_footer p;
    cgi # output # commit_work()
  with
      exn ->
	let msg = 
	  match exn with
	    | Unix.Unix_error (e,f,arg) ->
		"System error: " ^ (Unix.error_message e) ^ 
		"; function " ^ f ^ 
		"; argument " ^ arg
	    | Timeout ->
		"Timeout reached ! This prototype limits computation time ..."
	    | exn ->
	      Printexc.to_string exn
	in
	fatal_error "Internal software error!" msg

let () =
  ignore (Unix.alarm 20);
  Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout));
  main cgi;
  cgi # finalize ()

