viewcvs.cgi/driver/webiface.ml

(* TODO:
   - HTML design, logo
*)

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


(* Loading examples *)

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

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

let (|||) p x = p x; p
let (||=) p () = ()

let html_header p =
  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\"/>
  <link type=\"text/css\" href=\"/cduce.css\" rel=\"stylesheet\"/>
  <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=\"http://www.cduce.org/\">Main page</a></li>
     <li><a href=\"http://www.cduce.org/manual.html\">User's manual</a></li>
     <li><a href=\"http://www.cduce.org/memento.html\">Quick Reference</a></li>
    </ul>
   </div>
";

    p ||| "
<div class=\"box\">
<br/><center><b style=\"font-size:120&#37;; color: #008000\">Sample programs</b></center>
<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\">" 
  ||= ()


let html_form p content =
  p "
<div class=\"box\">
 <h2>Input</h2>
   <form name=\"main\" method=\"post\" action=\"/cgi-bin/cduce\">
   <p><input type=\"submit\" name=\"exec\" value=\"Submit to CDuce\"/>
   <input type=\"button\" value=\"Clear\" onClick=\"main.prog.value=''\"/>
   <input type=\"reset\" value=\"Revert changes\"/>
";

  p ||| "</p><p><textarea name=\"prog\" cols=\"80\" rows=\"35\">"
    ||| content
    ||| "</textarea></p></form></div>"
    ||= ()


let html_footer p =
  p "</div></body></html>"


let cmds = [ "exec", `Exec;
             "example", `Example;
           ]

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
        | '<' ->
            let rec tag i =
              p s.[i];
              if (s.[i] = '>') then aux (i + 1) x else tag (i + 1) in
            tag i
        | 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
    cgi # set_header ();

    let cmd = 
      try snd (List.find (fun (x,y) -> clicked x) cmds)
      with Not_found -> `New in

    let dialog content = html_form p content in

    let exec src =
      let v = Location.get_viewport () in
      let ppf = Html.ppf v
      and input = Stream.of_string src in
      Location.push_source (`String src);
      Location.set_protected true;
      
      let ok = Cduce.script ppf ppf input in
      if ok then Format.fprintf ppf "@\nOk.@\n";
      let res = Html.get v in
      p "<div class=\"box\"><h2>Results</h2><pre>"; 
      cut (cgi # output # output_char) 80 res;  
      p "</pre></div>";
      dialog src
    in

    Location.set_viewport (Html.create true);
    html_header p;
    let prog = cgi # argument_value "prog" in
    (match cmd with
       | `Exec -> exec prog
       | `Example -> dialog (example (cgi # argument_value "example"))
       | `New -> dialog ""
    );
    p ("
<div class=\"box\"><h2>About the prototype</h2>
<p>
CDuce is under active development; some features may not work properly.
<p><a href='mailto:Alain.Frisch@ens.fr'>Webmaster</a></p>
<p>Prototype version "^ <:symbol<cduce_version>> ^",
 built on "^ <:symbol<build_date>> ^".</p></div>");
    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));
  Random.self_init ();
  main cgi;
  cgi # finalize ()

1	(* TODO:
2	- HTML design, logo
3	*)
4
5	open Netcgi
6	exception Timeout
7
8	let operating_type = Netcgi.buffered_transactional_optype
9	let cgi = new Netcgi.std_activation ~operating_type ()
10
11	let fatal_error title s =
12	cgi # output # rollback_work();
13	cgi # set_header
14	~content_type:"text/html; charset=\"iso-8859-1\""
15	~cache:`No_cache
16	();
17	cgi # output # output_string ("<h1>" ^ title ^ "</h1>");
18	cgi # output # output_string s;
19	cgi # output # output_string "\n";
20	cgi # output # commit_work();
21	cgi # finalize ();
22	exit 0
23
24
25	(* Loading examples *)
26
27	let example code =
28	try List.assoc code Examples.examples
29	with Not_found -> ""
30
31	let begin_table = "<div class=\"box\">"
32	let end_table = "</div>"
33
34	let (\|\|\|) p x = p x; p
35	let (\|\|=) p () = ()
36
37	let html_header p =
38	p "
39	<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>
40	<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
41	\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
42	<html>
43	<head>
44	<meta content=\"text/html; charset=iso-8859-1\"
45	http-equiv=\"Content-Type\"/>
46	<link type=\"text/css\" href=\"/cduce.css\" rel=\"stylesheet\"/>
47	<title>CDuce online prototype</title>
48	</head>
49	<body>
50	<div class=\"title\"> <h1>CDuce online prototype</h1> </div>
51	<div id=\"Sidelog\">
52	<div class=\"box\">
53	<ul>
54	<li><a href=\"http://www.cduce.org/\">Main page</a></li>
55	<li><a href=\"http://www.cduce.org/manual.html\">User's manual</a></li>
56	<li><a href=\"http://www.cduce.org/memento.html\">Quick Reference</a></li>
57	</ul>
58	</div>
59	";
60
61	p \|\|\| "
62	<div class=\"box\">
63	<br/><center><b style=\"font-size:120%; color: #008000\">Sample programs</b></center>
64	<p>
65	You can start from one of the predefined examples below or try
66	with you own program...</p>
67	" \|\|\| Examples.present \|\|\| "</div></div><div id=\"Content\">"
68	\|\|= ()
69
70
71	let html_form p content =
72	p "
73	<div class=\"box\">
74	<h2>Input</h2>
75	<form name=\"main\" method=\"post\" action=\"/cgi-bin/cduce\">
76	<p><input type=\"submit\" name=\"exec\" value=\"Submit to CDuce\"/>
77	<input type=\"button\" value=\"Clear\" onClick=\"main.prog.value=''\"/>
78	<input type=\"reset\" value=\"Revert changes\"/>
79	";
80
81	p \|\|\| "</p><p><textarea name=\"prog\" cols=\"80\" rows=\"35\">"
82	\|\|\| content
83	\|\|\| "</textarea></p></form></div>"
84	\|\|= ()
85
86
87	let html_footer p =
88	p "</div></body></html>"
89
90
91	let cmds = [ "exec", `Exec;
92	"example", `Example;
93	]
94
95	let cut p w s =
96	let rec aux i x =
97	if i < String.length s then
98	match s.[i] with
99	\| '\n' -> p '\n'; aux (i + 1) 0
100	\| '\r' -> aux (i + 1) 0
101	\| '<' ->
102	let rec tag i =
103	p s.[i];
104	if (s.[i] = '>') then aux (i + 1) x else tag (i + 1) in
105	tag i
106	\| c ->
107	let x = if x = w then (p '\\'; p '\n'; p ':'; 2) else (x + 1) in
108	p c;
109	if c = '&' then
110	let rec ent i =
111	p s.[i];
112	if (s.[i] = ';') then aux (i + 1) x else ent (i + 1) in
113	ent (i + 1)
114	else
115	aux (i + 1) x
116	in
117	aux 0 0
118
119	let main (cgi : Netcgi.std_activation) =
120	let p = cgi # output # output_string in
121	let clicked s = cgi # argument_value s <> "" in
122	try
123	cgi # set_header ();
124
125	let cmd =
126	try snd (List.find (fun (x,y) -> clicked x) cmds)
127	with Not_found -> `New in
128
129	let dialog content = html_form p content in
130
131	let exec src =
132	let v = Location.get_viewport () in
133	let ppf = Html.ppf v
134	and input = Stream.of_string src in
135	Location.push_source (`String src);
136	Location.set_protected true;
137
138	let ok = Cduce.script ppf ppf input in
139	if ok then Format.fprintf ppf "@\nOk.@\n";
140	let res = Html.get v in
141	p "<div class=\"box\"><h2>Results</h2><pre>";
142	cut (cgi # output # output_char) 80 res;
143	p "</pre></div>";
144	dialog src
145	in
146
147	Location.set_viewport (Html.create true);
148	html_header p;
149	let prog = cgi # argument_value "prog" in
150	(match cmd with
151	\| `Exec -> exec prog
152	\| `Example -> dialog (example (cgi # argument_value "example"))
153	\| `New -> dialog ""
154	);
155	p ("
156	<div class=\"box\"><h2>About the prototype</h2>
157	<p>
158	CDuce is under active development; some features may not work properly.
159	<p><a href='mailto:Alain.Frisch@ens.fr'>Webmaster</a></p>
160	<p>Prototype version "^ <:symbol<cduce_version>> ^",
161	built on "^ <:symbol<build_date>> ^".</p></div>");
162	html_footer p;
163	cgi # output # commit_work()
164	with
165	exn ->
166	let msg =
167	match exn with
168	\| Unix.Unix_error (e,f,arg) ->
169	"System error: " ^ (Unix.error_message e) ^
170	"; function " ^ f ^
171	"; argument " ^ arg
172	\| Timeout ->
173	"Timeout reached ! This prototype limits computation time ..."
174	\| exn ->
175	Printexc.to_string exn
176	in
177	fatal_error "Internal software error!" msg
178
179	let () =
180	ignore (Unix.alarm 20);
181	Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout));
182	Random.self_init ();
183	main cgi;
184	cgi # finalize ()
185