Commit ad9222a2 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: cvscast
Date: 2002-11-10 04:26:26+00:00
parent ea7f3c5f
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 () =
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment