(* TODO:
- correct error messages, not failwith "..."
- HTML design, logo
- dump
*)
open Netcgi
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 ("" ^ title ^ "
");
cgi # output # output_string s;
cgi # output # output_string "\n";
cgi # output # commit_work();
cgi # finalize ();
exit 0
(* Configuration *)
let session_dirs = [ "/home/frisch/sessions"; "/users/formel/cduce/sessions" ]
let session_dir =
try List.find Sys.file_exists session_dirs
with Not_found -> fatal_error "Internal error"
"Cannot find sessions directory"
let timeout = 60 * 5 (* seconds *)
let max_sess = 10
(*****************)
let persistant = ref false
let session_id = ref ""
let html_header p =
p "
CDuce online prototype
CDuce online prototype
";
if !persistant then
(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 " (session #"; p !session_id; p ")
")
let html_form p content =
p ""
let html_footer p =
p "\n"
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 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 _ ->
failwith "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 ppf = Format.str_formatter
and input = Stream.of_string src in
Location.set_source (`String src);
Load_xml.set_auth false;
let ok = Cduce.run ppf ppf input in
if ok then Format.fprintf ppf "@\nOk.@\n";
let res = Format.flush_str_formatter () in
cgi # output # output_string ("" ^ res ^ "
");
if ok then (dialog ""; store_state ()) else dialog src;
in
let dump src =
let ppf = Format.str_formatter in
Format.fprintf ppf "Environment:@.";
Cduce.dump_env ppf;
let res = Format.flush_str_formatter () in
cgi # output # output_string ("" ^ res ^ "
");
dialog src
in
Location.set_viewport `Html;
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 ""
);
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
| exn ->
Printexc.to_string exn
in
fatal_error "Internal software error!" msg
let () =
main cgi;
cgi # finalize ()