#!/usr/bin/perl
#
# webface - web interface for xs26.net
#
# (c) pasky <pasky@ji.cz> 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 <country>-<pop_id>, 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 "<html><head><title>XS26.net$sp$title</title></head>\n";
    print "<body bgcolor=\"#ffffff\"><p align=\"center\"><hr align=\"center\"></hr>\n";
    print "<h2 align=\"center\">XS26.net</h1><br />\n<h1 align=\"center\">$title</h1><hr align=\"center\"></hr></p>\n";
    print mails2dot($content),"\n";
    print "<p align=\"center\"><small>(c) pasky\n";
    print "<a href=\"mailto:",mail2dot("pasky\@xs26.net"),"\">&lt;",mail2dot("pasky\@xs26.net"),"&gt;</a>\n";
    print "2001</small></p>\n</body></html>\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", "<p><h1 align=\"center\">Error - $file not found</h1></p>" . <<page_end
<p align="center">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 <a href="mailto:webmaster\@xs26.net">webmaster\@xs26.net</a>.
Try to find the informations you wanted at <a href="/s/">the main page</a>.</p>
<hr align="center"></hr>
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\n<html><head><title>BANNERS | INFO | GATEWAY</title></head><body bgcolor=black text=green>";
    print "<form action=\"banners.pl\" method=post>";
    print "Jméno uživatele - písmena, číslice, podtržítko: <input maxlength=24 type=text name=name value=$parametry{name}><br>\n";
    print "<table border=1><tr><td><input type=checkbox name=set value=0> Změnit nastavení<br>";
    print "Umístění vlastního banneru (http://.../...): <input type=text name=location value=$parametry{location}><br>\n";
    print "Odkaz na stránku (http://.../...): <input type=text name=anchor value=$parametry{anchor}><br>\n";
    print "Heslo: <input type=text name=secret> <i>Nové heslo: </i><input type=text name=secret_new> (heslo nesmí obsahovat znak |)<br>\n";
    print "<input type=checkbox name=camp value=$parametry{camp}> Reklamní kampaň? (vypnuto=jen si tiše šetřit imprese; zapnuto=zobrazovat moje bannery)";
    print "</td></tr></table><br><input type=submit name=info value=SEND></form></body></html>";
    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\n<html><head><title>BANNERS | INFO | $name</title></head><body bgcolor=black text=green>";
  print "<center>Target: <b>$name</b></center><br><a href=\"$data[2]\"><img src=\"$data[1]\" alt=\"Banner - $data[1] - odkaz na $data[2]\"></a><br>Počet impresí CyberSpace banneru na stránkách uživatele: <b>$data[3]</b><br>Počet impresí uživatelova banneru: <b>$data[4]</b><br>Skóre (počet 'volných' zobrazení): <b>$data[5]</b><br>";
  if ($data[6]) { print "Kampaň <b>probíhá</b>."; } else { print "Kampaň <b>neprobíhá</b>."; }
  print "</body></html>";

  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 <STDERR>, "Transaction ", $inout[1], "->", $inout[2], "\n";

@cookies=split(/; /, $ENV{"HTTP_COOKIE"});
%cookies=split(/=/, join("=", @cookies)); # uurgh?!?

############### KICK OUT
foreach $klic (keys %cookies) {print <STDERR>, "$cookies{$klic} -> $klic\n"}

open (<LOG>, ">>$LOGFILE") or die "KPB (backbone.pl): Cannot open log file $LOGFILE! (fatal)\n";
print <LOG>, time, " - Attemp to open transaction $inout[1] -> $inout[2]\n";

tie (%plugdb, "DB_File", "$dbpath$inout[1]")
  or print (<LOG>, 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 <LOG>, 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 (<LOG>, 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 <LOG>, 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;
}