File Coverage

blib/lib/POE/Component/Server/RADIUS.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package POE::Component::Server::RADIUS;
{
  $POE::Component::Server::RADIUS::VERSION = '1.08';
}

#ABSTRACT: a POE based RADIUS server component

use strict;
use warnings;
use Socket;
use POE;
use Net::Radius::Dictionary;
use Net::Radius::Packet;
use Net::IP::Minimal qw(ip_is_ipv4);

use constant DATAGRAM_MAXLEN => 4096;
use constant RADIUS_PORT => 1812;
use constant ACCOUNTING_PORT => 1813;
use constant RADIUS_PORT_OLD => 1645;
use constant ACCOUNTING_PORT_OLD => 1646;

# Stolen from POE::Wheel. This is static data, shared by all
my $current_id = 0;
my %active_identifiers;

sub spawn {
  my $package = shift;
  my %opts = @_;
  $opts{lc $_} = delete $opts{$_} for keys %opts;
  unless ( ref $opts{dict} and $opts{dict}->isa('Net::Radius::Dictionary') ) {
	warn "No 'dict' object provided, bailing out\n";
	return;
  }
  my $options = delete $opts{options};
  my $self = bless \%opts, $package;
  $self->{session_id} = POE::Session->create(
	object_states => [
	   $self => { shutdown => '_shutdown',
		      accept   => '_command',
		      reject   => '_command',
	   },
	   $self => [qw(_start _get_auth_data _get_acct_data register unregister _req_alarm)],
	],
	heap => $self,
	( ref($options) eq 'HASH' ? ( options => $options ) : () ),
  )->ID();
  return $self;
}

sub _allocate_identifier {
  while (1) {
    last unless exists $active_identifiers{ ++$current_id };
  }
  return $active_identifiers{$current_id} = $current_id;
}

sub _free_identifier {
  my $id = shift;
  delete $active_identifiers{$id};
}

sub session_id {
  return $_[0]->{session_id};
}

sub shutdown {
  my $self = shift;
  $poe_kernel->post( $self->{session_id}, 'shutdown' );
}

sub dictionary {
  return $_[0]->{dict};
}

sub add_client {
  my $self = shift;
  my %opts = @_;
  $opts{lc $_} = delete $opts{$_} for keys %opts;
  unless ( $opts{name} and $opts{address} and $opts{secret} ) {
    warn "You must provide a 'name' and 'address' and 'secret'\n";
    return;
  }
  unless ( ip_is_ipv4( $opts{address} ) ) {
    warn "'address' must be an IPv4 address\n";
    return;
  }
  if ( $self->{clients}->{ $opts{name} } ) {
    warn "That 'name' already exists\n";
    return;
  }
  if ( grep { $self->{clients}->{$_}->{address} eq $opts{address} } keys %{ $self->{clients} } ) {
    warn "That 'address' already exists\n";
    return;
  }
  $self->{clients}->{ $opts{name} }->{$_} = $opts{$_} for qw(address secret);
  return 1;
}

sub del_client {
  my $self = shift;
  my $value = shift || return;
  if ( $self->{clients}->{ $value } ) {
     delete $self->{clients}->{ $value };
     return 1;
  }
  if ( ip_is_ipv4( $value ) ) {
     foreach my $name ( keys %{ $self->{clients} } ) {
	next unless $self->{clients}->{$name}->{address} eq $value;
	delete $self->{clients}->{$name};
	return 1;
     }
  }
  return;
}

sub _validate_client {
  my $self = shift;
  my $client = shift || return;
  foreach my $name ( keys %{ $self->{clients} } ) {
     next unless $self->{clients}->{$name}->{address} eq $client;
     return $self->{clients}->{$name}->{secret};
  }
  return;
}

sub authports {
  my $self = shift;
  return map { ( sockaddr_in( getsockname $_ ) )[0] } @{ $self->{_authsocks} };
}

sub acctports {
  my $self = shift;
  return map { ( sockaddr_in( getsockname $_ ) )[0] } @{ $self->{_acctsocks} };
}

sub _start {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  $self->{session_id} = $_[SESSION]->ID();
  $kernel->alias_set( $self->{alias} ) if $self->{alias};
  $kernel->refcount_increment($self->{session_id}, __PACKAGE__) unless $self->{alias};
  my @authports; my @acctports;
  push @authports, $self->{authport} if defined $self->{authport};
  push @acctports, $self->{acctport} if defined $self->{acctport};
  unless ( defined $self->{authport} ) {
     push @authports, RADIUS_PORT;
     push @authports, RADIUS_PORT_OLD if $self->{legacy};
  }
  unless ( defined $self->{acctport} ) {
     push @acctports, ACCOUNTING_PORT;
     push @acctports, ACCOUNTING_PORT_OLD if $self->{legacy};
  }
  my $proto = getprotobyname('udp');
  foreach my $port ( @authports ) {
     my $paddr = sockaddr_in($port, INADDR_ANY);
     socket( my $socket, PF_INET, SOCK_DGRAM, $proto);
     bind( $socket, $paddr);
     push @{ $self->{_authsocks} }, $socket;
     $kernel->select_read( $socket, '_get_auth_data' );
  }
  foreach my $port ( @acctports ) {
     my $paddr = sockaddr_in($port, INADDR_ANY);
     socket( my $socket, PF_INET, SOCK_DGRAM, $proto);
     bind( $socket, $paddr);
     push @{ $self->{_acctsocks} }, $socket;
     $kernel->select_read( $socket, '_get_acct_data' );
  }
  return;
}

sub _shutdown {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  $kernel->alarm_remove_all();
  $kernel->alias_remove( $_ ) for $kernel->alias_list();
  $kernel->refcount_decrement($self->{session_id}, __PACKAGE__) unless $self->{alias};
  $kernel->select_read( $_ ) for @{ $self->{_authsocks} };
  $kernel->select_read( $_ ) for @{ $self->{_acctsocks} };
  delete $self->{_authsocks}; delete $self->{_acctsocks};
  delete $self->{_requests};
  $kernel->refcount_decrement( $_, __PACKAGE__ ) for keys %{ $self->{sessions} };
  return;
}

sub _get_auth_data {
  my ($kernel,$self,$socket) = @_[KERNEL,OBJECT,ARG0];
  my $remote_address = recv( $socket, my $message = '', 4096, 0 );
  # Check remote_address is valid
  my $client = inet_ntoa( ( sockaddr_in $remote_address )[1] );
  my $secret = $self->_validate_client( $client );
  return unless $secret;
  my $p = Net::Radius::Packet->new( $self->{dict}, $message );
  # Check $p is valid
  return unless $p->code eq 'Access-Request';
  my $data = {
     map { ( $_, $p->attr($_) ) } $p->attributes()
  };
  $data->{'User-Password'} = $p->password( $secret ) if $data->{'User-Password'};
  my $req_id = _allocate_identifier();
  $self->{_requests}->{ $req_id } = {
	identifier => $p->identifier,
	authenticator => $p->authenticator,
	from => $remote_address,
	client => $client,
	secret => $secret,
	socket => $socket,
  };
  # dispatch to interested sessions
  $kernel->post( $_, $self->{sessions}->{$_}->{authevent}, $client, $data, $req_id, $p )
	for grep { $self->{sessions}->{$_}->{authevent} } keys %{ $self->{sessions} };
  # set an alarm
  $self->{_requests}->{ $req_id }->{alarm_id} =
	$kernel->delay_set( '_req_alarm', $self->{timeout} || 10, $req_id );
  return;
}

sub _req_alarm {
  my ($kernel,$self,$req_id) = @_[KERNEL,OBJECT,ARG0];
  return unless $self->{_requests}->{ $req_id };
  delete $self->{_requests}->{ $req_id };
  _free_identifier( $req_id );
  return;
}

sub _get_acct_data {
  my ($kernel,$self,$socket) = @_[KERNEL,OBJECT,ARG0];
  my $remote_address = recv( $socket, my $message = '', 4096, 0 );
  # Check remote_address is valid
  my $client = inet_ntoa( ( sockaddr_in $remote_address )[1] );
  my $secret = $self->_validate_client( $client );
  return unless $secret;
  return unless auth_acct_verify( $message, $secret );
  my $p = Net::Radius::Packet->new( $self->{dict}, $message );
  # Check $p is valid
  return unless $p->code eq 'Accounting-Request';
  my $data = {
     map { ( $_, $p->attr($_) ) } $p->attributes()
  };
  # dispatch to interested sessions
  $kernel->post( $_, $self->{sessions}->{$_}->{acctevent}, $client, $data, $p )
	for grep { $self->{sessions}->{$_}->{acctevent} } keys %{ $self->{sessions} };
  my $rp = Net::Radius::Packet->new( $self->{dict} );
  $rp->set_identifier($p->identifier);
  $rp->set_authenticator($p->authenticator);
  $rp->set_code('Accounting-Response');
  my $reply = auth_resp( $rp->pack, $secret );
  warn "Problem sending packet to '$client'\n" unless
	send( $socket, $reply, 0, $remote_address ) == length($reply);
  return;
}

sub _command {
  my ($kernel,$self,$state,$req_id) = @_[KERNEL,OBJECT,STATE,ARG0];
  my %args;
  if ( ref $_[ARG1] eq 'HASH' ) {
    %args = %{ $_[ARG1] };
  }
  elsif ( ref $_[ARG1] eq 'ARRAY' ) {
    %args = @{ $_[ARG1] };
  }
  else {
    %args = @_[ARG1..$#_];
  }
  return unless $self->{_requests}->{ $req_id };
  my $req = delete $self->{_requests}->{ $req_id };
  _free_identifier( $req_id );
  $kernel->alarm_remove( $req->{alarm_id} );
  my $code;
  $code = 'Access-Accept' if $state eq 'accept';
  $code = 'Access-Reject' if $state eq 'reject';
  my $rp = Net::Radius::Packet->new( $self->{dict} );
  $rp->set_identifier( $req->{identifier} );
  $rp->set_authenticator( $req->{authenticator} );
  $rp->set_code( $code );
  $rp->set_attr( $_, $args{$_} ) for keys %args;
  my $reply = auth_resp( $rp->pack, $req->{secret} );
  warn "Problem sending packet to '$req->{client}'\n" unless
	send( $req->{socket}, $reply, 0, $req->{from} ) == length($reply);
  return;
}

sub register {
  my ($kernel,$self,$sender) = @_[KERNEL,OBJECT,SENDER];
  my $sender_id = $sender->ID();
  my %args;
  if ( ref $_[ARG0] eq 'HASH' ) {
    %args = %{ $_[ARG0] };
  }
  elsif ( ref $_[ARG0] eq 'ARRAY' ) {
    %args = @{ $_[ARG0] };
  }
  else {
    %args = @_[ARG0..$#_];
  }
  $args{lc $_} = delete $args{$_} for keys %args;
  unless ( $args{authevent} or $args{acctevent} ) {
    warn "You must specify either 'authevent' or 'acctevent' arguments\n";
    return;
  }
  if ( defined $self->{sessions}->{ $sender_id } ) {
    $self->{sessions}->{ $sender_id } = \%args;
  }
  else {
    $self->{sessions}->{ $sender_id } = \%args;
    $kernel->refcount_increment( $sender_id, __PACKAGE__ );
  }
  return;
}

sub unregister {
  my ($kernel,$self,$sender) = @_[KERNEL,OBJECT,SENDER];
  my $sender_id = $sender->ID();
  my %args;
  if ( ref $_[ARG0] eq 'HASH' ) {
    %args = %{ $_[ARG0] };
  }
  elsif ( ref $_[ARG0] eq 'ARRAY' ) {
    %args = @{ $_[ARG0] };
  }
  else {
    %args = @_[ARG0..$#_];
  }
  $args{lc $_} = delete $args{$_} for keys %args;
  my $data = delete $self->{sessions}->{ $sender_id };
  $kernel->refcount_decrement( $sender_id, __PACKAGE__ ) if $data;
  return;
}

1;

__END__