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

7
8
open Netcgi

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


26
27
(* Configuration *)

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

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

38
39
40
41
42
43
44
45
46
47
48
49

let persistant = ref false
let session_id = ref ""

let html_header p =
  p "<html>
<head>
  <title>CDuce online prototype</title>
</head>
<body>
  <h1>CDuce online prototype</h1>
";
50
51
52
53
54
  if !persistant then 
    (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><br>")
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70

let html_form p content =
  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\">\
       <input type=submit name=close value=\"Close session\">\
       <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>"


let html_footer p =
71
  p "</body></html>\n"
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113


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;
	     "new", `New;
	   ]
114
115

let main (cgi : Netcgi.std_activation) =
116
117
  let p = cgi # output # output_string in
  let clicked s = cgi # argument_value s <> "" in
118
  try
119
    let nb_sessions = flush_sessions () in
120
121
122
    cgi # set_header
      ~content_type:"text/html; charset=\"iso-8859-1\""
      ();
123

124
125
126
127
128
129
130
131
    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 ...";
132
133
134
135
136
	  let sid = gen_session_id () in
	  (* touch the session file ... *)
	  let chan = open_out_bin (session_file sid) in
	  close_out chan;
	  sid
137
138
139
140
141
142
143
144
145
      | `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
146
147
148

    let load_state () =
      if !persistant then
149
150
	try
	  let chan = open_in_bin (session_file !session_id) in
151
152
153
	  if in_channel_length chan > 0 then
	    (let s = Marshal.from_channel chan in
	     State.set s);
154
	  close_in chan;
155
156
	with Sys_error _ ->
	  failwith "This session has expired ..."
157
    in
158

159
160
161
162
163
164
165
166
167
168
169
170
171
172
    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);
      Load_xml.set_auth false;
      
173
      let ok = Cduce.run ppf ppf input in
174
175
176
      if ok then Format.fprintf ppf "@\nOk.@\n";
      let res = Format.flush_str_formatter () in
      cgi # output # output_string ("<pre>" ^ res ^ "</pre>");
177
178
      if ok then (dialog ""; store_state ()) else dialog src;
    in
179

180
181
182
183
184
185
186
187
188
    let dump src =
      let ppf = Format.str_formatter in

      Format.fprintf ppf "<b>Environment</b>:@.";
      Cduce.dump_env ppf;

      let res = Format.flush_str_formatter () in
      cgi # output # output_string ("<pre>" ^ res ^ "</pre>");
      dialog src
189
190
    in

191
    Location.set_viewport `Html;
192
193
    load_state ();
    store_state ();  (* Just touch the file ... *)
194
195
196
197
198
199
    html_header p;
    let prog = cgi # argument_value "prog" in
    (match cmd with
       | `Exec -> exec prog
       | `Open -> dialog prog
       | `New -> dialog ""
200
       | `Dump -> dump prog
201
202
203
       | `Close -> dialog ""
    );
    html_footer p;
204
205
206
    cgi # output # commit_work()
  with
      exn ->
207
208
209
	let msg = 
	  match exn with
	    | Unix.Unix_error (e,f,arg) ->
210
211
212
		"System error: " ^ (Unix.error_message e) ^ 
		"; function " ^ f ^ 
		"; argument " ^ arg
213
214
215
216
	    | exn ->
	      Printexc.to_string exn
	in
	fatal_error "Internal software error!" msg
217
218
219
220
221

let () =
  main cgi;
  cgi # finalize ()