[r2002-11-10 04:26:26 by cvscast] Empty log message

Original author: cvscast Date: 2002-11-10 04:26:26+00:00

[r2002-11-10 04:26:26 by cvscast] Empty log message
Original author: cvscast Date: 2002-11-10 04:26:26+00:00
fdd444dc · Pietro Abate · 6e5c6504 · fdd444dc
Commit fdd444dc authored Oct 05, 2007 by Pietro Abate
--- a/driver/webiface.ml
+++ b/driver/webiface.ml
 open Netcgi

+let session_dir = "/home/frisch/sessions"
+let timeout = 60  (* seconds *)
+let max_sess = 5
+
+let persistant = ref false
+let session_id = ref ""
+
+let html_header p =
+  p "<html>
+<head>
+  <title>CDuce online prototype</title>
+</head>
+<body>
+  <h1>CDuce online prototype</h1>
+";
+  if !persistant then (p "(session #"; p !session_id; p ")<br>")
+
+let html_form p content =
+  p "<form method=post>";
+  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=\""; p !session_id; p "\">";
+  ) else (
+    p "<input type=submit name=open value=\"Initiate session\">";
+  );
+  p "<br><textarea name=prog cols=80 rows=25>"; p content; p "</textarea>";
+  p "</form>"
+
+
+let html_footer p =
+  p "</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;
+	     "new", `New;
+	   ]

 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 src = cgi # argument_value "prog" in

-    let ppf = Format.str_formatter
-    and input = Stream.of_string src in
-    Location.set_source (`String src);
-    Location.set_viewport `Html;
-    Load_xml.set_auth false;
+    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 ...";
+	  gen_session_id ()
+      | `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 ok = Cduce.run ppf input in
-    if ok then Format.fprintf ppf "@\nOk.@\n";
-    let res = Format.flush_str_formatter () in
+    let exec src =
+      let ppf = Format.str_formatter
+      and input = Stream.of_string src in
+      Location.set_source (`String src);
+      Location.set_viewport `Html;
+      Load_xml.set_auth false;
+      
+      if !persistant then (
+	try
+	  let chan = open_in_bin (session_file !session_id) in
+	  let s = Marshal.from_channel chan in
+	  close_in chan;
+	  State.set s;
+	with Sys_error _ -> ()
+      );

-    cgi # output # output_string ("\
-<html>
-<head>
-  <title>CDuce online prototype</title>
-</head>
-<body>
-  <h1>CDuce online prototype</h1>
-<pre>" ^ res ^ "</pre>
-
-<form method=post>
- <textarea name=prog cols=80 rows=25></textarea>
- <input type=submit>
-</form>
-</body>
-</html>
-");
+      let ok = Cduce.run ppf input in
+      if ok then Format.fprintf ppf "@\nOk.@\n";
+      let res = Format.flush_str_formatter () in
+      cgi # output # output_string ("<pre>" ^ res ^ "</pre>");
+      if ok then dialog "" else dialog src;
+
+      if ok && !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
+
+    html_header p;
+    let prog = cgi # argument_value "prog" in
+    (match cmd with
+       | `Exec -> exec prog
+       | `Open -> dialog prog
+       | `New -> dialog ""
+       | `Dump -> failwith "Dump not yet implemented"
+       | `Close -> dialog ""
+    );
+    html_footer p;
    cgi # output # commit_work()
  with
      exn ->
@@ -43,7 +153,16 @@ let main (cgi : Netcgi.std_activation) =
          ~cache:`No_cache 
 	  ();
 	cgi # output # output_string "<h1>Internal software error!</h1>";
-	cgi # output # output_string (Printexc.to_string exn);
+	(match exn with
+	  | Unix.Unix_error (e,f,arg) ->
+	      cgi # output # output_string (
+		"System error: " ^ (Unix.error_message e) ^ 
+		"; function " ^ f ^ 
+		"; argument " ^ arg
+	      )
+	  | exn ->
+	      cgi # output # output_string (Printexc.to_string exn);
+	);
 	cgi # output # commit_work()

 let () =