| 1 |
(* TODO:
|
| 2 |
- correct error messages, not failwith "..."
|
| 3 |
- HTML design, logo
|
| 4 |
- dump
|
| 5 |
*)
|
| 6 |
|
| 7 |
open Netcgi
|
| 8 |
|
| 9 |
let operating_type = Netcgi.buffered_transactional_optype
|
| 10 |
let cgi = new Netcgi.std_activation ~operating_type ()
|
| 11 |
|
| 12 |
let fatal_error title s =
|
| 13 |
cgi # output # rollback_work();
|
| 14 |
cgi # set_header
|
| 15 |
~content_type:"text/html; charset=\"iso-8859-1\""
|
| 16 |
~cache:`No_cache
|
| 17 |
();
|
| 18 |
cgi # output # output_string ("<h1>" ^ title ^ "</h1>");
|
| 19 |
cgi # output # output_string s;
|
| 20 |
cgi # output # output_string "\n";
|
| 21 |
cgi # output # commit_work();
|
| 22 |
cgi # finalize ();
|
| 23 |
exit 0
|
| 24 |
|
| 25 |
|
| 26 |
(* Configuration *)
|
| 27 |
|
| 28 |
let session_dirs = [ "/home/frisch/sessions"; "/users/formel/cduce/sessions" ]
|
| 29 |
let session_dir =
|
| 30 |
try List.find Sys.file_exists session_dirs
|
| 31 |
with Not_found -> fatal_error "Internal error"
|
| 32 |
"Cannot find sessions directory"
|
| 33 |
let timeout = 60 * 5 (* seconds *)
|
| 34 |
let max_sess = 10
|
| 35 |
|
| 36 |
(*****************)
|
| 37 |
|
| 38 |
|
| 39 |
let persistant = ref false
|
| 40 |
let session_id = ref ""
|
| 41 |
|
| 42 |
let html_header p =
|
| 43 |
p "<html>
|
| 44 |
<head>
|
| 45 |
<title>CDuce online prototype</title>
|
| 46 |
</head>
|
| 47 |
<body>
|
| 48 |
<h1>CDuce online prototype</h1>
|
| 49 |
";
|
| 50 |
if !persistant then
|
| 51 |
(p "You're running the CDuce prototype in session mode: values and
|
| 52 |
types accepted by CDuce when you click 'Submit' will be available
|
| 53 |
for subsequent requests.";
|
| 54 |
p "<small> (session #"; p !session_id; p ")</small><br>")
|
| 55 |
|
| 56 |
let html_form p content =
|
| 57 |
p "<form method=post>";
|
| 58 |
p "<input type=submit name=exec value=\"Submit to CDuce\">";
|
| 59 |
if !persistant then(
|
| 60 |
p "<input type=submit name=dump value=\"Show current environment\">\
|
| 61 |
<input type=submit name=close value=\"Close session\">\
|
| 62 |
<input type=hidden name=session value=\""; p !session_id; p "\">";
|
| 63 |
) else (
|
| 64 |
p "<input type=submit name=open value=\"Initiate session\">";
|
| 65 |
);
|
| 66 |
p "<br><textarea name=prog cols=80 rows=25>"; p content; p "</textarea>";
|
| 67 |
p "</form>"
|
| 68 |
|
| 69 |
|
| 70 |
let html_footer p =
|
| 71 |
p "</body></html>\n"
|
| 72 |
|
| 73 |
|
| 74 |
let () =
|
| 75 |
Random.self_init ();
|
| 76 |
State.close ()
|
| 77 |
|
| 78 |
let session_file sid =
|
| 79 |
Filename.concat session_dir sid
|
| 80 |
|
| 81 |
let gen_session_id () = string_of_int (Random.bits ())
|
| 82 |
|
| 83 |
let check_session_id sid =
|
| 84 |
try ignore (int_of_string sid)
|
| 85 |
with _ -> failwith "Invalid session id"
|
| 86 |
|
| 87 |
let close_session sid =
|
| 88 |
check_session_id sid;
|
| 89 |
try Unix.unlink (session_file sid)
|
| 90 |
with Unix.Unix_error (_,_,_) -> ()
|
| 91 |
|
| 92 |
let flush_sessions () =
|
| 93 |
let time = Unix.time () -. (float timeout) in
|
| 94 |
let n = ref 0 in
|
| 95 |
let dir = Unix.opendir session_dir in
|
| 96 |
try while true do
|
| 97 |
let f = session_file (Unix.readdir dir) in
|
| 98 |
let st = Unix.stat f in
|
| 99 |
if (st.Unix.st_kind = Unix.S_REG) then
|
| 100 |
if (st.Unix.st_mtime < time)
|
| 101 |
then Unix.unlink f
|
| 102 |
else incr n
|
| 103 |
done; assert false with End_of_file ->
|
| 104 |
Unix.closedir dir;
|
| 105 |
!n
|
| 106 |
|
| 107 |
|
| 108 |
let cmds = [ "open", `Open;
|
| 109 |
"close", `Close;
|
| 110 |
"dump", `Dump;
|
| 111 |
"exec", `Exec;
|
| 112 |
"new", `New;
|
| 113 |
]
|
| 114 |
|
| 115 |
let main (cgi : Netcgi.std_activation) =
|
| 116 |
let p = cgi # output # output_string in
|
| 117 |
let clicked s = cgi # argument_value s <> "" in
|
| 118 |
try
|
| 119 |
let nb_sessions = flush_sessions () in
|
| 120 |
cgi # set_header
|
| 121 |
~content_type:"text/html; charset=\"iso-8859-1\""
|
| 122 |
();
|
| 123 |
|
| 124 |
let cmd =
|
| 125 |
try snd (List.find (fun (x,y) -> clicked x) cmds)
|
| 126 |
with Not_found -> `New in
|
| 127 |
|
| 128 |
let sid = match cmd with
|
| 129 |
| `Open ->
|
| 130 |
if (nb_sessions >= max_sess) then
|
| 131 |
failwith "Too many open sessions ...";
|
| 132 |
let sid = gen_session_id () in
|
| 133 |
(* touch the session file ... *)
|
| 134 |
let chan = open_out_bin (session_file sid) in
|
| 135 |
close_out chan;
|
| 136 |
sid
|
| 137 |
| `Close -> close_session (cgi # argument_value "session"); ""
|
| 138 |
| `New -> ""
|
| 139 |
| _ -> cgi # argument_value "session"
|
| 140 |
in
|
| 141 |
session_id := sid;
|
| 142 |
persistant := !session_id <> "";
|
| 143 |
if !persistant then check_session_id !session_id;
|
| 144 |
|
| 145 |
let dialog content = html_form p content in
|
| 146 |
|
| 147 |
let load_state () =
|
| 148 |
if !persistant then
|
| 149 |
try
|
| 150 |
let chan = open_in_bin (session_file !session_id) in
|
| 151 |
if in_channel_length chan > 0 then
|
| 152 |
(let s = Marshal.from_channel chan in
|
| 153 |
State.set s);
|
| 154 |
close_in chan;
|
| 155 |
with Sys_error _ ->
|
| 156 |
failwith "This session has expired ..."
|
| 157 |
in
|
| 158 |
|
| 159 |
let store_state () =
|
| 160 |
if !persistant then
|
| 161 |
let s = State.get () in
|
| 162 |
let chan = open_out_bin (session_file !session_id) in
|
| 163 |
Marshal.to_channel chan s [ Marshal.Closures ];
|
| 164 |
close_out chan
|
| 165 |
in
|
| 166 |
|
| 167 |
let exec src =
|
| 168 |
let ppf = Format.str_formatter
|
| 169 |
and input = Stream.of_string src in
|
| 170 |
Location.set_source (`String src);
|
| 171 |
Load_xml.set_auth false;
|
| 172 |
|
| 173 |
let ok = Cduce.run ppf input in
|
| 174 |
if ok then Format.fprintf ppf "@\nOk.@\n";
|
| 175 |
let res = Format.flush_str_formatter () in
|
| 176 |
cgi # output # output_string ("<pre>" ^ res ^ "</pre>");
|
| 177 |
if ok then (dialog ""; store_state ()) else dialog src;
|
| 178 |
in
|
| 179 |
|
| 180 |
let dump src =
|
| 181 |
let ppf = Format.str_formatter in
|
| 182 |
|
| 183 |
Format.fprintf ppf "<b>Environment</b>:@.";
|
| 184 |
Cduce.dump_env ppf;
|
| 185 |
|
| 186 |
let res = Format.flush_str_formatter () in
|
| 187 |
cgi # output # output_string ("<pre>" ^ res ^ "</pre>");
|
| 188 |
dialog src
|
| 189 |
in
|
| 190 |
|
| 191 |
Location.set_viewport `Html;
|
| 192 |
load_state ();
|
| 193 |
store_state (); (* Just touch the file ... *)
|
| 194 |
html_header p;
|
| 195 |
let prog = cgi # argument_value "prog" in
|
| 196 |
(match cmd with
|
| 197 |
| `Exec -> exec prog
|
| 198 |
| `Open -> dialog prog
|
| 199 |
| `New -> dialog ""
|
| 200 |
| `Dump -> dump prog
|
| 201 |
| `Close -> dialog ""
|
| 202 |
);
|
| 203 |
html_footer p;
|
| 204 |
cgi # output # commit_work()
|
| 205 |
with
|
| 206 |
exn ->
|
| 207 |
let msg =
|
| 208 |
match exn with
|
| 209 |
| Unix.Unix_error (e,f,arg) ->
|
| 210 |
"System error: " ^ (Unix.error_message e) ^
|
| 211 |
"; function " ^ f ^
|
| 212 |
"; argument " ^ arg
|
| 213 |
| exn ->
|
| 214 |
Printexc.to_string exn
|
| 215 |
in
|
| 216 |
fatal_error "Internal software error!" msg
|
| 217 |
|
| 218 |
let () =
|
| 219 |
main cgi;
|
| 220 |
cgi # finalize ()
|
| 221 |
|
Parent Directory
| 
Revision Log