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

5
open Netcgi
6
exception Timeout
7

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


25
26
27
28
29
30
(* Loading examples *)

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

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

34
35
36
let (|||) p x = p x; p
let (||=) p () = ()

37
let html_header p =
38
39
40
41
42
43
44
45
  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\"/>
46
  <link type=\"text/css\" href=\"/cduce.css\" rel=\"stylesheet\"/>
47
48
49
50
51
52
53
  <title>CDuce online prototype</title>
</head>
<body>
 <div class=\"title\"> <h1>CDuce online prototype</h1> </div>
 <div id=\"Sidelog\">
   <div class=\"box\">
    <ul>
54
55
56
     <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>
57
58
59
    </ul>
   </div>
";
60

61
62
    p ||| "
<div class=\"box\">
63
64
<br/><center><b style=\"font-size:120&#37;; color: #008000\">Sample programs</b></center>
<p>
65
66
67
68
You can start from one of the predefined examples below or try 
with you own program...</p>
" ||| Examples.present ||| "</div></div><div id=\"Content\">" 
  ||= ()
69

70
71

let html_form p content =
72
73
74
  p "
<div class=\"box\">
 <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
78
   <input type=\"button\" value=\"Clear\" onClick=\"main.prog.value=''\"/>
   <input type=\"reset\" value=\"Revert changes\"/>
79
80
";

81
  p ||| "</p><p><textarea name=\"prog\" cols=\"80\" rows=\"35\">"
82
83
84
    ||| content
    ||| "</textarea></p></form></div>"
    ||= ()
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
96
97
98
99
100
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
101
102
103
104
105
	| '<' ->
	    let rec tag i =
	      p s.[i];
	      if (s.[i] = '>') then aux (i + 1) x else tag (i + 1) in
	    tag i
106
107
108
109
110
111
112
113
114
115
116
117
118
	| 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

119
let main (cgi : Netcgi.std_activation) =
120
121
  let p = cgi # output # output_string in
  let clicked s = cgi # argument_value s <> "" in
122
  try
123
    cgi # set_header ();
124

125
126
127
128
129
    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
130
131

    let exec src =
132
      let v = Cduce_loc.get_viewport () in
133
      let ppf = Html.ppf v
134
      and input = Stream.of_string src in
135
136
      Cduce_loc.push_source (`String src);
      Cduce_loc.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
143
      cut (cgi # output # output_char) 80 res;  
      p "</pre></div>";
144
      dialog src
145
146
    in

147
    Cduce_loc.set_viewport (Html.create true);
148
149
150
151
    html_header p;
    let prog = cgi # argument_value "prog" in
    (match cmd with
       | `Exec -> exec prog
152
       | `Example -> dialog (example (cgi # argument_value "example"))
153
       | `New -> dialog ""
154
    );
155
    p ("
156
157
158
<div class=\"box\"><h2>About the prototype</h2>
<p>
CDuce is under active development; some features may not work properly.
159
<p><a href='mailto:Alain.Frisch@ens.fr'>Webmaster</a></p>
160
161
<p>Prototype version "^ <:symbol<cduce_version>> ^",
 built on "^ <:symbol<build_date>> ^".</p></div>");
162
    html_footer p;
163
164
165
    cgi # output # commit_work()
  with
      exn ->
166
167
168
	let msg = 
	  match exn with
	    | Unix.Unix_error (e,f,arg) ->
169
170
171
		"System error: " ^ (Unix.error_message e) ^ 
		"; function " ^ f ^ 
		"; argument " ^ arg
172
173
	    | Timeout ->
		"Timeout reached ! This prototype limits computation time ..."
174
175
176
177
	    | exn ->
	      Printexc.to_string exn
	in
	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
184
185
  main cgi;
  cgi # finalize ()