viewcvs.cgi/driver/webiface.ml

(* TODO:
   - correct error messages, not failwith "..."
   - HTML design, logo
   - dump
*)

open Netcgi
exception Timeout

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 ("<h1>" ^ title ^ "</h1>");
  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

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


(* Loading examples *)

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

let begin_table =
"<table width='100%' border=0 cellspacing=0 cellpadding=2 bgcolor=black>
<tr><td>
<table width='100%' border=0 cellspacing=0 cellpadding=3 bgcolor=white>
<tr><td>"

let end_table = "</td></tr></table></td></tr></table><br>"

let persistant = ref false
let session_id = ref ""

let html_header p =
  p "<html><head><title>CDuce online prototype</title></head>";
  p "<body bgcolor='#BBDDFF'>";
  p begin_table;
  p "<h1>CDuce online prototype</h1>";
  p end_table;

  if !persistant then 
    (p begin_table;
     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 "<small> (session #"; p !session_id; p ")</small>"; *)
     p end_table)
  else
    (p begin_table;
     p "This page is a front-end to a prototype implementation of CDuce.";
     p "You can start from one of the predefined examples below or try ";
     p "with you own program...";
     p "The session mode remembers CDuce definitions across requests.";
     p Examples.present;
     p end_table)


let html_form p content =
  p begin_table;
  p "<h2>Input</h2>";
  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'>";
    p "<input type=submit name=close value='Close session'>";
    p "<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>";
  p end_table


let html_footer p =
  p "</body></html>\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;
             "example", `Example;
             "new", `New;
           ]

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
        | 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

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);
      Location.set_protected true;
      
      Location.warning_ppf := ppf;
      let ok = Cduce.run ppf ppf input in
      if ok then Format.fprintf ppf "@\nOk.@\n";
      let res = Format.flush_str_formatter () in
      p begin_table;
      p "<h2>Results</h2>";
      p "<pre>"; cut (cgi # output # output_char) 80 res;  p "</pre>";
      p end_table;
      if ok then (dialog ""; store_state ()) else dialog src;
    in

    let dump src =
      let ppf = Format.str_formatter in

      Cduce.dump_env ppf;

      let res = Format.flush_str_formatter () in
      p begin_table;
      p "<h2>Current session environment</h2>";
      p ("<pre>" ^ res ^ "</pre>");
      p end_table;
      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 ""
       | `Example -> dialog (example (cgi # argument_value "example"))
    );
    p begin_table;
    p "<h2>About the prototype</h2>";
    p "CDuce is under active development; some features may not work properly.";
    p "We are planning a beta release for the beginning of 2003. ";
    p "The prototype is written in ";
    p "<a href='http://www.caml.inria.fr'>Objective Caml</a>, ";
    p "and uses several OCaml packages: ";
    p "<a href='http://caml.inria.fr/camlp4'>Camlp4</a>, ";
    p "<a href='http://ocamlnet.sourceforge.net/'>OCamlnet</a>, ";
    p "<a href='http://www.ocaml-programming.de/programming/pxp.html'>PXP</a>, ";
    p "<a href='http://www.eleves.ens.fr/home/frisch/soft#wlex'>wlex</a>.";
    p "<p>";
    p "<a href='mailto:Alain.Frisch@ens.fr'>Webmaster</a>";
    p end_table;

    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
            | Timeout ->
                "Timeout reached ! This prototype limits computation time ..."
            | exn ->
              Printexc.to_string exn
        in
        fatal_error "Internal software error!" msg

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

1	abate	98	(* TODO:
2			- correct error messages, not failwith "..."
3			- HTML design, logo
4			- dump
5			*)
6
7	abate	90	open Netcgi
8	abate	129	exception Timeout
9	abate	90
10	abate	101	let operating_type = Netcgi.buffered_transactional_optype
11			let cgi = new Netcgi.std_activation ~operating_type ()
12
13			let fatal_error title s =
14			cgi # output # rollback_work();
15			cgi # set_header
16	abate	102	~content_type:"text/html; charset=\"iso-8859-1\""
17	abate	101	~cache:`No_cache
18			();
19			cgi # output # output_string ("<h1>" ^ title ^ "</h1>");
20			cgi # output # output_string s;
21	abate	104	cgi # output # output_string "\n";
22	abate	101	cgi # output # commit_work();
23	abate	103	cgi # finalize ();
24			exit 0
25	abate	101
26
27	abate	98	(* Configuration *)
28
29	abate	99	let session_dirs = [ "/home/frisch/sessions"; "/users/formel/cduce/sessions" ]
30	abate	100	let session_dir =
31			try List.find Sys.file_exists session_dirs
32	abate	101	with Not_found -> fatal_error "Internal error"
33			"Cannot find sessions directory"
34	abate	98	let timeout = 60 * 5 (* seconds *)
35			let max_sess = 10
36	abate	90
37	abate	98	(*****************)
38
39
40	abate	126	(* Loading examples *)
41
42			let example code =
43			try List.assoc code Examples.examples
44			with Not_found -> ""
45
46	abate	129	let begin_table =
47			"<table width='100%' border=0 cellspacing=0 cellpadding=2 bgcolor=black>
48			<tr><td>
49			<table width='100%' border=0 cellspacing=0 cellpadding=3 bgcolor=white>
50			<tr><td>"
51	abate	126
52	abate	129	let end_table = "</td></tr></table></td></tr></table><br>"
53
54	abate	97	let persistant = ref false
55			let session_id = ref ""
56
57			let html_header p =
58	abate	129	p "<html><head><title>CDuce online prototype</title></head>";
59			p "<body bgcolor='#BBDDFF'>";
60			p begin_table;
61			p "<h1>CDuce online prototype</h1>";
62			p end_table;
63
64	abate	108	if !persistant then
65	abate	129	(p begin_table;
66			p "You're running the CDuce prototype in session mode: values and
67	abate	108	types accepted by CDuce when you click 'Submit' will be available
68			for subsequent requests.";
69	abate	129	(* p "<small> (session #"; p !session_id; p ")</small>"; *)
70			p end_table)
71			else
72			(p begin_table;
73			p "This page is a front-end to a prototype implementation of CDuce.";
74	abate	130	p "You can start from one of the predefined examples below or try ";
75	abate	129	p "with you own program...";
76			p "The session mode remembers CDuce definitions across requests.";
77			p Examples.present;
78			p end_table)
79	abate	97
80	abate	129
81	abate	97	let html_form p content =
82	abate	129	p begin_table;
83			p "<h2>Input</h2>";
84	abate	97	p "<form method=post>";
85	abate	129	p "<input type=submit name=exec value='Submit to CDuce'>";
86	abate	97	if !persistant then(
87	abate	129	p "<input type=submit name=dump value='Show current environment'>";
88			p "<input type=submit name=close value='Close session'>";
89			p "<input type=hidden name=session value='"; p !session_id; p "'>";
90	abate	97	) else (
91			p "<input type=submit name=open value=\"Initiate session\">";
92			);
93			p "<br><textarea name=prog cols=80 rows=25>"; p content; p "</textarea>";
94	abate	129	p "</form>";
95			p end_table
96	abate	97
97
98			let html_footer p =
99	abate	104	p "</body></html>\n"
100	abate	97
101
102			let () =
103			Random.self_init ();
104			State.close ()
105
106			let session_file sid =
107			Filename.concat session_dir sid
108
109			let gen_session_id () = string_of_int (Random.bits ())
110
111			let check_session_id sid =
112			try ignore (int_of_string sid)
113			with _ -> failwith "Invalid session id"
114
115			let close_session sid =
116			check_session_id sid;
117			try Unix.unlink (session_file sid)
118			with Unix.Unix_error (_,_,_) -> ()
119
120			let flush_sessions () =
121			let time = Unix.time () -. (float timeout) in
122			let n = ref 0 in
123			let dir = Unix.opendir session_dir in
124			try while true do
125			let f = session_file (Unix.readdir dir) in
126			let st = Unix.stat f in
127			if (st.Unix.st_kind = Unix.S_REG) then
128			if (st.Unix.st_mtime < time)
129			then Unix.unlink f
130			else incr n
131			done; assert false with End_of_file ->
132			Unix.closedir dir;
133			!n
134
135
136			let cmds = [ "open", `Open;
137			"close", `Close;
138			"dump", `Dump;
139			"exec", `Exec;
140	abate	126	"example", `Example;
141	abate	97	"new", `New;
142			]
143
144	abate	129	let cut p w s =
145			let rec aux i x =
146			if i < String.length s then
147			match s.[i] with
148			\| '\n' -> p '\n'; aux (i + 1) 0
149			\| '\r' -> aux (i + 1) 0
150			\| c ->
151			let x = if x = w then (p '\\'; p '\n'; p ':'; 2) else (x + 1) in
152			p c;
153			if c = '&' then
154			let rec ent i =
155			p s.[i];
156			if (s.[i] = ';') then aux (i + 1) x else ent (i + 1) in
157			ent (i + 1)
158			else
159			aux (i + 1) x
160			in
161			aux 0 0
162
163	abate	90	let main (cgi : Netcgi.std_activation) =
164	abate	97	let p = cgi # output # output_string in
165			let clicked s = cgi # argument_value s <> "" in
166	abate	90	try
167	abate	97	let nb_sessions = flush_sessions () in
168	abate	94	cgi # set_header
169			~content_type:"text/html; charset=\"iso-8859-1\""
170			();
171	abate	90
172	abate	97	let cmd =
173			try snd (List.find (fun (x,y) -> clicked x) cmds)
174			with Not_found -> `New in
175
176			let sid = match cmd with
177			\| `Open ->
178			if (nb_sessions >= max_sess) then
179			failwith "Too many open sessions ...";
180	abate	98	let sid = gen_session_id () in
181			(* touch the session file ... *)
182			let chan = open_out_bin (session_file sid) in
183			close_out chan;
184			sid
185	abate	97	\| `Close -> close_session (cgi # argument_value "session"); ""
186			\| `New -> ""
187			\| _ -> cgi # argument_value "session"
188			in
189			session_id := sid;
190			persistant := !session_id <> "";
191			if !persistant then check_session_id !session_id;
192
193			let dialog content = html_form p content in
194	abate	107
195			let load_state () =
196			if !persistant then
197	abate	97	try
198			let chan = open_in_bin (session_file !session_id) in
199	abate	98	if in_channel_length chan > 0 then
200			(let s = Marshal.from_channel chan in
201			State.set s);
202	abate	97	close_in chan;
203	abate	98	with Sys_error _ ->
204			failwith "This session has expired ..."
205	abate	107	in
206	abate	90
207	abate	107	let store_state () =
208			if !persistant then
209			let s = State.get () in
210			let chan = open_out_bin (session_file !session_id) in
211			Marshal.to_channel chan s [ Marshal.Closures ];
212			close_out chan
213			in
214
215			let exec src =
216			let ppf = Format.str_formatter
217			and input = Stream.of_string src in
218			Location.set_source (`String src);
219	abate	126	Location.set_protected true;
220	abate	107
221	abate	130	Location.warning_ppf := ppf;
222	abate	124	let ok = Cduce.run ppf ppf input in
223	abate	97	if ok then Format.fprintf ppf "@\nOk.@\n";
224			let res = Format.flush_str_formatter () in
225	abate	129	p begin_table;
226			p "<h2>Results</h2>";
227			p "<pre>"; cut (cgi # output # output_char) 80 res; p "</pre>";
228			p end_table;
229	abate	107	if ok then (dialog ""; store_state ()) else dialog src;
230			in
231	abate	90
232	abate	107	let dump src =
233			let ppf = Format.str_formatter in
234
235			Cduce.dump_env ppf;
236
237			let res = Format.flush_str_formatter () in
238	abate	129	p begin_table;
239			p "<h2>Current session environment</h2>";
240			p ("<pre>" ^ res ^ "</pre>");
241			p end_table;
242	abate	107	dialog src
243	abate	97	in
244
245	abate	107	Location.set_viewport `Html;
246	abate	110	load_state ();
247			store_state (); (* Just touch the file ... *)
248	abate	97	html_header p;
249			let prog = cgi # argument_value "prog" in
250			(match cmd with
251			\| `Exec -> exec prog
252			\| `Open -> dialog prog
253			\| `New -> dialog ""
254	abate	107	\| `Dump -> dump prog
255	abate	97	\| `Close -> dialog ""
256	abate	126	\| `Example -> dialog (example (cgi # argument_value "example"))
257	abate	97	);
258	abate	129	p begin_table;
259			p "<h2>About the prototype</h2>";
260			p "CDuce is under active development; some features may not work properly.";
261			p "We are planning a beta release for the beginning of 2003. ";
262			p "The prototype is written in ";
263			p "<a href='http://www.caml.inria.fr'>Objective Caml</a>, ";
264			p "and uses several OCaml packages: ";
265			p "<a href='http://caml.inria.fr/camlp4'>Camlp4</a>, ";
266			p "<a href='http://ocamlnet.sourceforge.net/'>OCamlnet</a>, ";
267			p "<a href='http://www.ocaml-programming.de/programming/pxp.html'>PXP</a>, ";
268			p "<a href='http://www.eleves.ens.fr/home/frisch/soft#wlex'>wlex</a>.";
269	abate	136	p "<p>";
270	abate	129	p "<a href='mailto:Alain.Frisch@ens.fr'>Webmaster</a>";
271			p end_table;
272
273	abate	97	html_footer p;
274	abate	90	cgi # output # commit_work()
275			with
276			exn ->
277	abate	103	let msg =
278			match exn with
279			\| Unix.Unix_error (e,f,arg) ->
280	abate	97	"System error: " ^ (Unix.error_message e) ^
281			"; function " ^ f ^
282			"; argument " ^ arg
283	abate	129	\| Timeout ->
284			"Timeout reached ! This prototype limits computation time ..."
285	abate	103	\| exn ->
286			Printexc.to_string exn
287			in
288			fatal_error "Internal software error!" msg
289	abate	90
290			let () =
291	abate	156	ignore (Unix.alarm 20);
292	abate	129	Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout));
293	abate	90	main cgi;
294			cgi # finalize ()
295