/[svn]/driver/webiface.ml
ViewVC logotype

Diff of /driver/webiface.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 96 by abate, Tue Jul 10 17:05:59 2007 UTC revision 97 by abate, Tue Jul 10 17:06:02 2007 UTC
# Line 1  Line 1 
1  open Netcgi  open Netcgi
2    
3    let session_dir = "/home/frisch/sessions"
4    let timeout = 60  (* seconds *)
5    let max_sess = 5
6    
7    let persistant = ref false
8    let session_id = ref ""
9    
10    let html_header p =
11      p "<html>
12    <head>
13      <title>CDuce online prototype</title>
14    </head>
15    <body>
16      <h1>CDuce online prototype</h1>
17    ";
18      if !persistant then (p "(session #"; p !session_id; p ")<br>")
19    
20    let html_form p content =
21      p "<form method=post>";
22      p "<input type=submit name=exec value=\"Submit to CDuce\">";
23      if !persistant then(
24        p "<input type=submit name=dump value=\"Show current environment\">\
25           <input type=submit name=close value=\"Close session\">\
26           <input type=hidden name=session value=\""; p !session_id; p "\">";
27      ) else (
28        p "<input type=submit name=open value=\"Initiate session\">";
29      );
30      p "<br><textarea name=prog cols=80 rows=25>"; p content; p "</textarea>";
31      p "</form>"
32    
33    
34    let html_footer p =
35      p "</body></html>"
36    
37    
38    let () =
39      Random.self_init ();
40      State.close ()
41    
42    let session_file sid =
43      Filename.concat session_dir sid
44    
45    let gen_session_id () =  string_of_int (Random.bits ())
46    
47    let check_session_id sid =
48      try ignore (int_of_string sid)
49      with _ -> failwith "Invalid session id"
50    
51    let close_session sid =
52      check_session_id sid;
53      try Unix.unlink (session_file sid)
54      with Unix.Unix_error (_,_,_) -> ()
55    
56    let flush_sessions () =
57      let time = Unix.time () -. (float timeout) in
58      let n = ref 0 in
59      let dir = Unix.opendir session_dir in
60      try while true do
61        let f = session_file (Unix.readdir dir) in
62        let st = Unix.stat f in
63        if (st.Unix.st_kind = Unix.S_REG) then
64          if  (st.Unix.st_mtime < time)
65          then Unix.unlink f
66          else incr n
67      done; assert false with End_of_file ->
68        Unix.closedir dir;
69        !n
70    
71    
72    let cmds = [ "open", `Open;
73                 "close", `Close;
74                 "dump", `Dump;
75                 "exec", `Exec;
76                 "new", `New;
77               ]
78    
79  let main (cgi : Netcgi.std_activation) =  let main (cgi : Netcgi.std_activation) =
80      let p = cgi # output # output_string in
81      let clicked s = cgi # argument_value s <> "" in
82    try    try
83        let nb_sessions = flush_sessions () in
84      cgi # set_header      cgi # set_header
85        ~content_type:"text/html; charset=\"iso-8859-1\""        ~content_type:"text/html; charset=\"iso-8859-1\""
86        ();        ();
     let src = cgi # argument_value "prog" in  
87    
88        let cmd =
89          try snd (List.find (fun (x,y) -> clicked x) cmds)
90          with Not_found -> `New in
91    
92        let sid = match cmd with
93          | `Open ->
94              if (nb_sessions >= max_sess) then
95                failwith "Too many open sessions ...";
96              gen_session_id ()
97          | `Close -> close_session (cgi # argument_value "session"); ""
98          | `New ->  ""
99          | _ -> cgi # argument_value "session"
100        in
101        session_id := sid;
102        persistant := !session_id <> "";
103        if !persistant then check_session_id !session_id;
104    
105        let dialog content = html_form p content in
106    
107        let exec src =
108      let ppf = Format.str_formatter      let ppf = Format.str_formatter
109      and input = Stream.of_string src in      and input = Stream.of_string src in
110      Location.set_source (`String src);      Location.set_source (`String src);
111      Location.set_viewport `Html;      Location.set_viewport `Html;
112      Load_xml.set_auth false;      Load_xml.set_auth false;
113    
114          if !persistant then (
115            try
116              let chan = open_in_bin (session_file !session_id) in
117              let s = Marshal.from_channel chan in
118              close_in chan;
119              State.set s;
120            with Sys_error _ -> ()
121          );
122    
123      let ok = Cduce.run ppf input in      let ok = Cduce.run ppf input in
124      if ok then Format.fprintf ppf "@\nOk.@\n";      if ok then Format.fprintf ppf "@\nOk.@\n";
125      let res = Format.flush_str_formatter () in      let res = Format.flush_str_formatter () in
126          cgi # output # output_string ("<pre>" ^ res ^ "</pre>");
127          if ok then dialog "" else dialog src;
128    
129      cgi # output # output_string ("\        if ok && !persistant then (
130  <html>          let s = State.get () in
131  <head>          let chan = open_out_bin (session_file !session_id) in
132    <title>CDuce online prototype</title>          Marshal.to_channel chan s [ Marshal.Closures ];
133  </head>          close_out chan
134  <body>        )
135    <h1>CDuce online prototype</h1>      in
136  <pre>" ^ res ^ "</pre>  
137        html_header p;
138  <form method=post>      let prog = cgi # argument_value "prog" in
139   <textarea name=prog cols=80 rows=25></textarea>      (match cmd with
140   <input type=submit>         | `Exec -> exec prog
141  </form>         | `Open -> dialog prog
142  </body>         | `New -> dialog ""
143  </html>         | `Dump -> failwith "Dump not yet implemented"
144  ");         | `Close -> dialog ""
145        );
146        html_footer p;
147      cgi # output # commit_work()      cgi # output # commit_work()
148    with    with
149        exn ->        exn ->
# Line 43  Line 153 
153            ~cache:`No_cache            ~cache:`No_cache
154            ();            ();
155          cgi # output # output_string "<h1>Internal software error!</h1>";          cgi # output # output_string "<h1>Internal software error!</h1>";
156            (match exn with
157              | Unix.Unix_error (e,f,arg) ->
158                  cgi # output # output_string (
159                    "System error: " ^ (Unix.error_message e) ^
160                    "; function " ^ f ^
161                    "; argument " ^ arg
162                  )
163              | exn ->
164          cgi # output # output_string (Printexc.to_string exn);          cgi # output # output_string (Printexc.to_string exn);
165            );
166          cgi # output # commit_work()          cgi # output # commit_work()
167    
168  let () =  let () =
Legend:
Removed from v.96  
changed lines
  Added in v.97
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5