Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
fdd444dc
Commit
fdd444dc
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-11-10 04:26:26 by cvscast] Empty log message
Original author: cvscast Date: 2002-11-10 04:26:26+00:00
parent
6e5c6504
Changes
1
Hide whitespace changes
Inline
Side-by-side
driver/webiface.ml
View file @
fdd444dc
open
Netcgi
let
session_dir
=
"/home/frisch/sessions"
let
timeout
=
60
(* seconds *)
let
max_sess
=
5
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
;
]
let
main
(
cgi
:
Netcgi
.
std_activation
)
=
let
p
=
cgi
#
output
#
output_string
in
let
clicked
s
=
cgi
#
argument_value
s
<>
""
in
try
let
nb_sessions
=
flush_sessions
()
in
cgi
#
set_header
~
content_type
:
"text/html; charset=
\"
iso-8859-1
\"
"
()
;
let
src
=
cgi
#
argument_value
"prog"
in
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
;
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 ..."
;
gen_session_id
()
|
`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
let
ok
=
Cduce
.
run
ppf
input
in
if
ok
then
Format
.
fprintf
ppf
"@
\n
Ok.@
\n
"
;
let
res
=
Format
.
flush_str_formatter
()
in
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
let
s
=
Marshal
.
from_channel
chan
in
close_in
chan
;
State
.
set
s
;
with
Sys_error
_
->
()
);
cgi
#
output
#
output_string
(
"\
<html>
<head>
<title>CDuce online prototype</title>
</head>
<body>
<h1>CDuce online prototype</h1>
<pre>"
^
res
^
"</pre>
<form method=post>
<textarea name=prog cols=80 rows=25></textarea>
<input type=submit>
</form>
</body>
</html>
"
);
let
ok
=
Cduce
.
run
ppf
input
in
if
ok
then
Format
.
fprintf
ppf
"@
\n
Ok.@
\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
;
cgi
#
output
#
commit_work
()
with
exn
->
...
...
@@ -43,7 +153,16 @@ let main (cgi : Netcgi.std_activation) =
~
cache
:
`No_cache
()
;
cgi
#
output
#
output_string
"<h1>Internal software error!</h1>"
;
cgi
#
output
#
output_string
(
Printexc
.
to_string
exn
);
(
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
);
);
cgi
#
output
#
commit_work
()
let
()
=
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment