%% $OpenXM: OpenXM/src/kan96xx/Doc/httpd.sm1,v 1.22 2013/03/07 02:10:32 takayama Exp $
%% common modules for httpd on sm1.
% [(Strict) 1] system_variable % for debugging.
/httpd.rawplus 0 def
/Oxserver_history_variable (Oxserver_history_variable_) def
/httpd.image.type
[(getenv) (OpenXM_PSTOIMG_TYPE)] extension
def
/httpd_sm1.cookie
[(oxGenPass)] extension
def
/httpd.set-cookie {
[(Set-Cookie: httpd_sm1=) httpd_sm1.cookie] cat
} def
[(getenv) (OXWEB_DEBUG)] extension tag 0 eq {
/httpd.debug 0 def
} {
/httpd.debug 1 def
} ifelse
[(getenv) (OXWEB_TAKE_LOG)] extension tag 0 eq {
/httpd.take.log 0 def
} {
/httpd.take.log 1 def
} ifelse
/httpd_startserver {
[(sm1.socket) (open) [httpd.port (localhost)]] extension
/httpd.server.fdAndPort set
(sm1.socket.open returns ) messagen httpd.server.fdAndPort message
[(sm1.socket) (accept) [httpd.server.fdAndPort 0 get]] extension
/httpd.server.fd set
(connected.) message
(sm1.socket.accept returns ) messagen httpd.server.fd message
} def
/httpd_stopserver {
[(sm1.socket) (close) httpd.server.fd ] extension message
} def
/send_packet {
/arg1 set
[(sm1.socket) (write) [httpd.server.fd 0 get arg1]] extension message
} def
/sendln {
/arg1 set
[/in-sendln /mmm /i] pushVariables
[ arg1 /mmm set
mmm tag 5 eq {
[mmm 10 (string) dc] cat /mmm set
}{
10 (string) dc /mmm set
} ifelse
[(sm1.socket) (select) [httpd.server.fd 0 get 0]] extension {
(Warning (sendln): your peer closed the connection. Do not send the data.) message
} {
[(sm1.socket) (write) [httpd.server.fd 0 get mmm]] extension /i set
httpd.debug { i message } { } ifelse
} ifelse
] pop
popVariables
} def
/sendBinaryFile {
/arg1 set
[/in-sendln /fname /fd /c /cdata] pushVariables
[ arg1 /fname set
[(sendBinaryFile: sending data) ] cat message
[(fp2openForRead) fname] extension /fd set fd message
fd 0 lt {
[(Error: sendBinaryFile: file ) fname ( is not found.)] cat message
/aaaa goto
} { } ifelse
[(fp2pushfile) fname] extension /cdata set
[(sm1.socket) (select) [httpd.server.fd 0 get 0]] extension {
(Warning (sendBinaryFile): your peer closed the connection. Do not send the data.)
message
exit
} {
[(sm1.socket) (writeByte) [httpd.server.fd 0 get cdata]] extension pop
} ifelse
/aaaa
] pop
popVariables
} def
/httpd {
/httpd.serial 0 def
/httpd.history [ ] def
/httpd.result.history [ 0 ] def
[(nobody)] extension pop
{
httpd_startserver ;
httpd_action ;
httpd_stopserver ;
httpd.take.log { (date) system } { } ifelse
% (sleep 2) system
httpd.serial 1 add /httpd.serial set
} loop
} def
/send-page-bye {
(HTTP/0.9 200 OK) sendln
%% (Date: Sun, 18 Mar 2001 02:54:50 GMT) sendln
%% (Server: sm1/0.1 (Unix)) sendln
%% (Last-Modified: Wed, 23 Aug 2000 11:19:27 GMT) sendln
%% (ETag: "1f8f-5df-39a3b33f") sendln
%% (Accept-Ranges: bytes) sendln
%% (Content-Length: 10) sendln
(Connection: close) sendln
% (Content-Type: text/plain) sendln
(Content-Type: text/html) sendln
0 sendln
(<html>) sendln
(Shutdown the engine. <br>) sendln
(See you! <a href="http://www.openxm.org"> Web/asir, Web/sm1 </a>) sendln
(</html>) sendln
0 sendln
[(flush)] extension
} def
/send-page-2 {
(HTTP/0.9 200 OK) sendln
%% (Content-Length: 10) sendln
(Connection: close) sendln
(Content-Type: text/html) sendln
0 sendln
(<FORM NAME="myFORM">) sendln
(<INPUT TYPE="TEXT" NAME="Num">) sendln
(</FORM>) sendln
0 sendln
[(flush)] extension
} def
/send-page-3 {
/arg1 set
[/in-send-page-3 /result] pushVariables
[
/result arg1 def
(HTTP/0.9 200 OK) sendln
(Connection: close) sendln
(Content-Type: text/html) sendln
httpd.set-cookie sendln
0 sendln
%% (<FORM NAME="myFORM" METHOD="POST">) sendln
result sendln
%%(<img src="hoge.jpeg"> <img>) sendln %%test. It does not work always?!
%%(<a href="hoge.jpeg"> Pretty format </a>) sendln %%test. It works.
[(getenv) (OXWEB_POST)] extension tag 0 eq {
(<FORM NAME="myFORM">) sendln % use get
}{
(<FORM NAME="myFORM" METHOD="POST">) sendln
} ifelse
(<INPUT TYPE=submit VALUE="submit">) sendln
[(<textarea name=) httpd.textarea.name
( rows=10 cols="80" wrap="soft"></textarea>)] cat sendln
(</FORM>) sendln
send-menu-1
0 sendln
[(flush)] extension
] pop
popVariables
} def
/send-image {
/arg2 set
/arg1 set
[/in-send-jpeg /fname /imagetype /ff /fsize] pushVariables
[
/fname arg1 def % set the jpeg file name.
/imagetype arg2 def % jpeg or gif
[(stat) fname] extension 0 get tag 0 eq {
(Warning (send-image): the file ) messagen fname messagen ( is not found.) message
/notFound goto
}{ }ifelse
[(stat) fname] extension 1 get 0 get toString /fsize set
(HTTP/1.1 200 OK) dup message sendln
(Server: httpd_sm1) dup message sendln
%% (ETag: "2197-bf6c-3b2d6541") sendln ???
(Accept-Ranges: bytes) dup message sendln
[(Content-Length: ) fsize] cat dup message sendln
(Connection: close) dup message sendln
[(Content-Type: image/) imagetype] cat dup message sendln
[(flush)] extension
0 sendln
fname sendBinaryFile
0 sendln
[(flush)] extension
/notFound
] pop
popVariables
} def
/send-page-warning {
(HTTP/0.9 200 OK) sendln
(Connection: close) sendln
(Content-Type: text/html) sendln
0 sendln
(You cannot execute ox servers without a session key! <br>) sendln
0 sendln
[(flush)] extension
} def
/send-page-warning-image {
(HTTP/0.9 200 OK) sendln
(Connection: close) sendln
(Content-Type: text/html) sendln
0 sendln
(Error: Image translation is not supported on this server<br>) sendln
( Check the value of the environmental variable OpenXM_PSTOIMG_TYPE <br>) sendln
0 sendln
[(flush)] extension
} def
/stopclient {
[(sm1.socket) (close) [client.fdAndPort 0 get] ] extension message
} def
/cleanErrors {
/arg1 set
[/in-cleanErrors /clientt /spp] pushVariables
[
/clientt arg1 def
clientt oxgetsp (integer) dc /spp set
clientt spp oxpops
] pop
popVariables
} def
/fromHex {
/arg1 set
[/in-fromHex /s1 /s2 /c /c2] pushVariables
[
arg1 0 get /s1 set
arg1 1 get /s2 set
48 s1 le s1 57 le and { % 0, ..., 9
s1 48 sub /c set
}{ } ifelse
65 s1 le s1 70 le and { % A, ..., F
s1 65 sub 10 add /c set
}{ } ifelse
97 s1 le s1 102 le and { % a, ..., f
s1 97 sub 10 add /c set
}{ } ifelse
c 16 mul /c set
48 s2 le s2 57 le and { % 0, ..., 9
s2 48 sub /c2 set
}{ } ifelse
65 s2 le s2 70 le and { % A, ..., F
s2 65 sub 10 add /c2 set
}{ } ifelse
97 s2 le s2 102 le and { % a, ..., f
s2 97 sub 10 add /c2 set
}{ } ifelse
c c2 add /arg1 set
] pop
popVariables
arg1
} def
/randomName {
[/in-randomName /sss /rrr ] pushVariables
[
%% Seed name
/sss [ 97 97 97 97 97 97 97 97 97 97 ] def %% 97 == 'a'
%% This procedure to generate port number might fail.
sss {
[
[(oxGenPass)] extension .. /rrr set
[(tdiv_qr) rrr (26)..] mpzext 1 get /rrr set
] pop
rrr (integer) dc add
} map
/sss set
sss {(string) dc} map cat /arg1 set
] pop
popVariables
arg1
} def
(httpd.textarea.name) boundp { }
{
/httpd.textarea.name randomName def
/httpd.textarea.name.aaa
[(GET /?) httpd.textarea.name] cat
(array) dc
def
} ifelse
/askToSendFile {
/arg1 set
[/in-askToSendFile /ss /fname] pushVariables
[
/ss arg1 def
/fname null def
ss toTokensBySpace /ss set
ss 0 get (GET) eq {
ss 1 get length 1 gt {
ss 1 get (array) dc 1 get 63 eq { %% See if /?
/fname null def
}{
/fname ss 1 get def % set the file name.
fname (array) dc rest /fname set % remove /
fname { (string) dc } map cat /fname set
} ifelse
}{ /fname null def } ifelse
}{
/fname null def
} ifelse
(::::) messagen ss message fname message
/arg1 fname def
] pop
popVariables
arg1
} def
%% remove GET /?msg= or msg=
/removeGET {
/arg1 set
[/in-removeGET /s /s2 /i /j /i0
/tname /nnn /sta
] pushVariables
[
/s arg1 def
/httpd.textarea.valid 0 def
s 1 copy /s2 set
s (array) dc /s set
/sta 0 def
%% In case of POST, remove the HTTP header. cf. trouble for NS 6.0
s length 4 gt {
[s 0 get s 1 get s 2 get s 3 get] (POST) (array) dc eq {
0 1 s length 4 sub {
/i0 set
/sta i0 def
[ s i0 get s i0 1 add get ] [ 10 10 ] eq
[ s i0 get s i0 1 add get s i0 2 add get s i0 3 add get]
[ 13 10 13 10] eq or
{ exit } { } ifelse
} for
}{ } ifelse
} { } ifelse
(sta=) messagen sta message
/nnn httpd.textarea.name.aaa length 6 sub def
/tname [ ] def
sta 1 s length 1 sub {
/i0 set
s i0 get 61 eq { %% 61 is =
i0 1 add /i0 set
[
<< tname length 1 sub >> -1
<< tname length nnn sub >> dup 0 ge { } { pop 0 } ifelse
{
/i set
tname i get
} for
] reverse /tname set
(GET /?) (array) dc tname join /tname set
httpd.debug { httpd.textarea.name.aaa message } { } ifelse
tname httpd.textarea.name.aaa eq {
/httpd.textarea.valid 1 def
} {
/httpd.textarea.valid 0 def
tname message
httpd.textarea.name.aaa { (string) dc } map cat message
(Warning: got an invalid name for the text field.) message
} ifelse
exit
} { } ifelse
tname s i0 get append /tname set
} for
/j 0 def
i0 1 s length 1 sub {
/i set
s2 j << s i get (string) dc >> put
j s2 length 1 sub lt { s2 j 1 add ( ) put } { } ifelse
%% might cause a BUG. It should be improved.
j 1 add /j set
} for
/arg1 s2 def
] pop
arg1
} def
/webstringToAscii {
/arg1 set
[/in-webstringToAscii /s /i /j /c /n] pushVariables
[
/s arg1 def
s (array) dc /s set
/j 0 def /n s length def
/i 0 def
{
s i get /c set
c 32 eq { exit } { } ifelse
c 37 eq { % c == %
[s i 1 add get s i 2 add get] fromHex /c set
s j c put
j 1 add /j set
i 3 add /i set
} {
c 43 eq { % c == +
httpd.rawplus { s j 43 put } { s j 32 put } ifelse
j 1 add /j set
i 1 add /i set
} {
c 13 eq { % c == 0xd
i 1 add /i set
} {
s j c put
j 1 add /j set
i 1 add /i set
} ifelse
} ifelse
} ifelse
i n ge { exit } { } ifelse
} loop
s j carN /s set
s { (string) dc } map cat /arg1 set
] pop
popVariables
arg1
} def
/preformatHTML {
/arg1 set
[/in-preformatHTML /sss /c] pushVariables
[
/sss arg1 def
sss toString /sss set
sss (array) dc /sss set
sss {
/c set
[
c 60 eq {
/c (<) def
} { } ifelse
c 62 eq {
/c (>) def
} { } ifelse
c 38 eq {
/c (&) def
} { } ifelse
] pop
c (string) dc
} map cat /sss set
[(<pre> ) sss ( </pre> )] cat /arg1 set
] pop
popVariables
arg1
} def
/executeStringAndSelectInputFromBrowserAndOxserver {
/arg3 set
/arg2 set
/arg1 set
[/in-executeStringAndSelectInputFromBrowserAndOxserver
/oxserver.ccc
/command.to.oxserver
/sss.engine
/sss.web
/sss
/err
/httpd.result
/stringOrCmo
] pushVariables
% Global var: httpd.server.fd
[
/oxserver.ccc arg1 def
/command.to.oxserver arg2 def
/stringOrCmo arg3 def
oxserver.ccc
command.to.oxserver
oxexecutestring ;
[(oxReq) oxserver.ccc SM_dupErrors ] extension pop
[(oxReq) oxserver.ccc SM_popCMO ] extension pop
stringOrCmo (string) eq {
[(oxReq) oxserver.ccc SM_popString ] extension pop
}{
[(oxReq) oxserver.ccc SM_popCMO ] extension pop
} ifelse
[(flush)] extension pop
%% Select inputs for interruption.
%% Wait by the spin lock.
{
[(oxMultiSelect) [oxserver.ccc] 1] extension 1 get 0 get
/sss.engine set
[(sm1.socket) (mselect)
[[httpd.server.fd 0 get] 1]
] extension 0 get /sss.web set
/sss [sss.engine sss.web] def
sss.engine { exit } { } ifelse
sss.web { exit } { } ifelse
} loop
sss message
sss 0 get {
[(oxGet) oxserver.ccc] extension /err set
[(oxGet) oxserver.ccc] extension /httpd.result set
} {
oxserver.ccc oxreset
oxserver.ccc ("computation is interrupted.";) oxexecutestring ;
oxserver.ccc oxpopstring
/httpd.result set
exit
} ifelse
(------------- result -------------) message
httpd.result message
(----------------------------------) message
( ) message
err message
err [ ] eq {
} {
oxserver.ccc cleanErrors
[httpd.result 10 (string) dc err toString] cat
/httpd.result set
} ifelse
/arg1 [err httpd.result] def
] pop
popVariables
arg1
} def
% This function will be written in C in a future.
% [(httpd) (parseHTTP) string] extension
% [(GET) key-value-pair-1 key-value-pair-2 ...]
% [(POST) key-value-pair-1 key-value-pair-2 ...]
% [(GET-file) file-1 file2 ...]
% ex. (GET / HTT..) (GET /?rpc=1-2)
/httpd.parse {
/arg1 set
[/in-httpd.parse /s /s2 /sta /i0
/ans /getKeyword /j /tname /tvalue
] pushVariables
[
/s arg1 def
s 1 copy /s2 set
s (array) dc /s set
/sta 0 def
/getKeyword 0 def
s length 7 lt {
/ans [(GET-file)] def
/httpd.exit goto
}{ } ifelse
/ans [(GET)] def
[s 0 get s 1 get s 2 get s 3 get s 4 get s 5 get] (GET /?) (array) dc eq {
/sta 6 def
/getKeyword 1 def
}{
[s 0 get s 1 get s 2 get s 3 get s 4 get] (GET /) (array) dc eq {
/sta 5 def
}{
[s 0 get s 1 get s 2 get s 3 get] (GET ) (array) dc eq {
/ans [(GET-file)] def
/httpd.exit goto
} { /ans [ ] def /httpd.exit.goto } ifelse
} ifelse
}ifelse
%% In case of POST, remove the HTTP header. cf. trouble for NS 6.0
[s 0 get s 1 get s 2 get s 3 get] (POST) (array) dc eq {
/ans [(POST) ] def
/getKeyword 1 def
0 1 s length 4 sub {
/i0 set
/sta i0 def
[ s i0 get s i0 1 add get ] [ 10 10 ] eq
[ s i0 get s i0 1 add get s i0 2 add get s i0 3 add get]
[ 13 10 13 10] eq or
{ exit } { } ifelse
} for
}{ } ifelse
(sta=) messagen sta message
%% get file name
getKeyword not {
/tname [ ] def
sta 1 << s length 1 sub >> {
/i0 set
s i0 get 32 le { %% 32 is " "
exit
} { } ifelse
tname s i0 get append /tname set
} for
httpd.debug { (Filename is ) messagen tname {(string) dc } map message} { } ifelse
/ans [(GET-file) tname { (string) dc } map cat ] def
/httpd.exit goto
} { } ifelse
/tname [ ] def
sta 1 << s length 1 sub >> {
/i0 set
s i0 get 61 eq { %% 61 is =
httpd.debug { tname message tname {(string) dc } map cat message} { } ifelse
i0 1 add /i0 set
exit
} { } ifelse
tname s i0 get append /tname set
} for
%% Remove space and cr/lf from the key word.
[
0 1 tname length 1 sub {
/j set
tname j get 36 le {
} {
tname j get
} ifelse
} for
] /tname set
/j 0 def
i0 1 s length 1 sub {
/i set
s2 j << s i get (string) dc >> put
j s2 length 1 sub lt { s2 j 1 add ( ) put } { } ifelse
%% might cause a BUG. It should be improved.
j 1 add /j set
} for
ans [tname {(string) dc} map cat
s2 webstringToAscii ] append
/ans set
/httpd.exit
ans length 1 lt {
/ans [(Unknown)] def
} { } ifelse
/arg1 ans def
] pop
popVariables
arg1
} def
/httpd.root [(getenv) (OXWEB_HTTPD_ROOT)] extension def
%% /usr/local/www/data/ Assume slash!!
% [(GET-file) (filename)] httpd_sendfile
% [(MSG) (message)] httpd_sendfile
/httpd_sendfile {
/arg1 set
[/in-htpd_sendfile /msg /fname /fname2
/fsize
] pushVariables
[
/msg arg1 def
%% Send message. [(MSG) msg2 ...] httpd_sendfile
msg message
msg 0 get (MSG) eq {
(HTTP/0.9 200 OK) sendln
(Connection: close) sendln
(Content-Type: text/html) sendln
0 sendln
msg rest { sendln } map
0 sendln
[(flush)] extension
/httpd_sendfile.L1 goto
}{ } ifelse
%% Get a file message. [(GET-file) fname] httpd_sendfile
msg 0 get (GET-file) eq {
httpd.root tag 5 eq not {
[(MSG) (<h1> File transfer is not allowed on this server. </h1>)]
httpd_sendfile
/httpd_sendfile.L1 /httpd_sendfile.L1 goto
} { } ifelse
msg length 1 eq {
/fname (index.html) def
}{
/fname msg 1 get def
(fname=) messagen fname (array) dc message
fname tag 5 eq not {
[(MSG) (<h1> Invalid file name. </h1>)]
httpd_sendfile
/httpd_sendfile.L1 /httpd_sendfile.L1 goto
} { } ifelse
fname (array) dc /fname set
fname length 1 lt {
/fname (index.html) (array) dc def
} { } ifelse
fname [47] eq {
/fname (index.html) (array) dc def
}{ } ifelse
fname 0 get 47 eq { %% /
/fname fname rest def
} { } ifelse
fname { (string) dc } map cat /fname set
} ifelse
/fname2 fname def
[httpd.root fname2] cat /fname set
[(fname=) fname] cat message
fname httpd.check_name {
[(MSG) (Warning: invalid file name.)] httpd_sendfile
/httpd_sendfile.L1 /httpd_sendfile.L1 goto
} { } ifelse
[(stat) fname] extension 0 get tag 0 eq {
[(MSG) (Warning (sendfile): the file ) fname2 ( is not found.) ]
httpd_sendfile
/httpd_sendfile.L1 /httpd_sendfile.L1 goto
}{ }ifelse
[(stat) fname] extension 1 get 0 get toString /fsize set
(HTTP/1.1 200 OK) sendln
(Server: httpd_sm1) sendln
%% (ETag: "2197-bf6c-3b2d6541") sendln ???
(Accept-Ranges: bytes) sendln
[(Content-Length: ) fsize] cat sendln
(Connection: close) sendln
[(Content-Type: ) fname httpd_type] cat sendln
[(flush)] extension
0 sendln
fname sendBinaryFile
0 sendln
[(flush)] extension
0 sendln
[(flush)] extension
/httpd_sendfile.L1 goto
}{
[(MSG) (Warning: unknown argument type for httpd_sendfile)]
httpd_sendfile
} ifelse
/httpd_sendfile.L1
] pop
popVariables
} def
/httpd_type {
/arg1 set
[/in-httpd_type /fname /ftype /i /ans] pushVariables
[
/fname arg1 def
fname getFileType /ftype set
/ans (text/plain) def % .txt, .jar,
ftype (gif) eq {
/ans (image/gif) def
}{ } ifelse
ftype (jpeg) eq ftype (jpg) eq or {
/ans (image/jpeg) def
}{ } ifelse
ftype (png) eq {
/ans (image/png) def
}{ } ifelse
ftype (png) eq {
/ans (image/png) def
}{ } ifelse
ftype (html) eq ftype (htm) eq or {
/ans (text/html) def
} { } ifelse
ftype (wav) eq {
/ans (audio/x-wav) def
} { } ifelse
ftype (class) eq {
/ans (application/octet-stream) def
} { } ifelse
/arg1 ans def
] pop
popVariables
arg1
} def
/httpd.check_name {
/arg1 set
[/in-httpd.check_name /fname /invalid] pushVariables
[
/fname arg1 def
/invalid 0 def
[(regionMatches) fname [(..) (/.)]] extension 0 get -1 eq
{
} {
(The file name contains .. or /. ) message
/invalid 1 def /httpd.check_name.L1 /httpd.check_name.L1 goto
} ifelse
fname length 0 eq {
(Warning: empty file name.)
/invalid 1 def /httpd.check_name.L1 /httpd.check_name.L1 goto
}{ } ifelse
fname (array) dc 0 get 47 eq {
}{
(Warning: The first letter is not /) message
/invalid 1 def /httpd.check_name.L1 /httpd.check_name.L1 goto
} ifelse
/httpd.check_name.L1
/arg1 invalid def
] pop
popVariables
arg1
} def
/httpd.startBrowserUnix {
/arg1 set
[/portnum /browser /cmd /fd /msg /htmlfn] pushVariables
[
arg1 /portnum set
portnum toString /portnum set
[(getenv) (OX_BROWSER)] extension /browser set
{
browser tag 0 eq {
[(ostype)] extension 1 get (mac) eq {
[(sleep 3 ; open http://localhost:) portnum ( & ) ] cat
/cmd set cmd message
}{
[(sleep 3 ; firefox http://localhost:) portnum ( & ) ] cat
/cmd set cmd message
}ifelse
cmd system
exit
}{ } ifelse
browser (mac) eq, browser (MAC) eq, or {
(.sm1.httpd.startBrowserUnix.html) /htmlfn set
htmlfn (w) file /fd set
fd tag 0 eq { (httpd.startBrowserUnix fails to open a file.) error }
{ } ifelse
[(<html><body>) nl
(<a href="http://localhost:) portnum (">)
(Click here to connect to the ox server)
(</a>) nl
(</body></html>) nl
] cat /msg set
fd msg writestring fd closefile
[(sleep 3 ; open ) htmlfn ( &) ] cat
/cmd set cmd message
cmd system
exit
}{ } ifelse
[(sleep 3 ; ) browser ( http://localhost:) portnum ( & ) ] cat
/cmd set cmd message
cmd system
exit
} loop
] pop
popVariables
} def![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to httpd.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc