check_reply.pl

my $blackListFilename = "/etc/radiator/blacklist";
my %blacklist;
if (open(BLACKLIST, "<$blackListFilename")) {
  %blacklist = map {$_ => 1} map {$_ =~ s/\s+$//s; $_} <BLACKLIST>;
  close(BLACKLIST);
} else {
  &main::log($main::LOG_DEBUG, "Can't read \"$blackListFilename\": $!");
  &main::log($main::LOG_DEBUG, "Assuming that nobody is blacklisted.");
};

my @stripAttrs = ('Class',
                  'Cisco-AVPair',
                  'cisco-avpair',
                  'Tunnel-Type',
                  'Tunnel-Medium-Type');

my $testAccountID      = 'Tunnel-Private-Group-ID';
my $testAccountIDValue = '1:666';

sub isBlacklisted {
  my $username = shift;

  return $blacklist{$username};
}

sub stripAttrs {
  my $p = shift;
  my @stripAttrs = @_;

  foreach my $attr (@stripAttrs) {
    if (defined($p->get_attr($attr))) {
      &main::log($main::LOG_DEBUG,
                 'Removing prohibited attr '.$attr.' from reply.');
      $p->delete_attr($attr);
    };
  };
};

sub {
  my $replyFromProxy  = ${$_[0]};
  my $replyToNAS      = ${$_[1]};
  my $originalRequest = ${$_[2]};
  my $sentToProxy     = ${$_[3]};
  my $host            =   $_[4];

  if ($replyFromProxy->code eq 'Access-Accept') {
    # Zkontrolovat, jestli uzivatel neni na blacklistu.
    if (isBlacklisted($replyFromProxy->get_attr('User-Name'))) {
      &main::log($main::LOG_DEBUG,
                 $replyFromProxy->get_attr('User-Name').
                 ' is blacklisted rewriting to Access-Reject!');

      $replyFromProxy->set_code('Access-Reject');
      stripAttrs($replyToNAS, @stripAttrs, $testAccountID);

      return ;
    }; # ----------------------------------------------------------------------

    # Mrknout, jestli se jedna o testovaci ucet.
    my $attrVal = $replyFromProxy->get_attr($testAccountID);

    if ($attrVal eq $testAccountIDValue) {
      &main::log($main::LOG_DEBUG, "This is a testing account!");
    } else {
      stripAttrs($replyToNAS, $testAccountID);
    }; # ----------------------------------------------------------------------

    # Odstranit atributy, ktery by mohly zmast nase APcka.
    stripAttrs($replyToNAS, @stripAttrs);
  };