Skip to content
GitLab
Switch branch/tag
Find file Normal viewHistoryPermalink
webiface.ml 5.44 KB
Newer Older
Pietro Abate's avatar
[r2002-11-10 04:37:17 by cvscast] Empty log message    
Pietro Abate committed
1
2
3
4
5
6 
(* TODO:
   - correct error messages, not failwith "..."
   - HTML design, logo
   - dump
*)
Pietro Abate's avatar
[r2002-11-09 10:42:14 by cvscast] Empty log message  
Pietro Abate committed
7
8 
open Netcgi
Pietro Abate's avatar
[r2002-11-10 13:06:17 by cvscast] Empty log message    
Pietro Abate committed
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
Pietro Abate's avatar
[r2002-11-10 13:12:27 by cvscast] Empty log message    
Pietro Abate committed
15 
    ~content_type:"text/html; charset=\"iso-8859-1\""
Pietro Abate's avatar
[r2002-11-10 13:06:17 by cvscast] Empty log message    
Pietro Abate committed
16
17
18
19 
    ~cache:`No_cache 
    ();
  cgi # output # output_string ("<h1>" ^ title ^ "</h1>");
  cgi # output # output_string s;
Pietro Abate's avatar
[r2002-11-10 13:50:17 by cvscast] Empty log message    
Pietro Abate committed
20 
  cgi # output # output_string "\n";
Pietro Abate's avatar
[r2002-11-10 13:06:17 by cvscast] Empty log message    
Pietro Abate committed
21 
  cgi # output # commit_work();
Pietro Abate's avatar
[r2002-11-10 13:45:59 by cvscast] Empty log message    
Pietro Abate committed
22
23 
  cgi # finalize ();
  exit 0
Pietro Abate's avatar
[r2002-11-10 13:06:17 by cvscast] Empty log message    
Pietro Abate committed
24
25
Pietro Abate's avatar
[r2002-11-10 04:37:17 by cvscast] Empty log message    
Pietro Abate committed
26
27 
(* Configuration *)
Pietro Abate's avatar
[r2002-11-10 12:49:51 by cvscast] Empty log message    
Pietro Abate committed
28 
let session_dirs = [ "/home/frisch/sessions"; "/users/formel/cduce/sessions" ]
Pietro Abate's avatar
[r2002-11-10 12:56:43 by cvscast] Empty log message    
Pietro Abate committed
29
30 
let session_dir = 
  try List.find Sys.file_exists session_dirs
Pietro Abate's avatar
[r2002-11-10 13:06:17 by cvscast] Empty log message    
Pietro Abate committed
31
32 
  with Not_found -> fatal_error "Internal error" 
    "Cannot find sessions directory"
Pietro Abate's avatar
[r2002-11-10 04:37:17 by cvscast] Empty log message    
Pietro Abate committed
33
34
35
36
37 
let timeout = 60 * 5  (* seconds *)
let max_sess = 10

(*****************)
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66 

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>
";
  if !persistant then (p "(session #"; p !session_id; p ")<br>")

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 =
Pietro Abate's avatar
[r2002-11-10 13:50:17 by cvscast] Empty log message    
Pietro Abate committed
67 
  p "</body></html>\n"
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
68
69
70
71
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 


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;
	   ]
Pietro Abate's avatar
[r2002-11-09 10:42:14 by cvscast] Empty log message  
Pietro Abate committed
110
111 

let main (cgi : Netcgi.std_activation) =
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
112
113 
  let p = cgi # output # output_string in
  let clicked s = cgi # argument_value s <> "" in
Pietro Abate's avatar
[r2002-11-09 10:42:14 by cvscast] Empty log message  
Pietro Abate committed
114 
  try
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
115 
    let nb_sessions = flush_sessions () in
Pietro Abate's avatar
[r2002-11-10 01:10:37 by cvscast] Empty log message    
Pietro Abate committed
116
117
118 
    cgi # set_header
      ~content_type:"text/html; charset=\"iso-8859-1\""
      ();
Pietro Abate's avatar
[r2002-11-09 10:42:14 by cvscast] Empty log message  
Pietro Abate committed
119
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
120
121
122
123
124
125
126
127 
    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 ...";
Pietro Abate's avatar
[r2002-11-10 04:37:17 by cvscast] Empty log message    
Pietro Abate committed
128
129
130
131
132 
	  let sid = gen_session_id () in
	  (* touch the session file ... *)
	  let chan = open_out_bin (session_file sid) in
	  close_out chan;
	  sid
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
133
134
135
136
137
138
139
140
141 
      | `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
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
142
143
144 

    let load_state () =
      if !persistant then
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
145
146 
	try
	  let chan = open_in_bin (session_file !session_id) in
Pietro Abate's avatar
[r2002-11-10 04:37:17 by cvscast] Empty log message    
Pietro Abate committed
147
148
149 
	  if in_channel_length chan > 0 then
	    (let s = Marshal.from_channel chan in
	     State.set s);
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
150 
	  close_in chan;
Pietro Abate's avatar
[r2002-11-10 04:37:17 by cvscast] Empty log message    
Pietro Abate committed
151
152 
	with Sys_error _ ->
	  failwith "This session has expired ..."
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
153 
    in
Pietro Abate's avatar
[r2002-11-09 10:42:14 by cvscast] Empty log message  
Pietro Abate committed
154
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169 
    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;
      
      load_state ();
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
170
171
172
173 
      let ok = Cduce.run ppf input in
      if ok then Format.fprintf ppf "@\nOk.@\n";
      let res = Format.flush_str_formatter () in
      cgi # output # output_string ("<pre>" ^ res ^ "</pre>");
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
174
175 
      if ok then (dialog ""; store_state ()) else dialog src;
    in
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
176
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
177
178
179
180
181
182
183
184
185
186
187 
    let dump src =
      let ppf = Format.str_formatter in
      load_state ();
      store_state ();  (* Just touch the file ... *)

      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
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
188
189 
    in
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
190 
    Location.set_viewport `Html;
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
191
192
193
194
195
196 
    html_header p;
    let prog = cgi # argument_value "prog" in
    (match cmd with
       | `Exec -> exec prog
       | `Open -> dialog prog
       | `New -> dialog ""
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
197 
       | `Dump -> dump prog
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
198
199
200 
       | `Close -> dialog ""
    );
    html_footer p;
Pietro Abate's avatar
[r2002-11-09 10:42:14 by cvscast] Empty log message  
Pietro Abate committed
201
202
203 
    cgi # output # commit_work()
  with
      exn ->
Pietro Abate's avatar
[r2002-11-10 13:45:59 by cvscast] Empty log message    
Pietro Abate committed
204
205
206 
	let msg = 
	  match exn with
	    | Unix.Unix_error (e,f,arg) ->
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
207
208
209 
		"System error: " ^ (Unix.error_message e) ^ 
		"; function " ^ f ^ 
		"; argument " ^ arg
Pietro Abate's avatar
[r2002-11-10 13:45:59 by cvscast] Empty log message    
Pietro Abate committed
210
211
212
213 
	    | exn ->
	      Printexc.to_string exn
	in
	fatal_error "Internal software error!" msg
Pietro Abate's avatar
[r2002-11-09 10:42:14 by cvscast] Empty log message  
Pietro Abate committed
214
215
216
217
218 

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