#!/usr/bin/perl
#
# webface - web interface for xs26.net
#
# (c) pasky 2001
#
# cgi script
#
BEGIN {
require CGI;
use HTML::Template;
}
## defines
@reqs=qw(uaddp zaddp ulsp zlsp uchgp zchgp udelp zdelp dummy);
$WEBROOT="/home/pasky/WWW/design/xs26.net";
$DOCROOT="/home/pasky/WWW/design/xs26.net/site";
@usr_data =[
{name=>'Login', type=>'text', desc=>'Your login name', intype=>'id'},
{name=>'Password', type=>'password', desc=>'Your password'},
{name=>'Contact1', type=>'text', desc=>'', span=>2},
{name=>'Contact2', type=>'text', desc=>'', span=>2},
{name=>'Contact3', type=>'text', desc=>'', span=>2},
{name=>'NIC handle', type=>'text', desc=>'Your 6BONE NIC handle', id=>'nic_handle', intype=>'v6nic'},
{name=>'Maintainer', type=>'text', desc=>'Your 6BONE NIC mnter handle (if you have any)', id=>'mnter', intype=>'nic', noneed=>1},
{name=>'E-mail', type=>'text', desc=>'Your e-mail', id=>'email', intype=>'email'},
{name=>'Notify', type=>'text', desc=>'E-mail, where to send notifies about updates', id=>'notify_to', intype=>'email', noneed=>1},
];
@zne_data =[
{name=>'Main prefix', type=>'ls', list=>[{n=>'3ffe:80ee::/32'}], desc=>'Prefix of user zones area', id=>'main_prefix', intype=>'v6xs', nochange=>1},
{name=>'Zone #', type=>'text', desc=>'Your zone number', id=>'number_of_prefix', intype=>'v6seg', nochange=>1, pre=>'N/A'},
{name=>'Prefix length', type=>'ls', list=>[{n=>'64'},{n=>'60'},{n=>'48'}], desc=>'Size of your zone', id=>'prefixlen', intype=>'v6prelen'},
{name=>'Owner', type=>'text', desc=>'Your loginname', intype=>'id'},
{name=>'Password', type=>'password', desc=>'Your password'},
{name=>'NIC handle', type=>'text', desc=>'You can override owner\'s one', id=>'nic_handle', intype=>'v6nic', noneed=>1},
{name=>'Maintainer', type=>'text', desc=>'You can override owner\'s one', id=>'mnter', intype=>'nic', noneed=>1},
{name=>'', type=>'', desc=>'You can provide DNS servers for reverse zone managment.', span=>3},
{name=>'NS1', type=>'text', desc=>'', span=>2, noneed=>1, intype=>'addr'},
{name=>'NS2', type=>'text', desc=>'', span=>2, noneed=>1, intype=>'addr'},
{name=>'NS3', type=>'text', desc=>'', span=>2, noneed=>1, intype=>'addr'},
{name=>'', type=>'hidden', desc=>'', id=>'create_time', own=>1, skip=>1},
{name=>'', type=>'hidden', desc=>'', id=>'last_success_ping', own=>1, skip=>1},
{name=>'', type=>'', desc=>'You need to have at least one tunnel, but you can use up to five ones. Traffic will be routed through the shortest way. PoP is specified in the format -, e.g. sk-01.', span=>3},
{name=>' ', type=>'', desc=>'', superspan=>1, subtable=>1, span=>2},
{name=>'PoP', type=>'text', desc=>'', id=>'pop1', intype=>'pop', subspan=>1, superspan=>1},
{name=>'#', type=>'text', desc=>'', id=>'no1', intype=>'v6seg', subspan=>1},
{name=>'', type=>'', desc=>'', superspan=>1},
{name=>'PoP', type=>'text', desc=>'', id=>'pop2', intype=>'pop', subspan=>1, superspan=>1},
{name=>'#', type=>'text', desc=>'', id=>'no2', intype=>'v6seg', subspan=>1},
{name=>'', type=>'', desc=>'', superspan=>1},
{name=>'PoP', type=>'text', desc=>'', id=>'pop3', intype=>'pop', subspan=>1, superspan=>1},
{name=>'#', type=>'text', desc=>'', id=>'no3', intype=>'v6seg', subspan=>1},
{name=>'', type=>'', desc=>'', superspan=>1},
{name=>'PoP', type=>'text', desc=>'', id=>'pop4', intype=>'pop', subspan=>1, superspan=>1},
{name=>'#', type=>'text', desc=>'', id=>'no4', intype=>'v6seg', subspan=>1},
{name=>'', type=>'', desc=>'', superspan=>1},
{name=>'PoP', type=>'text', desc=>'', id=>'pop5', intype=>'pop', subspan=>1, superspan=>1},
{name=>'#', type=>'text', desc=>'', id=>'no5', intype=>'v6seg', subspan=>1, supertable=>1},
];
@ints=qw(txt pop id email nic v6nic v6xs v6seg v6prelen addr);
## init
$q=new CGI;
# which template?
$templ=$q->param('templ') or $templ=$q->cookie('templ') or $templ="default";
# make new template cookie
$tc=$q->cookie(-name=>'templ', -value=>$templ, -expires=>'+1y');
# load request
$request=substr($ENV{"PATH_INFO"},1);
if (!$request) { $request="index"; }
## main scope
if (!(member($request, @reqs)+1)) {
$tmp=load_content($request=~/\.html$/?$request:$request.".html");
build_page("", $tmp->output);
} else {
eval("proc_$request();");
}
################################################################################
## requests
####
## dummy
sub proc_dummy {
build_page("Dummy", "Yyiikes! I'm just an internal dummy request! *bubble* *bubble* #IPv6 ;-)");
}
################################################################################
## support
####
## build page around $2 with title $1, forced w/o template if $3
sub build_page {
my($content, $title, $sp, $tmp);
$title=$_[0]; $content=$_[1];
if ($_[2]) {
if ($title) { $sp=" - "; }
print $q->header(-type=>"text/html");
print "XS26.net$sp$title\n";
print "
\n";
print "XS26.net
\n$title
\n";
print mails2dot($content),"\n";
print "(c) pasky\n";
print "<",mail2dot("pasky\@xs26.net"),">\n";
print "2001
\n\n";
} else {
error_404("$templ.tmpl") unless (-e "$WEBROOT/templates/$templ.tmpl" or -e "$DOCROOT/templates/$templ.tmpl");
$tmp=HTML::Template->new(filename=>$templ.".tmpl", path=>["$WEBROOT/templates", "$DOCROOT/templates"],
search_path_on_inclue=>1, associate=>$q,
file_cache=>1, file_cache_dir=>'/tmp',
die_on_bad_params=>0);
$tmp->param(__template=>$templ, __request=>$request, __title=>$title, __content=>$content, __referer=>$q->referer());
$sp=mails2dot($tmp->output);
print $q->header(-type=>"text/html",-cookie=>$tc), $sp;
}
}
## convert e-mail to anti-spam notation
sub mails2dot {
my($c)=$_[0];
$c=~s/([-.a-zA-Z0-9!]+\@[-.a-zA-z0-9]+)/mail2dot($1)/ge;
return $c;
}
sub mail2dot {
my($mail);
$mail=$_[0];
#print $mail,", ";
if ($mail=~s/^!//) { return $mail; }
$mail=~s/!/ in /g;
$mail=~s/\@/ at /g;
$mail=~s/\./ dot /g;
#print $mail,"!\n";
return $mail;
}
## load content from a file
sub load_content {
my($file, $tmp, $F);
$file=$_[0];
error_404("$file") unless (-e "$WEBROOT/site/$file" or -e "$DOCROOT/site/$file" or
-e "$WEBROOT/$file" or -e "$DOCROOT/$file");
if (!($tmp=HTML::Template->new(filename=>$file, path=>["$DOCROOT", "$WEBROOT", "$WEBROOT/site", "$DOCROOT/site"],
search_path_on_inclue=>1, associate=>$q,
file_cache=>1, file_cache_dir=>'/tmp',
die_on_bad_params=>0))) {
}
$tmp->param(__template=>$templ, __request=>$request, __referer=>$q->referer(), "__template-$templ"=>1,
usr_data=>@usr_data, zne_data=>@zne_data);
return $tmp;
}
## make error 404
sub error_404 {
my $file=$_[0];
build_page("404 Page not found", "Error - $file not found
" . <We are sorry, but you requested file which is not
available. Please check the URL, and if this page resulted from some
link on this site, contact us at webmaster\@xs26.net.
Try to find the informations you wanted at the main page.
page_end
, 1);
die "404";
}
=xx=============================================================================
= =
=inspiration =
= =
================================================================================
=cu
#
############### INFO
#
if ($parametry{"info"})
{
$name=$parametry{"name"};
if ($name =~ /[\W]/) { print "Content-type: text/plain\n\nBylo zadáno špatné jméno. Zkuste to znovu, prosím.\n"; exit; }
tie (%maindb, "DB_File", "$dbfile") or die "Banner-system (banners.pl): Cannot open db file $dbfile.db! (fatal)\n";
if ($parametry{"gw"})
{ if ($name) {
@data=split(/|/, $maindb{$name}); # 0 = heslo; 1 = banner; 2 = odkaz; 3 = impresí CyberSpace; 4 = impresí banneru; 5 = kampaň?
$parametry{location}=$data[1];
$parametry{anchor}=$data[2];
$parametry{campaign}=$data[5];
}
print "Content-type: text/html\n\nBANNERS | INFO | GATEWAY";
print "";
exit;
}
$secret=$parametry{"secret"};
if (!$name) { print "Content-type: text/plain\n\nBylo zadáno špatné jméno. Zkuste to znovu, prosím.\n"; exit; }
# INFO o existujicim
if (defined $parametry{"camp"}) { $parametry{"camp"}=1; }
if ($maindb{$name}) {
@data=split(/|/, $maindb{$name}); # 0=heslo; 1=banner; 2=odkaz; 3=impresí CyberSpace; 4=impresí banneru; 5=skóre; 6=kampaň
if ($parametry{"set"}) {
if (!$secret) { print "Content-type: text/plain\n\nNebylo zadáno heslo. Zkuste to znovu, prosím.\n"; exit; }
if ($data[0] ne $secret) { print "Conent-type: text/plain\n\nBylo zadáno špatné heslo. Nezkoušejte to znovu, prosím.\n"; exit; }
if ($parametry{"secret_new"} =~ /|/) { print "Content-type: text/plain\n\nBylo zadáno heslo obsahující nepovolené znaky. Zkuste to znovu, prosím.\n"; exit; }
if ($parametry{"secret_new"}) { $data[0]=$parametry{"secret_new"}; }
$data[1]=$parametry{"location"};
$data[2]=$parametry{"anchor"};
$data[6]=$parametry{"camp"};
$maindb{$name}=join("|", @data);
}
# Vytvoreni noveho
} else {
if (!$secret) { print "Content-type: text/plain\n\nNebylo zadáno heslo. Zkuste to znovu, prosím.\n"; exit; }
if ($secret =~ /|/) { print "Content-type: text/plain\n\nBylo zadáno heslo obsahující nepovolené znaky. Zkuste to znovu, prosím.\n"; exit; }
$data[0]=$parametry{"secret"};
$data[1]=$parametry{"location"};
$data[2]=$parametry{"anchor"};
$data[3]=0;
$data[4]=0;
$data[5]=0;
$data[6]=$parametry{"camp"};
$maindb{$name}=join("|", @data);
}
print "Content-type: text/html\n\nBANNERS | INFO | $name";
print "Target: $name
Počet impresí CyberSpace banneru na stránkách uživatele: $data[3]
Počet impresí uživatelova banneru: $data[4]
Skóre (počet 'volných' zobrazení): $data[5]
";
if ($data[6]) { print "Kampaň probíhá."; } else { print "Kampaň neprobíhá."; }
print "";
untie %maindb;
exit;
}
#
############### IMAGE
#
if ($parametry{"banner"}) {
$name=$parametry{"name"};
if (!$name) { print "Content-type: text/plain\n\nNebylo zadáno jméno - nevím na čí účet to přesměrovat.\n"; exit; }
if ($name =~ /[\W]/) { print "Content-type: text/plain\n\nBylo zadáno špatné jméno. Zkuste to znovu, prosím.\n"; exit; }
tie (%maindb, "DB_File", "$dbfile") or die "Banner-system (banners.pl): Cannot open db file $dbfile.db! (fatal)\n";
@data=split(/|/, $maindb{$name}); # 0=heslo; 1=banner; 2=odkaz; 3=impresí CyberSpace; 4=impresí banneru; 5=skóre; 6=kampaň
# sude skore - CS banner
if (! $data[5]%2) {
print "Set-Cookie: CB_REDIR=http://matrix.cyberspace.cz/\n";
$random=rand $banners;
print "Location: $csbloc$csbpfx$random$csbsfx\n\n";
$data[5]++;
$data[3]++;
# liche skore - user banner
} else {
# sken databaze - vybirame si banner
@keys=keys %maindb;
$poc=0;
do {
$random=rand @keys;
@xdata=split(/|/, $maindb{$keys[$random]}); # 0=heslo; 1=banner; 2=odkaz; 3=impresí CyberSpace; 4=impresí banneru; 5=skóre; 6=kampaň
$poc++;
} until ($keys[$random] ne $name && $xdata[5] && $xdata[6] || $poc == $keys*2);
if ($poc == $keys*2) { # this is so ugly... you don't know subroutines, don't you, my second half?
print "Set-Cookie: CB_REDIR=http://matrix.cyberspace.cz/\n";
$random=rand $banners;
print "Location: $csbloc$csbpfx$random$csbsfx\n\n";
$data[5]++;
$data[3]++;
} else {
print "Set-Cookie: CB_REDIR=$xdata[2]\n";
print "Location: $xdata[1]\n\n";
$xdata[5]--;
$xdata[4]++;
$maindb{$keys[$random]}=join("|",@xdata);
}
}
$maindb{$name}=join("|",@data);
untie %maindb;
exit;
}
#
############### LINK
# Dis's done
# primitively
# in order to
# don't have
# to open
# whole db once
# more time.
#
if ($parametry{"link"}) {
$cookie=$query->cookie(-name=>'CB_REDIR');
print "Location: $cookie\n\n";
exit;
}
print "Location: banners.pl?info\&gw\n\n";
=censored-stuff_for_KPB_:-)
$dino=$ENV{"PATH_INFO"};
@inout=split(/\//, $dino);
if ("$inout[1]" =!~ /^[\w_-]+$/ or "$inout[2]" =!~ /^[\w_-]+$/ )
{ $query->redirect('./misused.html'); exit; }
############### KICK OUT
print , "Transaction ", $inout[1], "->", $inout[2], "\n";
@cookies=split(/; /, $ENV{"HTTP_COOKIE"});
%cookies=split(/=/, join("=", @cookies)); # uurgh?!?
############### KICK OUT
foreach $klic (keys %cookies) {print , "$cookies{$klic} -> $klic\n"}
open (, ">>$LOGFILE") or die "KPB (backbone.pl): Cannot open log file $LOGFILE! (fatal)\n";
print , time, " - Attemp to open transaction $inout[1] -> $inout[2]\n";
tie (%plugdb, "DB_File", "$dbpath$inout[1]")
or print (, time, " - Open of source db failed, dying...\n")
and die "KPB (backbone.pl): Cannot open db file $dbpath$inout[1].db! (fatal)\n";
if ($plugdb{isvalid} ne "it is")
{ print , time, " - Unknown source plugin, dying...\n"; die "KPB (backbone.pl): Unknown source plugin $inout[1]! (fatal)\n"; }
untie(%plugdb);
if ($inout[2] =~ /logout_[\w_]{3-}/) # we've 2 logout it
{ &receive_auth; &open_ssidb; $ssidb{$AUTH_SSID}=undef; untie(%ssidb);
CGI::redirect("http://matrix.cyberspace.cz/node/comlink.zone?jmeno=$AUTH_UNAME\&proxy=\&kam=LOGOUT"); exit; }
tie (%plugdb, "DB_File", "$dbpath$inout[2]")
or print (, time, " - Open of destination db failed, dying...\n")
and die "KPB (backbone.pl): Cannot open db file $dbpath$inout[2].db! (fatal)\n";
if ($plugdb{isvalid} ne "it is")
{ print , time, " - Unknown dest plugin, dying...\n"; die "KPB (backbone.pl): Unknown dest plugin $inout[2]! (fatal)\n"; }
############### KICK OUT
=cut
sub member {
my($pos, $f);
$f=shift;
for ($pos=0; $pos<@_; $pos++) { if (uc( $_[$pos] )eq uc $f) { return $pos; } }
return -1;
}