#!/usr/bin/perl -w
#
# This sample Perl script limits the number of concurrent logins a user can
# create from the same location within certain time frame.
#
# Originator page: <http://www.stalker.com/CGRADIUS/>
# See also: <http://www.stalker.com/CommuniGatePro/RADIUS.html> 

use strict;
use Time::Local;

use CLI;  #get one from www.stalker.com/CGPerl/

###############

my $loginTimeFrame=60*2; #seconds

my $CLIAddress='127.0.0.1';
my $CLILogin='postmaster';
my $CLIPassword='pass';
my $doDebug=1;
###############

$| = 1;
print "* sample RADIUS helper script v1.02 started\n";

my $connTime=0;
my $cli;



while (<STDIN>) {
  chomp;
  my $cmdLine=$_;
  my ( $prefix, $command, @eargs ) = split (/ /);

  if ( $command eq 'LOGIN' ) {
    unless ( $prefix && $command && $cmdLine=~/({.*})\s+({.*})/ ) {
      print "$prefix ERROR Expected: nnn LOGIN user\@domain {attributes} {settings}\n";
    } else {      
      LoginCommand($prefix,$eargs[0],$1,$2);
    }
  }
  elsif ( $command eq 'ACCNT' ) {
    unless ( $prefix && $command && $cmdLine=~/(started|ended|updated) (\S+) ({.*})/ ) {
      print "$prefix ERROR Expected: nnn ACCNT command user\@domain {attributes}\n";
    } else {      
      AccntCommand($prefix,$1,$2,$3);
    }
  }
  elsif ( $command eq 'INTF' ) {
    print "$prefix INTF 1\n";
  }
  elsif ( $command eq 'QUIT' ) {
    print "$prefix OK\n";
    last;
  }
  else {
    print "$prefix ERROR Only LOGIN,ACCNT,INTF and QUIT commands supported\n";
  }
}
print "* sample RADIUS helper script v1.02 ended\n";
exit;


sub ReconnectCLI {
  if(time()>$connTime+4*60+30) {
    debugMsg("(re)Connecting to CLI");
    $cli=new CGP::CLI( {  PeerAddr => $CLIAddress,
                          PeerPort => 106,
                          login    => $CLILogin,
                          password => $CLIPassword,
                          Timeout => 2
                     } );
    unless($cli) { #trying again
      debugMsg("connection failed, re-connecting to CLI again");
      sleep(2); #wait for 2 seconds
      $cli=new CGP::CLI( {  PeerAddr => $CLIAddress,
                            PeerPort => 106,
                            login    => $CLILogin,
                            password => $CLIPassword,
                            Timeout => 2
                       } );
    }
    unless($cli) { #give up trying                
      die "Can't login to CGPro: ".$CGP::ERR_STRING."\n";
    }
  }
  $connTime=time();
  
}


sub LoginCommand {
  my ($prefix,$account,$attrDict,$settingsDict) = @_;

  ReconnectCLI();

  my $attr=$cli->parseWords($attrDict);
  my $settings=$cli->parseWords($settingsDict);

  if(ref($attr) ne 'HASH') {
    debugMsg("Error: attributes is not in dictionary format");
    print "$prefix REJECT was error\n";
    return;        
  };
  if(ref($settings) ne 'HASH') {
    debugMsg("Error: settings is not in dictionary format\n");
    print "$prefix REJECT was error\n";
    return;        
  };
  
  my $radConcurrent=@$settings{RADIUSConcurrent};
  if((!defined($radConcurrent))) { 
    debugMsg("no RADIUSConcurrent setting");
    $radConcurrent=1; 
  }
  my $nRecentLogins=0;
  
  my $sessions=$cli->GetAccountInfo($account,'RADIUSSESSIONS');
  unless($cli->isSuccess) {
    die "Error: GetAccountInfo failed:".$cli->getErrMessage.", quitting";
  }
  if(defined($sessions) && ref($sessions) eq 'HASH') {
    debugMsg("RADIUSSESSIONS data:");
    foreach(keys %$sessions) {
      my $key=$_;
      my $item=@$sessions{$_};
      if(ref($item) eq 'HASH') {
        debugMsg(" $key: $_ = @$item{$_}") foreach(keys %$item);
        my $when=@$item{'when'};
        if(defined($when)) {
          if((Date2Secs($when)+$loginTimeFrame) > time()) {
            $nRecentLogins++;
          }
        }

      }
    }
    debugMsg("$nRecentLogins recent logins");
  } else {
    debugMsg("no RADIUSSESSIONS info");
  }  
  
  if($nRecentLogins > $radConcurrent) {
    print "$prefix REJECT\n";
    return;
  }
  
  my $framedIP=@$settings{FramedIPAddress};
  if((!defined($framedIP))) { 
    debugMsg("no FramedIPAddress setting");
  }

  if(defined($framedIP)) {
    print "$prefix ACCEPT {8=$framedIP;}\n";
  } else {
    print "$prefix ACCEPT {}\n";
  }
  return;        

}


sub AccntCommand {
  my ($prefix,$command,$account,$attrDict) = @_;

  ReconnectCLI();

  my $attr=$cli->parseWords($attrDict);
  if(ref($attr) ne 'HASH') {
    debugMsg("Error: attributes is not in dictionary format");
    print "$prefix REJECT was error\n";
    return;        
  };
  
  foreach (keys %$attr) {
     debugMsg(" $_ = \"@$attr{$_}\"");
  }


  #LockAccoount($account);
  my $sessions=$cli->GetAccountInfo($account,'RADIUSSESSIONS');
  unless($cli->isSuccess) {
    die "Error: GetAccountInfo failed:".$cli->getErrMessage.", quitting";
  }
  
  if(defined($sessions) && ref($sessions) eq 'HASH') {
    debugMsg("RADIUSSESSIONS data:");
    foreach(keys %$sessions) {
      my $key=$_;
      my $item=@$sessions{$_};
      if(ref($item) eq 'HASH') {
        debugMsg("$key: $_ = @$item{$_}") foreach(keys %$item);
        my $when=@$item{'when'};
        if(defined($when)) {
          if((Date2Secs($when)+$loginTimeFrame) < time()) {
            delete @$sessions{$key};
            debugMsg("deleting old entry");
          }
        }
      }
    }
  } else {
    debugMsg("no RADIUSSESSIONS info");
    $sessions={};
  }  
  my $newKey="";
  my $elem;

  $elem=@$attr{'4'};
  $elem="" unless(defined($elem) && !ref($elem));
  $newKey.=$elem . '-';
  $elem=@$attr{'5'};
  $elem="" unless(defined($elem) && !ref($elem));
  $newKey.=$elem . '-';
  $elem=@$attr{'61'};
  $elem="" unless(defined($elem) && !ref($elem));
  $newKey.=$elem . '-';
  $elem=@$attr{'32'};
  $elem="" unless(defined($elem) && !ref($elem));
  $newKey.=$elem;

  if($command eq 'ended') {
    delete @$sessions{$newKey};
  } else {
    @$sessions{$newKey}={when => Secs2Date(time()),};
  }
  #$cli->UpdateAccountInfo($account,{RADIUSSESSIONS=>$sessions});
  $cli->SendCommand("UpdateAccountInfo $account ".$cli->printWords({RADIUSSESSIONS=>$sessions})); 
  #UnlockAccount($account);

  print "$prefix OK\n";
  return;        

}


sub Date2Secs {
  my ($year,$month,$day,$hour,$min,$sec);
  if($_[0] =~ /^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/) {
    ($year,$month,$day,$hour,$min,$sec) = ($1,$2,$3,$4,$5,$6);
  } else {
   die "Unknown date format: \"$_[0]\", quitting";
  }
   return timegm($sec,$min,$hour,$day,$month-1,$year-1900);
}

sub Secs2Date {
  my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =  gmtime($_[0]);
  return sprintf("%04d%02d%02d%02d%02d%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec);
}

sub debugMsg {
   my $msg=$_[0];
   print "* $msg\n" if($doDebug);
}

__END__;