webiface.ml 4.97 KB
Newer Older
1
2
3
4
(* TODO:
   - HTML design, logo
*)

5
open Netcgi
6
exception Timeout
7

8
9
10
11
let config = Netcgi.default_config 
let cgi _ ch = new Netchannels.buffered_trans_channel ch 

(*
12
13
let operating_type = Netcgi.buffered_transactional_optype
let cgi = new Netcgi.std_activation ~operating_type ()
14
*)
15
16


17
18
19
20
21
22
(* Loading examples *)

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

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

26
27
28
let (|||) p x = p x; p
let (||=) p () = ()

29
let html_header p =
30
  p "
31
<?xml version=\"1.0\" encoding=\"UTF-*\"?>
32
33
34
35
<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
  \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
<html>
<head>
36
  <meta content=\"text/html\"; charset=\"UTF-8\" 
37
        http-equiv=\"Content-Type\"/>
38
  <link type=\"text/css\" href=\"/cduce.css\" rel=\"stylesheet\"/>
39
40
41
42
43
44
45
  <title>CDuce online prototype</title>
</head>
<body>
 <div class=\"title\"> <h1>CDuce online prototype</h1> </div>
 <div id=\"Sidelog\">
   <div class=\"box\">
    <ul>
46
47
48
     <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>
49
50
51
    </ul>
   </div>
";
52

53
54
    p ||| "
<div class=\"box\">
55
56
<br/><center><b style=\"font-size:120&#37;; color: #008000\">Sample programs</b></center>
<p>
57
58
59
60
You can start from one of the predefined examples below or try 
with you own program...</p>
" ||| Examples.present ||| "</div></div><div id=\"Content\">" 
  ||= ()
61

62
63

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

73
  p ||| "</p><p><textarea name=\"prog\" cols=\"80\" rows=\"35\">"
74
75
76
    ||| content
    ||| "</textarea></p></form></div>"
    ||= ()
77
78
79


let html_footer p =
80
  p "</div></body></html>"
81
82


83
let cmds = [ "exec", `Exec;
84
	     "example", `Example;
85
	   ]
86

87
88
89
90
91
92
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
93
94
95
96
97
	| '<' ->
	    let rec tag i =
	      p s.[i];
	      if (s.[i] = '>') then aux (i + 1) x else tag (i + 1) in
	    tag i
98
99
100
101
102
103
104
105
106
107
108
109
110
	| 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

111
112
let main (cgi : Netcgi.cgi) =
  let p = cgi # out_channel # output_string in
113
  let clicked s = cgi # argument_value s <> "" in
114
115
116
117
118
119
120
121
122
123
124
125
  let fatal_error title s =
    cgi # out_channel # rollback_work();
    cgi # set_header 
      ~content_type:"text/html\"; charset=\"UTF-8\""
      ~cache:`No_cache 
      ();
    cgi # out_channel # output_string ("<h1>" ^ title ^ "</h1>");
    cgi # out_channel # output_string s;
    cgi # out_channel # output_string "\n";
    cgi # out_channel # commit_work();
    cgi # finalize (); 
    exit 0 in
126
  try
127
    cgi # set_header ();
128

129
130
131
132
133
    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
134
135

    let exec src =
136
      let v = Cduce_loc.get_viewport () in
137
      let ppf = Html.ppf v
138
      and input = Stream.of_string src in
139
140
      Cduce_loc.push_source (`String src);
      Cduce_loc.set_protected true;
141
      
142
      let ok = Cduce.script ppf ppf input in
143
      if ok then Format.fprintf ppf "@\nOk.@\n";
144
      let res = Html.get v in
145
      p "<div class=\"box\"><h2>Results</h2><pre>"; 
146
      cut (cgi # out_channel # output_char) 80 res;  
147
      p "</pre></div>";
148
      dialog src
149
150
    in

151
    Cduce_loc.set_viewport (Html.create true);
152
153
154
155
    html_header p;
    let prog = cgi # argument_value "prog" in
    (match cmd with
       | `Exec -> exec prog
156
       | `Example -> dialog (example (cgi # argument_value "example"))
157
       | `New -> dialog ""
158
    );
159
    p ("
160
161
162
<div class=\"box\"><h2>About the prototype</h2>
<p>
CDuce is under active development; some features may not work properly.
Giuseppe Castagna's avatar
Giuseppe Castagna committed
163
<p><a href='mailto:gc@pps.univ-paris-diderot.fr'>Webmaster</a></p>
164
165
<p>Prototype version "^ <:symbol<cduce_version>> ^",
 built on "^ <:symbol<build_date>> ^".</p></div>");
166
    html_footer p;
167
    cgi # out_channel # commit_work()
168
169
  with
      exn ->
170
171
172
	let msg = 
	  match exn with
	    | Unix.Unix_error (e,f,arg) ->
173
174
175
		"System error: " ^ (Unix.error_message e) ^ 
		"; function " ^ f ^ 
		"; argument " ^ arg
176
177
	    | Timeout ->
		"Timeout reached ! This prototype limits computation time ..."
178
179
180
181
	    | exn ->
	      Printexc.to_string exn
	in
	fatal_error "Internal software error!" msg
182
183

let () =
184
  ignore (Unix.alarm 20);
185
  Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout));
186
  Random.self_init ();
187
188
  Netcgi_cgi.run ~config ~output_type:(`Transactional cgi) main;

189