webiface.ml 5.28 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
20
    ~cache:`No_cache 
    ();
  cgi # output # output_string ("<h1>" ^ title ^ "</h1>");
  cgi # output # output_string s;
  cgi # output # commit_work();
21
22
  cgi # finalize ()

23

24
let () = fatal_error "Error" "Blabla\n\n"
25

26
(*
27
28
(* Configuration *)

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

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

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
67
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
110

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 =
  p "</body></html>"


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;
	   ]
111
112

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

121
122
123
124
125
126
127
128
    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 ...";
129
130
131
132
133
	  let sid = gen_session_id () in
	  (* touch the session file ... *)
	  let chan = open_out_bin (session_file sid) in
	  close_out chan;
	  sid
134
135
136
137
138
139
140
141
142
      | `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
143
    
144
145
146
147
148
149
150
151
152
153
    let exec src =
      let ppf = Format.str_formatter
      and input = Stream.of_string src in
      Location.set_source (`String src);
      Location.set_viewport `Html;
      Load_xml.set_auth false;
      
      if !persistant then (
	try
	  let chan = open_in_bin (session_file !session_id) in
154
155
156
	  if in_channel_length chan > 0 then
	    (let s = Marshal.from_channel chan in
	     State.set s);
157
	  close_in chan;
158
159
	with Sys_error _ ->
	  failwith "This session has expired ..."
160
      );
161

162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
      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>");
      if ok then dialog "" else dialog src;

      if ok && !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

    html_header p;
    let prog = cgi # argument_value "prog" in
    (match cmd with
       | `Exec -> exec prog
       | `Open -> dialog prog
       | `New -> dialog ""
       | `Dump -> failwith "Dump not yet implemented"
       | `Close -> dialog ""
    );
    html_footer p;
186
187
188
189
    cgi # output # commit_work()
  with
      exn ->
	cgi # output # rollback_work();
190
191
192
193
	cgi # set_header 
	  ~status:`Internal_server_error
          ~cache:`No_cache 
	  ();
194
	cgi # output # output_string "<h1>Internal software error!</h1>";
195
196
197
198
199
200
201
202
203
204
	(match exn with
	  | Unix.Unix_error (e,f,arg) ->
	      cgi # output # output_string (
		"System error: " ^ (Unix.error_message e) ^ 
		"; function " ^ f ^ 
		"; argument " ^ arg
	      )
	  | exn ->
	      cgi # output # output_string (Printexc.to_string exn);
	);
205
206
207
208
209
210
	cgi # output # commit_work()

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

211
*)