webiface.ml 8.33 KB
Newer Older
1
2
3
4
5
6
(* TODO:
   - correct error messages, not failwith "..."
   - HTML design, logo
   - dump
*)

7
open Netcgi
8
exception Timeout
9

10
11
12
13
14
15
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 
16
    ~content_type:"text/html; charset=\"iso-8859-1\""
17
18
19
20
    ~cache:`No_cache 
    ();
  cgi # output # output_string ("<h1>" ^ title ^ "</h1>");
  cgi # output # output_string s;
21
  cgi # output # output_string "\n";
22
  cgi # output # commit_work();
23
24
  cgi # finalize ();
  exit 0
25
26


27
28
(* Configuration *)

29
let session_dirs = [ "/home/beppe/sessions"; "/home/frisch/sessions"; "/users/formel/cduce/sessions"]
30
31
let session_dir = 
  try List.find Sys.file_exists session_dirs
32
33
  with Not_found -> fatal_error "Internal error" 
    "Cannot find sessions directory"
34
35
36
37
38
let timeout = 60 * 5  (* seconds *)
let max_sess = 10

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

39

40
41
42
43
44
45
(* Loading examples *)

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

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

49
50
51
let persistant = ref false
let session_id = ref ""

52
53
54
let (|||) p x = p x; p
let (||=) p () = ()

55
let html_header p =
56
57
58
59
60
61
62
63
  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\"/>
64
  <link type=\"text/css\" href=\"/cduce.css\" rel=\"stylesheet\"/>
65
66
67
68
69
70
71
72
  <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=\"/\">Main page</a></li>
73
     <li><a href=\"/memento.php\">CDuce Memento</a></li>
74
75
76
    </ul>
   </div>
";
77

78
  if !persistant then 
79
80
81
82
83
    p "
  </div>
<div id=\"Content\">
<div class=\"box\">
 <p>You're running the CDuce prototype in session mode: values and
84
types accepted by CDuce when you click 'Submit' will be available
85
86
87
for subsequent requests.</p>
</div>
"
88
  else
89
90
91
92
93
94
95
    p ||| "
<div class=\"box\">
 <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\">" 
  ||= ()
96

97
98

let html_form p content =
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
  p "
<div class=\"box\">
 <h2>Input</h2>
   <form 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 ||| "</p><p><textarea name=\"prog\" cols=\"80\" rows=\"25\">"
    ||| content
    ||| "</textarea></p></form></div>"
    ||= ()
121
122
123


let html_footer p =
124
125
126
127
128
  p "
 </div>
</body>
</html>
"
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168


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;
169
	     "example", `Example;
170
171
	     "new", `New;
	   ]
172

173
174
175
176
177
178
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
179
180
181
182
183
	| '<' ->
	    let rec tag i =
	      p s.[i];
	      if (s.[i] = '>') then aux (i + 1) x else tag (i + 1) in
	    tag i
184
185
186
187
188
189
190
191
192
193
194
195
196
	| 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

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

206
207
208
209
210
211
212
213
    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 ...";
214
215
216
217
218
	  let sid = gen_session_id () in
	  (* touch the session file ... *)
	  let chan = open_out_bin (session_file sid) in
	  close_out chan;
	  sid
219
220
221
222
223
224
225
226
227
      | `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
228
229
230

    let load_state () =
      if !persistant then
231
232
	try
	  let chan = open_in_bin (session_file !session_id) in
233
234
235
	  if in_channel_length chan > 0 then
	    (let s = Marshal.from_channel chan in
	     State.set s);
236
	  close_in chan;
237
238
	with Sys_error _ ->
	  failwith "This session has expired ..."
239
    in
240

241
242
243
244
245
246
247
248
249
250
251
    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
252
      Location.push_source (`String src);
253
      Location.set_protected true;
254
      
255
      Location.warning_ppf := ppf;
256
      let ok = Cduce.run ppf ppf input in
257
258
      if ok then Format.fprintf ppf "@\nOk.@\n";
      let res = Format.flush_str_formatter () in
259
260
      p "<div class=\"box\"><h2>Results</h2><pre>"; 
      cut (cgi # output # output_char) 80 res;  p "</pre></div>";
261
262
      if ok then (dialog ""; store_state ()) else dialog src;
    in
263

264
265
266
267
268
269
    let dump src =
      let ppf = Format.str_formatter in

      Cduce.dump_env ppf;

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

275
    Location.set_viewport `Html;
276
277
    load_state ();
    store_state ();  (* Just touch the file ... *)
278
279
280
281
282
283
    html_header p;
    let prog = cgi # argument_value "prog" in
    (match cmd with
       | `Exec -> exec prog
       | `Open -> dialog prog
       | `New -> dialog ""
284
       | `Dump -> dump prog
285
       | `Close -> dialog ""
286
       | `Example -> dialog (example (cgi # argument_value "example"))
287
    );
288
289
290
291
292
293
294
295
296
297
298
299
300
    p "
<div class=\"box\"><h2>About the prototype</h2>
<p>
CDuce is under active development; some features may not work properly.
We are planning a beta release for the beginning of 2003. 
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></div>";
301
    html_footer p;
302
303
304
    cgi # output # commit_work()
  with
      exn ->
305
306
307
	let msg = 
	  match exn with
	    | Unix.Unix_error (e,f,arg) ->
308
309
310
		"System error: " ^ (Unix.error_message e) ^ 
		"; function " ^ f ^ 
		"; argument " ^ arg
311
312
	    | Timeout ->
		"Timeout reached ! This prototype limits computation time ..."
313
314
315
316
	    | exn ->
	      Printexc.to_string exn
	in
	fatal_error "Internal software error!" msg
317
318

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