File Coverage

blib/lib/Net/Radius/Server/NS.pm

Criterion	Covered	Total	%
statement	18	101	17.8
branch	0	38	0.0
condition	0	18	0.0
subroutine	6	9	66.6
pod			n/a
total	24	166	14.4

package Net::Radius::Server::NS;

use 5.008;
use strict;
use warnings;
use Net::Radius::Packet;
use base qw/Net::Server::MultiType Net::Radius::Server/;
use Net::Radius::Server::Base qw/:all/;

our $VERSION = do { sprintf "%0.3f", 1+(q$Revision: 89 $ =~ /\d+/g)[0]/1000 };

# Verify that the required configuration keys are present. Initialize
# whatever we'll require for request processing, such as dictionaries,
# RADIUS setup file and 'secret' sources.
sub options
{
    my $self	= shift;
    my $prop	= $self->{server};
    my $ref 	= shift;

    $self->SUPER::options($ref, @_);

    for ( qw(nrs_rule_script nrs_secret_script nrs_dictionary_script) )
    {
	$prop->{$_} = [] unless exists $prop->{$_};
	$ref->{$_} = $prop->{$_};
    }
}

sub configure
{
    my $self = shift;		# A Net::Server-derived object
    my $s = $self->{server};

    $self->SUPER::configure(@_);

    # We need to have a few keys defined before proceeding.
    die __PACKAGE__, " definitions are missing\n"
	unless (exists $s->{nrs_rule_script}
		and exists $s->{nrs_secret_script}
		and exists $s->{nrs_dictionary_script});

    for (qw/nrs_dictionary_script nrs_rule_script nrs_secret_script/)
    {
	die __PACKAGE__, ": Exactly one $_ must be specified\n"
	    if @{$s->{$_}} != 1;
    }

    my ($d_method, $s_method, $rules);

    eval { $d_method = do ($s->{nrs_dictionary_script}->[0]) };
    warn "Dictionary script ", $s->{nrs_dictionary_script}->[0],
    " produced output: $@\n" if $@;
    die "Dictionary script ", $s->{nrs_dictionary_script}->[0],
    " must return a coderef (returned "
	. ($d_method||'false/undef') . ")\n"
	unless ref($d_method) eq 'CODE';

    eval { $s_method = do ($s->{nrs_secret_script}->[0]) };
    warn "Secret script ", $s->{nrs_secret_script}->[0],
    " produced output: $@\n" if $@;
    die "Secret script ", $s->{nrs_secret_script}->[0],
    " must return a coderef (returned "
	. ($s_method||'false/undef') . ")\n"
	unless ref($s_method) eq 'CODE';

    eval { $rules = do ($s->{nrs_rule_script}->[0]) };
    warn "Rule script produced output: $@\n" if $@;
    die "Rule script must return a listref (returned "
	. ($rules||'false/undef') . ")\n"
	unless ref($rules) eq 'ARRAY';

    $self->{_nrs} = {
	secret		=> $s_method,
	dict		=> $d_method,
	rules		=> $rules,
    };
}

# Add the processing handler that is responsible for each packet
sub process_request
{
    my $self = shift;
    my $prop = $self->{server};
    my $data = {
	packet		=> $prop->{udp_data},
	peer_addr	=> $prop->{peeraddr},
	peer_host	=> $prop->{peerhost},
	peer_port	=> $prop->{peerport},
	port		=> $prop->{sockport},
	sockaddr	=> $prop->{sockaddr},
	server		=> $self,
    };

    if (length($data->{packet}) < 18)
    {
	$self->log(2, "Packet too short - Ignoring");
	return;
    }

    $data->{secret}	= $self->{_nrs}->{secret}->($data);
    $data->{dict}	= $self->{_nrs}->{dict}->($data);
    $data->{response}	= new Net::Radius::Packet $data->{dict};
    $data->{request}	= Net::Radius::Packet->new($data->{dict},
						   $data->{packet});

    if (not defined $data->{request})
    {
	$self->log(2, "Failed to decode RADIUS packet (garbage?)");
	return;
    }

    $self->log(2, "Received from " . ($data->{peer_addr} || '[no peer]')
	       . ' (' . $data->{request}->code . ' '
	       . join(', ', map { "$_ => " . $data->{request}->attr($_) }
		      grep { $_ !~ /(?i)password|-message/ }
		      $data->{request}->attributes)
	       . ') ');

    $self->log(4, "Request: " . $data->{request}->str_dump);

    # Verify that the authenticator in the packet matches the packet
    # data. Discard the packet if this check fails

    if (grep { $data->{request}->code eq $_ }
	qw/Accounting-Request
	Disconnect-Request Disconnect-ACK Disconnect-NAK
	CoA-Request CoA-ACK CoA-NAK/)
    {
	if (auth_acct_verify($data->{packet}, $data->{secret}))
	{
	    $self->log(4, $data->{request}->code .
		       ' with good secret from ' .
		       $data->{peer_addr});
	}
	else
	{
	    # Bad secret - Ignore request
	    $self->log(2, $data->{request}->code .
		       ' with bad secret from ' .
		       $data->{peer_addr});
	    return;
	}
    }

    my $res = undef;
    for my $r (@{$self->{_nrs}->{rules}})
    {
	$res = $r->eval($data);
	unless (defined $res)
	{
	    $self->log(4, $r->description . ": Did not match");
	    next;
	}

	if ($res & NRS_SET_DISCARD)
	{
	    $self->log(2, $r->description . ": Requested discard");
	    return;
	}

	if ($res & NRS_SET_SKIP)
	{
	    $self->log(4, $r->description . ": Requested skip");
	    next;
	}

	if ($res & NRS_SET_RESPOND)
	{
	    $self->log(4, $r->description . ": Requested respond");
	    last;
	}
    }

    unless (defined $res)
    {
	$self->log(2, "Discard: No matching rule");
	return;
    }

    if ($res & NRS_SET_RESPOND)
    {
	$self->log(2, "Sent " . $data->{response}->code . ' '
		   . join(', ', map { "$_ => " . $data->{response}->attr($_) }
			  grep { $_ !~ /(?i)password|-message/ }
			  $data->{response}->attributes) . " to request from "
		   . ($data->{peer_addr} || '[no peer]')
		   . ' (' . $data->{request}->code . ' '
		   . join(', ', map { "$_ => " . $data->{request}->attr($_) }
			  grep { $_ !~ /(?i)password|-message/ }
			  $data->{request}->attributes)
		   . ') ');
	$self->log(3, "Responding");
	my $reply_packet = auth_resp($data->{response}->pack,
				     $data->{secret});
	$self->{server}->{client}->send($reply_packet);
	$self->log(4, "Response: " .
		   Net::Radius::Packet->new($data->{dict},
					    $reply_packet)->str_dump);
    }
    else
    {
	$self->log(2, "Ignoring request from " .
		   ($data->{peer_addr} || '[no peer]')
		   . ' (' . $data->{request}->code . ' '
		   . join(', ', map { "$_ => " . $data->{request}->attr($_) }
			  grep { $_ !~ /(?i)password|-message/ }
			  $data->{request}->attributes)
		   . ') ');
    }
}

42;

__END__