File Coverage

blib/lib/POE/Component/Client/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::Client::RADIUS;
$POE::Component::Client::RADIUS::VERSION = '1.04';
#ABSTRACT: a flexible POE-based RADIUS client

use strict;
use warnings;
use Carp;
use POE;
use IO::Socket::INET;
use Net::Radius::Dictionary;
use Net::Radius::Packet;
use Math::Random;

use constant DATAGRAM_MAXLEN => 4096;
use constant RADIUS_PORT => 1812;
use constant ACCOUNTING_PORT => 1813;

my $ERROR;
my $ERRNO;

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

sub spawn {
  my $package = shift;
  return $package->_create( 'spawn', @_ );
}

sub authenticate {
  my $self;
  eval {
    if ( (ref $_[0]) && $_[0]->isa(__PACKAGE__) ) {
	$self = shift;
    }
  };
  if ( $self ) {
	$poe_kernel->post( $self->{session_id}, 'authenticate', @_ );
	return 1;
  }
  my $package = shift;
  return $package->_create( 'authenticate', @_ );
}

sub accounting {
  my $self;
  eval {
    if ( (ref $_[0]) && $_[0]->isa(__PACKAGE__) ) {
	$self = shift;
    }
  };
  if ( $self ) {
	$poe_kernel->post( $self->{session_id}, 'accounting', @_ );
	return 1;
  }
  my $package = shift;
  return $package->_create( 'accounting', @_ );
}

sub _create {
  my $package = shift;
  my $command = shift;
  my %opts = @_;
  $opts{lc $_} = delete $opts{$_} for grep { !/^_/ } 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 { }, $package;
  if ( $command =~ /^a/ ) {
     unless ( $opts{event} ) {
	warn "You must specify 'event' for '$command'\n";
        return;
     }
     unless ( $opts{server} and _ip_is_v4( $opts{server} ) ) {
	warn "You must specify 'server' as a valid IPv4 address\n";
        return;
     }
     unless ( $opts{secret} ) {
	warn "You must specify a 'secret'\n";
	return;
     }
     unless ( $opts{attributes} and ref $opts{attributes} eq 'HASH' ) {
	warn "You must specify 'attributes' as a hashref of RADIUS attributes\n";
        return;
     }
     if ( $command eq 'authenticate' and !( $opts{username} and $opts{password} ) ) {
	warn "You must specify 'username' and 'password' for 'authenticate'\n";
	return;
     }
     if ( $command eq 'accounting' and !$opts{type} ) {
	warn "You must specify 'type' for an accounting request\n";
	return;
     }
     $opts{port} = RADIUS_PORT if $command eq 'authenticate' and !$opts{port};
     $opts{port} = ACCOUNTING_PORT if $command eq 'accounting' and !$opts{port};
  }
  $self->{session_id} = POE::Session->create(
     object_states => [
	$self => { shutdown => '_shutdown',
		   authenticate => '_command',
		   accounting   => '_command', },
	$self => [qw(_start _create_socket _dispatch _get_datagram _sock_timeout)],
     ],
     heap => $self,
     args => [ $command, %opts ],
     ( ref($options) eq 'HASH' ? ( options => $options ) : () ),
  )->ID();
  return $self;
}

sub _allocate_identifier {
  while (1) {
    ++$current_id;
    $current_id = 1 if $current_id > 255;
    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 _start {
  my ($kernel,$self,$sender,$command,@args) = @_[KERNEL,OBJECT,SENDER,ARG0..$#_];
  $self->{session_id} = $_[SESSION]->ID();
  if ( $command eq 'spawn' ) {
     my $opts = { @args };
     $self->{$_} = $opts->{$_} for keys %{ $opts };
     $kernel->alias_set($self->{alias}) if $self->{alias};
     $kernel->refcount_increment($self->{session_id}, __PACKAGE__) unless $self->{alias};
     return;
  }
  if ( $kernel == $sender ) {
	croak "'authenticate' and 'accounting' should be called from another POE Session\n";
  }
  $self->{sender_id} = $sender->ID();
  $kernel->refcount_increment( $self->{sender_id}, __PACKAGE__ );
  $kernel->yield( $command, @args );
  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};
  return;
}

sub _command {
  my ($kernel,$self,$state,$session,$sender) = @_[KERNEL,OBJECT,STATE,SESSION,SENDER];
  my $args;
  if ( ref $_[ARG0] eq 'HASH' ) {
     $args = $_[ARG0];
  }
  else {
     $args = { @_[ARG0..$#_] };
  }
  $args->{cmd} = $state;
  if ( $session == $sender ) {
     $args->{sender_id} = $self->{sender_id};
     $self->{dict} = delete $args->{dict};
  }
  else {
     $args->{lc $_} = delete $args->{$_} for grep { !/^_/ } keys %{ $args };
     $args->{sender_id} = $sender->ID();
     unless ( $args->{event} ) {
	warn "You must specify 'SuccessEvent' and 'FailureEvent' for '$state'\n";
        return;
     }
     unless ( $args->{server} and _ip_is_v4( $args->{server} ) ) {
	warn "You must specify 'server' as a valid IPv4 address\n";
        return;
     }
     unless ( $args->{secret} ) {
	warn "You must specify a 'secret'\n";
	return;
     }
     unless ( $args->{attributes} and ref $args->{attributes} eq 'HASH' ) {
	warn "You must specify 'attributes' as a hashref of RADIUS attributes\n";
        return;
     }
     if ( $state eq 'authenticate' and !( $args->{username} and $args->{password} ) ) {
	warn "You must specify 'username' and 'password' for 'authenticate'\n";
	return;
     }
     if ( $state eq 'accounting' and !$args->{type} ) {
	warn "You must specify 'type' for an accounting request\n";
	return;
     }
     $args->{port} = RADIUS_PORT if $state eq 'authenticate' and !$args->{port};
     $args->{port} = ACCOUNTING_PORT if $state eq 'accounting' and !$args->{port};
     $kernel->refcount_increment( $args->{sender_id}, __PACKAGE__ );
  }
  my $req = Net::Radius::Packet->new( $self->{dict} );
  my $packet;
  if ( $state eq 'authenticate' ) {
     $args->{identifier} = _allocate_identifier();
     $args->{authenticator} = _bigrand();
     $req->set_code('Access-Request');
     $req->set_attr('User-Name' => $args->{username});
     $req->set_attr('Service-Type' => '2');
     $req->set_attr('Framed-Protocol' => 'PPP');
     $req->set_attr('NAS-Port' => 1234);
     $req->set_attr('NAS-Identifier' => 'PoCoClientRADIUS');
     $req->set_attr('NAS-IP-Address' => _my_address( $args->{server} ) );
     $req->set_attr('Called-Station-Id' => '0000');
     $req->set_attr('Calling-Station-Id' => '01234567890');
     delete $args->{attributes}->{'User-Name'};
     $req->set_attr( $_ => $args->{attributes}->{$_} ) for keys %{ $args->{attributes} };
     $req->set_identifier( $args->{identifier} );
     $req->set_authenticator( $args->{authenticator} );
     $req->set_password( $args->{password}, $args->{secret} );
     $packet = $req->pack;
  }
  if ( $state eq 'accounting' ) {
     $args->{identifier} = _allocate_identifier();
     $args->{authenticator} = '';
     $req->set_code('Accounting-Request');
     $req->set_attr('Acct-Status-Type', ucfirst lc $args->{type});
     delete $args->{attributes}->{'Acct-Status-Type'};
     $req->set_attr( $_ => $args->{attributes}->{$_} ) for keys %{ $args->{attributes} };
     $req->set_identifier( $args->{identifier} );
     $req->set_authenticator( $args->{authenticator} );
     $packet = auth_resp($req->pack,$args->{secret});
  }
  $kernel->yield( '_create_socket', $packet, $args );
  return;
}

sub _create_socket {
  my ($kernel,$self,$packet,$data) = @_[KERNEL,OBJECT,ARG0,ARG1];
  my $socket = IO::Socket::INET->new( Proto => 'udp' );
  $kernel->select_read( $socket, '_get_datagram', $data );
  unless ( $socket ) {
     $data->{error} = $!;
     $kernel->yield( '_dispatch', $data );
     return;
  }
  my $server_address = pack_sockaddr_in( $data->{port}, inet_aton($data->{server}) );
  unless ( $server_address ) {
     $data->{error} = 'Couldn\'t create packed server address and socket';
     $kernel->yield( '_dispatch', $data );
     return;
  }
  unless ( send( $socket, $packet, 0, $server_address ) == length($packet) ) {
     $data->{error} = $!;
     $kernel->yield( '_dispatch', $data );
     return;
  }
  $data->{alarm_id} = $kernel->delay_set( '_sock_timeout', $self->{timeout} || 10, $socket, $data );
  return;
}

sub _sock_timeout {
  my ($kernel,$self,$socket,$data) = @_[KERNEL,OBJECT,ARG0,ARG1];
  $kernel->select_read( $socket );
  $data->{timeout} = 'Timeout waiting for a response';
  $kernel->yield( '_dispatch', $data );
  return;
}

sub _get_datagram {
  my ($kernel,$self,$socket,$data) = @_[KERNEL,OBJECT,ARG0,ARG2];
  $kernel->alarm_remove( delete $data->{alarm_id} );
  $kernel->select_read( $socket );
  my $remote_address = recv( $socket, my $message = '', 4096, 0 );
  unless ( defined $remote_address ) {
     $data->{error} = $!;
     $kernel->yield( '_dispatch', $data );
     return;
  }
  my $resp = Net::Radius::Packet->new( $self->{dict}, $message );
  my ($port, $iaddr) = unpack_sockaddr_in( $remote_address );
  $iaddr = inet_ntoa( $iaddr );
  if ( $data->{identifier} ne $resp->identifier or $iaddr ne $data->{server} ) {
     $data->{error} = 'Unexpected response to request.';
     $kernel->yield( '_dispatch', $data );
     return;
  }
  if ( $data->{cmd} eq 'authenticate' and !auth_req_verify( $message, $data->{secret}, $data->{authenticator} ) ) {
     $data->{error} = 'Couldn\'t authenticate the response from the server.';
     $kernel->yield( '_dispatch', $data );
     return;
  }
  my $reply = {
     map { ( $_, $resp->attr($_) ) } $resp->attributes()
  };
  $reply->{Code} = $resp->code;
  $data->{response} = $reply;
  $kernel->yield( '_dispatch', $data );
  return;
}

sub _dispatch {
  my ($kernel,$self,$data) = @_[KERNEL,OBJECT,ARG0];
  delete $data->{authenticator};
  my $ident = delete $data->{identifier};
  _free_identifier( $ident ) if $ident;
  $kernel->post( $data->{sender_id}, $data->{event}, $data );
  $kernel->refcount_decrement( delete $data->{sender_id}, __PACKAGE__ );
  return;
}

#------------------------------------------------------------------------------
# Subroutine _ip_is_ipv4
# Purpose           : Check if an IP address is version 4
# Params            : IP address
# Returns           : 1 (yes) or 0 (no)
sub _ip_is_v4 {
    my $ip = shift;

    # Check for invalid chars
    unless ($ip =~ m/^[\d\.]+$/) {
        $ERROR = "Invalid chars in IP $ip";
        $ERRNO = 107;
        return 0;
    }

    if ($ip =~ m/^\./) {
        $ERROR = "Invalid IP $ip - starts with a dot";
        $ERRNO = 103;
        return 0;
    }

    if ($ip =~ m/\.$/) {
        $ERROR = "Invalid IP $ip - ends with a dot";
        $ERRNO = 104;
        return 0;
    }

    # Single Numbers are considered to be IPv4
    if ($ip =~ m/^(\d+)$/ and $1 < 256) { return 1 }

    # Count quads
    my $n = ($ip =~ tr/\./\./);

    # IPv4 must have from 1 to 4 quads
    unless ($n >= 0 and $n < 4) {
        $ERROR = "Invalid IP address $ip";
        $ERRNO = 105;
        return 0;
    }

    # Check for empty quads
    if ($ip =~ m/\.\./) {
        $ERROR = "Empty quad in IP address $ip";
        $ERRNO = 106;
        return 0;
    }

    foreach (split /\./, $ip) {

        # Check for invalid quads
        unless ($_ >= 0 and $_ < 256) {
            $ERROR = "Invalid quad in IP address $ip - $_";
            $ERRNO = 107;
            return 0;
        }
    }
    return 1;
}

sub _bigrand {
  my @numbers;
  push @numbers, scalar random_uniform_integer(1,0,65536) for 0 .. 7;
  pack "n8", @numbers;
}

sub _my_address {
  my $remote = shift || '198.41.0.4';
  my $socket = IO::Socket::INET->new(
        Proto       => 'udp',
        PeerAddr    => $remote,
        PeerPort    => 53,
  );
  return unless $socket;
  return $socket->sockhost;
}

qq[Sound of crickets];

__END__