Skip to content

GitLab

Switch branch/tag
Find file Normal viewHistoryPermalink
webiface.ml 5.6 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 

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>
";
Pietro Abate's avatar
[r2002-11-10 16:20:52 by cvscast] Empty log message    
Pietro Abate committed
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>")
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
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 =
Pietro Abate's avatar
[r2002-11-10 13:50:17 by cvscast] Empty log message    
Pietro Abate committed
71 
  p "</body></html>\n"
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
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;
	   ]
Pietro Abate's avatar
[r2002-11-09 10:42:14 by cvscast] Empty log message  
Pietro Abate committed
114
115 

let main (cgi : Netcgi.std_activation) =
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
116
117 
  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
118 
  try
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
119 
    let nb_sessions = flush_sessions () in
Pietro Abate's avatar
[r2002-11-10 01:10:37 by cvscast] Empty log message    
Pietro Abate committed
120
121
122 
    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
123
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
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 ...";
Pietro Abate's avatar
[r2002-11-10 04:37:17 by cvscast] Empty log message    
Pietro Abate committed
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
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
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
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
146
147
148 

    let load_state () =
      if !persistant then
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
149
150 
	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
151
152
153 
	  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
154 
	  close_in chan;
Pietro Abate's avatar
[r2002-11-10 04:37:17 by cvscast] Empty log message    
Pietro Abate committed
155
156 
	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
157 
    in
Pietro Abate's avatar
[r2002-11-09 10:42:14 by cvscast] Empty log message  
Pietro Abate committed
158
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
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;
Pietro Abate's avatar
[r2002-11-13 23:21:38 by cvscast] Empty log message    
Pietro Abate committed
173 
      let ok = Cduce.run ppf ppf input in
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
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>");
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
177
178 
      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
179
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
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
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
189
190 
    in
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
191 
    Location.set_viewport `Html;
Pietro Abate's avatar
[r2002-11-10 22:26:37 by cvscast] Passage au type XML    
Pietro Abate committed
192
193 
    load_state ();
    store_state ();  (* Just touch the file ... *)
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
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 ""
Pietro Abate's avatar
[r2002-11-10 16:13:31 by cvscast] Empty log message    
Pietro Abate committed
200 
       | `Dump -> dump prog
Pietro Abate's avatar
[r2002-11-10 04:26:26 by cvscast] Empty log message    
Pietro Abate committed
201
202
203 
       | `Close -> dialog ""
    );
    html_footer p;
Pietro Abate's avatar
[r2002-11-09 10:42:14 by cvscast] Empty log message  
Pietro Abate committed
204
205
206 
    cgi # output # commit_work()
  with
      exn ->
Pietro Abate's avatar
[r2002-11-10 13:45:59 by cvscast] Empty log message    
Pietro Abate committed
207
208
209 
	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
210
211
212 
		"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
213
214
215
216 
	    | 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
217
218
219
220
221 

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