#!/usr/bin/perl

=head1 NAME

coa-server.pl

=head1 DESCRIPTION

Modified version of example-yes.pl taken from
https://metacpan.org/source/LUISMUNOZ/Net-Radius-2.103/examples/example-yes.pl

This is a VERY simple RADIUS CoA server which responds with some of the data
in the request. It was built to do load testing and to validate that we can
use the CoA code in a multithreaded context without issues.

=cut
 
use warnings;
use strict;

use Fcntl;
use Net::Radius::Dictionary;
use Net::Radius::Packet;
use Net::UDP;
use lib qw(/usr/local/pf/lib /usr/local/pf/lib_perl/lib/perl5);
use pf::util::radius_dictionary ($RADIUS_DICTIONARY);

my $secret = "qwerty";  # Shared secret on the term server. This seems to be ignored actually.
 
# Set up the network socket (must have radius-dynauth in /etc/services)
my $s = new Net::UDP { thisservice => "radius-dynauth" } or die $!;
$s->bind or die "Couldn't bind: $!";
$s->fcntl(F_SETFL, $s->fcntl(F_GETFL,0) | O_NONBLOCK)
  or die "Couldn't make socket non-blocking: $!";
 
# Loop forever, receiving packets and replying to them
while (1) {
  my ($rec, $whence);
  # Wait for a packet
  my $nfound = $s->select(1, 0, 1, undef);
  if ($nfound > 0) {
    # Get the data
    $rec = $s->recv(undef, undef, $whence);
    # Unpack it
    my $p = new Net::Radius::Packet $RADIUS_DICTIONARY, $rec;
    # Create a response packet
    my $rp = new Net::Radius::Packet $RADIUS_DICTIONARY;

    if ( my ($request_type) = $p->code =~ /(CoA|Disconnect)-Request/ ) {

      $rp->set_code("$request_type-ACK");
      $rp->set_identifier($p->identifier);
      $rp->set_authenticator($p->authenticator);
      $rp->set_attr('Reply-Message' => $p->attr('Calling-Station-Id'));
      #$rp->set_attr('Error-Cause' => 404);

    } else {

      # It's not an CoA-Request
      print "Unexpected packet type recieved.\n";

      # Create a response packet
      $rp->set_code("$request_type-NAK");
      $rp->set_identifier($p->identifier);
      $rp->set_authenticator($p->authenticator);
      $rp->set_attr('Error-Cause' => 404);

    }

    # printing debug information
    print "Request\n";
    print "=======\n";
    $p->dump;
    print "Response\n";
    print "========\n";
    $rp->dump;

    # send response
    $s->sendto(auth_resp($rp->pack, $secret), $whence);
  }
}

=head1 AUTHOR

Inverse inc. <info@inverse.ca>

Luis E. Muñoz <luismunoz@cpan.org>.

Christopher Masto. 

=head1 COPYRIGHT

Copyright (C) 2005-2023 Inverse inc.

Changes (c) 2002,2003 Luis E. Muñoz <luismunoz@cpan.org>.

Original work (c) Christopher Masto. 

=head1 LICENSE

This software can be used under the same terms as perl itself. It also
carries the same warranties.

=cut
