@program weblogin.htmuf
1 1000 d
i
$include $lib/cgiparse
$include $lib/alynna
$include $muf/cron
$def astr dup int? if dup not if pop "" then then
$def myip descr descripnum
$def myref "target" getwebuser dup not if pop #-1 then
$def myname "name" getwebuser dup not if pop "" then
$pubdef myip descr descripnum
$pubdef myref "target" getwebuser dup not if pop #-1 then
$pubdef myname "name" getwebuser dup not if pop "" then
$pubdef astr dup int? if dup not if pop "" then then
$def verbose prog "MOBILE" flag? if logstatus else pop then
INCLUDE_WEBVARS
lvar cmd
lvar param

: setwebuser[ value str:prop -- ]
WWW { "/~login/" myip "/" prop @ }cat value @ setprop
; PUBLIC setwebuser
$libdef setwebuser

: getwebuser[ str:prop -- ]
WWW { "/~login/" myip "/" prop @ }cat getprop
; PUBLIC getwebuser
$libdef getwebuser

: setstat[ value str:prop -- ]
myref prop @ value @ setprop
; PUBLIC setstat
$libdef setstat

: getstat[ str:prop -- ]
myref prop @ getprop
; PUBLIC getstat
$libdef getstat

: sys.reg
WWW { "/~login/" myip "/referrer" }cat "Referer" head setprop
{ "<H1>" "Host" head " register: </H1>" }w
{ "<FORM ACTION='http://" "host" head wpath @ "?regauth' METHOD='POST' NAME='YERF'>" }w
{ "<center><table rows=3 cols=1 border=0><tr><td align=left>" }w
{ "<CODE>Username: <input name='username' type='input' size=32 maxlength=128><code>" }w
{ "</td></tr><tr><td align=left>" }w
{ "<CODE>Password: <input name='password' type='password' size=32 maxlength=128><code>" }w
{ "</td></tr><tr><td align=right>" }w
{ "<CODE>Email: <input name='email' type='input' size=32 maxlength=128><code>" }w
{ "</td></tr><tr><td align=right>" }w
{ "<INPUT TYPE='SUBMIT' SIZE=320 VALUE='Register' NAME='SUBMIT'>" }w
{ "</td></tr></table>" }w
{ "</FORM></CENTER>" }w
;

: sys.regauth
"Username" post var! username
"Password" post var! password
"Email"    post var! email
var target
username @ not password @ not email @ not or or if 
 { "<H2><font color=YELLOW>A field was left empty.</font></H2>" }w 
 { "<right><a href='/weblogin?register'>Try it again...</a></right>" }w 
 exit then
username @ pname-ok? not if 
 { "<H2><font color=YELLOW>The username was invalid or taken.</font></H2>" }w 
 { "<right><a href='/weblogin?register'>Try it again...</a></right>" }w 
 { "WWW(Regauth): Username invalid '" username @ "'" }cat verbose
 exit then
email @ "*@*.*" smatch not if 
 { "<H2><font color=YELLOW>The email address was invalid.</font></H2>" }w 
 { "<right><a href='/weblogin?register'>Try it again...</a></right>" }w 
 { "WWW(Regauth): Email invalid '" username @ " " email @ "'" }cat verbose
 exit then
#-1 "*" "P" find_array "@/RegAddr" myip array_filter_prop array_count if 
 { "<H2><font color=YELLOW>Register failure: You have already registered a character.</font></H2>" }w 
 { "<right><a href='/weblogin?register'>Try it again...</a></right>" }w 
 { "WWW(Regauth): Already requested (IP match) '" username @ "'" }cat verbose
 exit then
#-1 "*" "P" find_array "@/RegEmail" email @ array_filter_prop array_count if 
 { "<H2><font color=YELLOW>Register failure: You have already registered a character.</font></H2>" }w 
 { "<right><a href='/weblogin?register'>Try it again...</a></right>" }w 
 { "WWW(Regauth): Already requested (email match) '" username @ "'" }cat verbose
 exit then
username @ password @ newplayer target !
WWW { "/~login/" myip "/name" }cat target @ name setprop
WWW { "/~login/" myip "/target" }cat target @ setprop
WWW { "/~login/" myip "/access" }cat systime setprop
target @ "@/regAddr" myip setprop
target @ "@/regEmail" email @ setprop
    { "<H2><font color=#00CC00>Registration and login successful.</font></H2>" }w 
    { "<right><a href='" 
      WWW { "/~login/" myip "/referrer" }cat getprop dup not if pop "/" then 
      "'>Continue...</a></right>" }w 
    { "WWW(Sysauth): User created and access granted '" username @ "'" }cat logstatus
;

: sys.login
WWW { "/~login/" myip "/referer" }cat "referrer" head setprop
{ "<H1>" "Host" head " login: </H1>" }w
{ "<FORM ACTION='http://" "host" head wpath @ "?auth' METHOD='POST' NAME='YERF'>" }w
{ "<center><table rows=3 cols=1 border=0><tr><td align=left>" }w
{ "<CODE>Username: <input name='username' type='input' size=32 maxlength=128><code>" }w
{ "</td></tr><tr><td align=left>" }w
{ "<CODE>Password: <input name='password' type='password' size=32 maxlength=128><code>" }w
{ "</td></tr><tr><td align=right>" }w
{ "Remember me <input name='remember' type='checkbox'>" }w
{ "<INPUT TYPE='SUBMIT' SIZE=320 VALUE='Login' NAME='SUBMIT'>" }w
{ "</td></tr></table>" }w
{ "</FORM></CENTER>" }w
;

: sys.auth
"Username" post var! username
"Password" post var! password
"Remember" raw  var! remember
var target
username @ resolve target !
username @ pname-ok? if 
 { "<H2><font color=YELLOW>The username was invalid.</font></H2>" }w 
 { "<right><a href='/weblogin?login'>Try it again...</a>" }w 
 { "WWW(Regauth): Username invalid '" username @ "'" }cat verbose
 exit then
target @ int 0 < if 
 { "<H2><font color=YELLOW>Login failure: Object not found</font></H2>" }w 
 { "<right><a href='/weblogin?login'>Try it again...</a></right>" }w 
 { "WWW(Sysauth): Object not found '" username @ "'" }cat verbose
 exit then
target @ password @ checkpassword not if
 { "<H2><font color=#0000CC>Permission Denied</font></H2>" }w 
 { "<right><a href='/weblogin?login'>Try it again...</a></right>" }w 
 { "WWW(Sysauth): Permission denied '" username @ "'" }cat logstatus
 exit then
WWW { "/~login/" myip "/name" }cat target @ name setprop
WWW { "/~login/" myip "/target" }cat target @ setprop
remember @ if 
  WWW { "/~login/" myip "/remember" }cat 1 setprop 
 else
  WWW { "/~login/" myip "/remember" }cat 0 setprop 
 then
WWW { "/~login/" myip "/access" }cat systime setprop
    { "<H2><font color=#00CC00>Login successful.</font></H2>" }w 
    { "<right><a href='" 
      WWW { "/~login/" myip "/referrer" }cat getprop dup not if pop "/" then 
      "'>Continue...</a></right>" }w 
    { "WWW(Sysauth): Access granted '" username @ "'" }cat logstatus
;

: sys.logout
WWW { "/~login/" myip "/" }cat remove_prop
    { "<H2><font color=#00C000>Logout successful.</font></H2>" }w 
    { "<right><a href='/'>Return to home page...</a></right>" }w 
    { "WWW(Sysauth): logout '" myip "'" }cat logstatus
;

: sys.ping
WWW { "/~login/" myip "/access" }cat systime setprop
WWW { "/~login/" myip "/path" }cat wpath @ setprop
WWW { "/~login/" myip "/referrer" }cat "referer" head dup not if pop "/" then setprop
{ "PING: " myip " accessed path " wpath @ }cat logstatus
;

: sys.cron
var xp
var ip
{ "CRON: Start login CRON" }cat verbose
WWW "/_prefs/loginexpire" getpropval xp !
 xp @ not if 900 xp ! then
{ "CRON: expiry time is " xp @ }cat verbose
WWW "/~login/" array_get_propdirs foreach ip ! pop
 WWW { "/~login/" ip @ "/remember" }join getprop not if
  systime WWW { "/~login/" ip @ "/access" }join getpropval - xp @ > if
   WWW { "/~login/" ip @ "/" }join remove_prop
   { "CRON: " ip @ " is EXPIREDed " }cat verbose
  else
   { "CRON: " ip @ " is CURRENT " }cat verbose
  then
 else
  { "CRON: " ip @ " is REMEMBERed " }cat verbose
 then
repeat
;

: main
dup mufcron? if pop sys.cron exit then
" " split param ! cmd !
PARSE_HEADERS
command @ "*mpi*" smatch if 
 cmd @ case
  "ping" smatch when sys.ping "" end
  "get" smatch when param @ getwebuser astr end
  "set" smatch when param @ ":" split swap setwebuser 
                    param @ ":" split pop getwebuser astr end
  "uget" smatch when param @ getstat astr end
  "uset" smatch when param @ ":" split swap setstat
                    param @ ":" split pop getstat astr end
  "myip" smatch when myip end
  "myref" smatch when myref dtos end
  "myname" smatch when myname end
 endcase
exit
then
{ WWW "_/www/header" mpilist }w
wparam @ tolower case
 "login" smatch when sys.login end
 "auth" smatch when sys.auth end
 "ping" smatch when sys.ping end
 "register" smatch when sys.reg end
 "regauth" smatch when sys.regauth end
 "logout" smatch when sys.logout end 
endcase 
{ WWW "_/www/footer" mpilist }w
;
.
c
q
@reg weblogin=web/login
@set #0=_msgmacs/ping:{muf:$web/login,ping}
@set #0=_msgmacs/wget:{muf:$web/login,get {:1}}
@set #0=_msgmacs/wset:{muf:$web/login,set {:1}:{:2}}
@set #0=_msgmacs/uget:{muf:$web/login,uget {:1}}
@set #0=_msgmacs/uset:{muf:$web/login,uset {:1}:{:2}}
@set #0=_msgmacs/myip:{muf:$web/login,myip}
@set #0=_msgmacs/myref:{muf:$web/login,myref}
@set #0=_msgmacs/myname:{muf:$web/login,myname}