r66157 - in /trunk/libauthen-radius-perl: Changes Radius.pm debian/changelog debian/control debian/source/ debian/source/format raddb/dictionary raddb/dictionary.rfc2869
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Fri Dec 24 04:15:48 UTC 2010
Author: jawnsy-guest
Date: Fri Dec 24 04:15:30 2010
New Revision: 66157
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=66157
Log:
* New upstream release
+ Improved support for CoA
+ Adds support for dictionaries in FreeRADIUS format
+ Partial support for WiMAX attributes
+ Now supports multiple RADIUS servers (i.e. a cluster)
* Standards-Version 3.9.1 (no changes)
* Use new 3.0 (quilt) source format
Added:
trunk/libauthen-radius-perl/debian/source/
trunk/libauthen-radius-perl/debian/source/format
trunk/libauthen-radius-perl/raddb/dictionary.rfc2869
- copied unchanged from r66156, branches/upstream/libauthen-radius-perl/current/raddb/dictionary.rfc2869
Modified:
trunk/libauthen-radius-perl/Changes
trunk/libauthen-radius-perl/Radius.pm
trunk/libauthen-radius-perl/debian/changelog
trunk/libauthen-radius-perl/debian/control
trunk/libauthen-radius-perl/raddb/dictionary
Modified: trunk/libauthen-radius-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libauthen-radius-perl/Changes?rev=66157&op=diff
==============================================================================
--- trunk/libauthen-radius-perl/Changes (original)
+++ trunk/libauthen-radius-perl/Changes Fri Dec 24 04:15:30 2010
@@ -1,4 +1,17 @@
Revision history for Perl extension Radius.
+
+0.20 Tue Nov 09 22:45:99 2010
+ - Fixed the bug with the incorrect encoding of Cisco AVPair attributes
+
+0.19 Tue Nov 02 00:07:00 2010
+ - Improved support for CoA (thanks Oleg Gawriloff and Matej Vela)
+ - Ability to work with dictionaries in FreeRADIUS format
+ (thanks to Alexandr Kovalenko and Matej Vela)
+ - Support (partial) for WIMAX attributes
+
+0.18 Sun Oct 05 01:00:00 2010 (this version was not released to CPAN,
+ only used for internal testing)
+ - Support for a list of multiple RADIUS servers (RADIUS cluster)
0.17 Thu Jan 14 09:20:00 2010
- Support for RFC3579 - Message-Authenticator
Modified: trunk/libauthen-radius-perl/Radius.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libauthen-radius-perl/Radius.pm?rev=66157&op=diff
==============================================================================
--- trunk/libauthen-radius-perl/Radius.pm (original)
+++ trunk/libauthen-radius-perl/Radius.pm Fri Dec 24 04:15:30 2010
@@ -8,11 +8,12 @@
# #
# Modified by Olexander Kapitanenko <kapitan at portaone.com>, #
# Andrew Zhilenko <andrew at portaone.com>, 2002-2010. #
+# and the rest of PortaOne team. #
# #
# See the file 'Changes' in the distrution archive. #
# #
#############################################################################
-# $Id: Radius.pm,v 1.33 2010/01/14 08:20:50 andrew Exp $
+# $Id: Radius.pm,v 1.49 2010/11/10 06:52:02 andrew Exp $
package Authen::Radius;
@@ -31,15 +32,18 @@
@ISA = qw(Exporter);
@EXPORT = qw(ACCESS_REQUEST ACCESS_ACCEPT ACCESS_REJECT
ACCOUNTING_REQUEST ACCOUNTING_RESPONSE ACCOUNTING_STATUS
- DISCONNECT_REQUEST
- COA_REQUEST);
-$VERSION = '0.17';
+ DISCONNECT_REQUEST DISCONNECT_ACCEPT DISCONNECT_REJECT
+ COA_REQUEST COA_ACCEPT COA_REJECT COA_ACK COA_NAK);
+
+$VERSION = '0.20';
my (%dict_id, %dict_name, %dict_val, %dict_vendor_id, %dict_vendor_name );
my ($request_id) = $$ & 0xff; # probably better than starting from 0
my ($radius_error, $error_comment) = ('ENONE', '');
my $debug = 0;
+use constant WIMAX_VENDOR => '24757';
+use constant WIMAX_CONTINUATION_BIT => 0b10000000;
#
# we'll need to predefine these attr types so we can do simple password
# verification without having to load a dictionary
@@ -56,11 +60,20 @@
use constant ACCOUNTING_RESPONSE => 5;
use constant ACCOUNTING_STATUS => 6;
use constant DISCONNECT_REQUEST => 40;
+use constant DISCONNECT_ACCEPT => 41;
+use constant DISCONNECT_REJECT => 42;
use constant COA_REQUEST => 43;
+use constant COA_ACCEPT => 44;
+use constant COA_ACK => 44;
+use constant COA_REJECT => 45;
+use constant COA_NAK => 45;
my $HMAC_MD5_BLCKSZ = 64;
my $RFC3579_MSG_AUTH_ATTR_ID = 80;
my $RFC3579_MSG_AUTH_ATTR_LEN = 18;
+my %SERVICES = ( 'radius' => 1812,
+ 'radacct' => 1813,
+ 'radius-acct' => 1813 );
sub new {
my $class = shift;
@@ -72,41 +85,82 @@
$self->set_error;
$debug = $h{'Debug'};
-
- return $self->set_error('ENOHOST') unless $h{'Host'};
+
+ if (!$h{'Host'} && !$h{'NodeList'}) {
+ return $self->set_error('ENOHOST');
+ }
+
+ $service = $h{'Service'} ? $h{'Service'} : 'radius';
+ my $serv_port = getservbyname($service, 'udp');
+ if (!$serv_port && !exists($SERVICES{$service})) {
+ return $self->set_error('EBADSERV');
+ } elsif (!$serv_port) {
+ $serv_port = $SERVICES{$service};
+ }
+
($host, $port) = split(/:/, $h{'Host'});
-
- $service = $h{'Service'} ? $h{'Service'} : 'radius';
-
- $port = getservbyname($service, 'udp') unless $port;
-
- unless ($port) {
- my %services = ( radius => 1645, radacct => 1646,
- 'radius-acct' => 1813 );
- if (exists($services{$service})) {
- $port = $services{$service};
- } else {
- return $self->set_error('EBADSERV');
- }
+ if (!$port) {
+ $port = $serv_port;
}
$self->{'timeout'} = $h{'TimeOut'} ? $h{'TimeOut'} : 5;
+ $self->{'localaddr'} = $h{'LocalAddr'};
$self->{'secret'} = $h{'Secret'};
$self->{'message_auth'} = $h{'Rfc3579MessageAuth'};
print STDERR "Using Radius server $host:$port\n" if $debug;
my %io_sock_args = (
- PeerAddr => $host,
- PeerPort => $port,
Type => SOCK_DGRAM,
Proto => 'udp',
- TimeOut => $self->{'timeout'}
+ Timeout => $self->{'timeout'},
+ LocalAddr => $self->{'localaddr'},
);
- if ($h{'LocalAddr'}) {
- $io_sock_args{'LocalAddr'} = $h{'LocalAddr'};
- }
- $self->{'sock'} = new IO::Socket::INET(%io_sock_args)
- or return $self->set_error('ESOCKETFAIL', $@);
-
+ if ($h{'NodeList'}) {
+ # contains resolved node list in text respresentation
+ $self->{'node_list_a'} = {};
+ foreach my $node_a (@{$h{'NodeList'}}) {
+ my ($n_host, $n_port) = split(/:/, $node_a);
+ if (!$n_port) {
+ $n_port = $serv_port;
+ }
+ my @hostinfo = gethostbyname($n_host);
+ if (!scalar(@hostinfo)) {
+ print STDERR "Can't resolve node hostname '$n_host': $! - skipping it!\n" if $debug;
+ next;
+ }
+ print STDERR "Adding ".inet_ntoa($hostinfo[4]).':'.$n_port." to node list.\n" if $debug;
+ # store splitted address to avoid additional parsing later
+ $self->{'node_list_a'}->{inet_ntoa($hostinfo[4]).':'.$n_port} =
+ [inet_ntoa($hostinfo[4]), $n_port];
+ }
+ if (!scalar(keys %{$self->{'node_list_a'}})) {
+ return $self->set_error('ESOCKETFAIL', 'Empty node list.');
+ }
+ if ($host) {
+ my @hostinfo = gethostbyname($host);
+ if (scalar(@hostinfo)) {
+ my $act_addr_a = inet_ntoa($hostinfo[4]).':'.$port;
+ if (exists($self->{'node_list_a'}->{$act_addr_a})) {
+ $self->{'node_addr_a'} = $act_addr_a;
+ } else {
+ print STDERR "'$host' doesn't exist in node list - ignoring it!\n" if $debug;
+ }
+ } else {
+ print STDERR "Can't resolve active node hostname '$host': $! - ignoring it!\n" if $debug;
+ }
+ }
+ } else {
+ my @hostinfo = gethostbyname($host);
+ if (!scalar(@hostinfo)) {
+ return $self->set_error('ESOCKETFAIL', "Can't resolve hostname '".$host."'.");
+ }
+ $self->{'node_addr_a'} = inet_ntoa($hostinfo[4]).':'.$port;
+ }
+ if ($host) {
+ $io_sock_args{'PeerAddr'} = $host;
+ $io_sock_args{'PeerPort'} = $port;
+ $self->{'sock'} = IO::Socket::INET->new(%io_sock_args)
+ or return $self->set_error('ESOCKETFAIL', $@);
+ }
$self;
}
@@ -155,7 +209,39 @@
print STDERR "Sending request:\n";
print STDERR HexDump($data);
}
- $self->{'sock'}->send($data) || $self->set_error('ESENDFAIL', $!);
+ my $res;
+ if (!defined($self->{'node_list_a'})) {
+ if ($debug) { print STDERR 'Sending request to: '.$self->{'node_addr_a'}."\n"; }
+ $res = $self->{'sock'}->send($data) || $self->set_error('ESENDFAIL', $!);
+ } else {
+ if (!$retransmit && defined($self->{'sock'})) {
+ if ($debug) { print STDERR 'Sending request to active node: '.$self->{'node_addr_a'}."\n"; }
+ $res = $self->{'sock'}->send($data) || $self->set_error('ESENDFAIL', $!);
+ } else {
+ if ($debug) { print STDERR "ReSending request to all cluster nodes.\n"; }
+ $self->{'sock'} = undef;
+ $self->{'sock_list'} = [];
+ my %io_sock_args = (
+ Type => SOCK_DGRAM,
+ Proto => 'udp',
+ Timeout => $self->{'timeout'},
+ LocalAddr => $self->{'localaddr'},
+ );
+ foreach my $node (keys %{$self->{'node_list_a'}}) {
+ if ($debug) { print STDERR 'Sending request to: '.$node."\n"; }
+ $io_sock_args{'PeerAddr'} = $self->{'node_list_a'}->{$node}->[0];
+ $io_sock_args{'PeerPort'} = $self->{'node_list_a'}->{$node}->[1];
+ my $new_sock = IO::Socket::INET->new(%io_sock_args)
+ or return $self->set_error('ESOCKETFAIL', $@);
+ $res = $new_sock->send($data) || $self->set_error('ESENDFAIL', $!);
+ if ($res) {
+ push @{$self->{'sock_list'}}, $new_sock;
+ }
+ $res ||= $res;
+ }
+ }
+ }
+ return $res;
}
sub recv_packet {
@@ -164,14 +250,47 @@
$self->set_error;
- $sh = new IO::Select($self->{'sock'}) or return $self->set_error('ESELECTFAIL');
- $sh->can_read($self->{'timeout'}) or return $self->set_error('ETIMEOUT', $!);
-
- $self->{'sock'}->recv ($data, 65536) or return $self->set_error('ERECVFAIL', $!);
- if ($debug) {
- print STDERR "Received response:\n";
+ if (defined($self->{'sock_list'}) && scalar(@{$self->{'sock_list'}})) {
+ $sh = IO::Select->new(@{$self->{'sock_list'}}) or return $self->set_error('ESELECTFAIL');
+ } elsif (defined($self->{'sock'})) {
+ $sh = IO::Select->new($self->{'sock'}) or return $self->set_error('ESELECTFAIL');
+ } else {
+ return $self->set_error('ESELECTFAIL');
+ }
+ my $timeout = $self->{'timeout'};
+ my @ready;
+ my $from_addr_n;
+ while ($timeout > 0){
+ my $start_time = time();
+ @ready = $sh->can_read($self->{'timeout'}) or return $self->set_error('ETIMEOUT', $!);
+ my $end_time = time();
+ $timeout -= $end_time - $start_time;
+ $from_addr_n = $ready[0]->recv($data, 65536);
+ if (defined($from_addr_n)) {
+ last;
+ }
+ if (!defined($from_addr_n) && !defined($self->{'sock_list'})) {
+ return $self->set_error('ERECVFAIL', $!);
+ }elsif ($debug) {
+ print STDERR "Received error/event from one peer:".$!."\n";
+ }
+ }
+
+ if ($debug) {
+ print STDERR "Received response:\n";
print STDERR HexDump($data);
}
+
+ if (defined($self->{'sock_list'})) {
+ # the sending attempt was 'broadcast' to all cluster nodes
+ # switcking to single active node
+ $self->{'sock'} = $ready[0];
+ $self->{'sock_list'} = undef;
+ my ($node_port, $node_iaddr) = sockaddr_in($from_addr_n);
+ $self->{'node_addr_a'} = inet_ntoa($node_iaddr).':'.$node_port;
+ if ($debug) { print STDERR "Registering new active peeer:".$self->{'node_addr_a'}."\n"; }
+ }
+
($type, $id, $length, $auth, $resp_attributes ) = unpack('C C n a16 a*', $data);
if ($detect_bad_id && defined($id) && ($id != $request_id) ) {
return $self->set_error('EBADID');
@@ -187,7 +306,7 @@
if ($a->{Code} == $RFC3579_MSG_AUTH_ATTR_ID) {
$rfc3579_msg_auth = $a->{Value};
last;
- }
+ }
}
if (defined($rfc3579_msg_auth)) {
$self->replace_attr_value($RFC3579_MSG_AUTH_ATTR_ID,
@@ -207,6 +326,7 @@
print STDERR "Received response with VALID RFC3579 Message-Authenticator.\n";
}
}
+
return $type;
}
@@ -254,6 +374,7 @@
$vendor = 'not defined';
}
$type = $dict_id{$vendor}{$id}{'type'} || '';
+ $value = undef;
if ($type eq "string") {
if ($id == 2 && $vendor eq 'not defined' ) {
$value = '<encrypted>';
@@ -279,6 +400,10 @@
push @values, "$subname = \"$subvalue\"";
}
$value = join("; ", @values);
+ } elsif ($type ne '') {
+ print STDERR "Unsupported type '$type' for attribute with id:'$id'.\n" if $debug;
+ } else {
+ print STDERR "Unknown type for attribute with id:'$id'. Check Radius dictionaries!\n" if $debug;
}
push (@a, { 'Name' => defined $dict_id{$vendor}{$id}{'name'} ? $dict_id{$vendor}{$id}{'name'} : $id,
@@ -291,71 +416,184 @@
return @a;
}
+# it used to be
+# $vendor = defined $a->{'Vendor'} ?
+# ( defined $dict_vendor_name{ $a->{'Vendor'} }{'id'} ? $dict_vendor_name{ $a->{'Vendor'} }{'id'} : int($a->{'Vendor'}) )
+# : ( defined $dict_name{$a->{'Name'}}{'vendor'}
+# ? $dict_vendor_name{ $dict_name{$a->{'Name'}}{'vendor'} }{'id'} : 'not defined' );
+
+sub vendorID ($) {
+ my ($attr) = @_;
+ if (defined $attr->{'Vendor'}) {
+ return defined $dict_vendor_name{ $attr->{'Vendor'} }{'id'} ? $dict_vendor_name{ $attr->{'Vendor'} }{'id'} : int($attr->{'Vendor'});
+ } else {
+ # look up vendor by attribute name
+ my $vendor_name = $dict_name{$attr->{'Name'}}{'vendor'};
+ my $vendor_id = defined ($dict_vendor_name{$vendor_name}{'id'}) ?
+ $dict_vendor_name{$vendor_name}{'id'} : 'not defined';
+ return $vendor_id;
+ }
+}
+
+sub encodeValue ($$$$$) {
+ my ($self, $vendor, $id, $type, $name, $value) = @_;
+
+ my $new_value;
+ $type = '' unless defined $type;
+ if ($type eq "string") {
+ $new_value = $value;
+ if ($id == 2 && $vendor eq 'not defined' ) {
+ $self->gen_authenticator();
+ $new_value = $self->encrypt_pwd($value);
+ }
+ $new_value = substr($new_value, 0, 253);
+ # if ($vendor eq WIMAX_VENDOR) {
+ # add the "continuation" byte
+ # but no support for attribute spli for now
+ # $value = pack('C', 0). substr($value, 0, 246);
+ # }
+ } elsif ($type eq "integer") {
+ my $enc_value;
+ if ( defined $dict_val{$id}{$value}{'id'} ) {
+ $enc_value = $dict_val{$id}{$value}{'id'};
+ } else {
+ $enc_value = int($value);
+ }
+ $new_value = pack('N', $enc_value);
+ } elsif ($type eq "byte") {
+ $new_value = pack('C', $value);
+ } elsif ($type eq "short") {
+ $new_value = pack('S', $value);
+ } elsif ($type eq "signed") {
+ # there should be something else, since it is signed
+ $new_value = pack('N', $value);
+ } elsif ($type eq "ipaddr") {
+ $new_value = inet_aton($value);
+ } elsif ($type eq "avpair") {
+ $new_value = $name.'='.$value;
+ $new_value = substr($new_value, 0, 253);
+# WiMAX
+ } elsif ($type eq "combo-ip") {
+ if ($value =~ m/^\d+\.\d+\.\d+.\d+/) {
+ # IPv4 address
+ $new_value = inet_aton($value);
+ } else {
+ # currently unsupported, use IPv4
+ $new_value = inet_aton($value);
+ }
+ } elsif ($type eq "octets") {
+ $new_value = '';
+ foreach my $c (split('', $value)) {
+ $new_value .= pack('C',ord($c));
+ }
+ } elsif ($type eq 'tlv' and ref($value)) {
+ $new_value = '';
+ foreach my $sub_attr (sort { $a->{'TLV_ID'} <=> $b->{'TLV_ID'} } @{$value}) {
+ my $sub_attr_name = $sub_attr->{'Name'};
+ my $sub_attr_type = defined $sub_attr->{'Type'} ? $sub_attr->{'Type'} : $dict_name{$sub_attr_name}{'type'};
+ my $sub_attr_id = defined $dict_name{$sub_attr_name}{'id'} ? $dict_name{$sub_attr_name}{'id'} : int($sub_attr_name);
+ my $sub_value = $self->encodeValue($vendor, $sub_attr_id, $sub_attr_type, $sub_attr->{'Name'}, $sub_attr->{'Value'});
+
+ if (defined($sub_value)) {
+ $new_value .= pack('C C', $sub_attr_id, length($sub_value)+2).$sub_value;
+ }
+ }
+ } elsif ($type eq 'sublist') {
+ # Digest attributes look like:
+ # Digest-Attributes = 'Method = "REGISTER"'
+ my $digest = $value;
+ my @pairs;
+ if (ref($digest)) {
+ next unless ref($digest) eq 'HASH';
+ foreach my $key (keys %{$digest}) {
+ push @pairs, [ $key => $digest->{$key} ];
+ }
+ } else {
+ # string
+ foreach my $z (split(/\"\; /, $digest)) {
+ my ($subname, $subvalue) = split(/\s+=\s+\"/, $z, 2);
+ $subvalue =~ s/\"$//;
+ push @pairs, [ $subname => $subvalue ];
+ }
+ }
+ $new_value = '';
+ foreach my $da (@pairs) {
+ my ($subname, $subvalue) = @{$da};
+ my $subid = $dict_val{$id}->{$subname}->{'id'};
+ next unless defined($subid);
+ $new_value .= pack('C C', $subid, length($subvalue) + 2) . $subvalue;
+ }
+ } else {
+ return;
+ }
+ return $new_value;
+}
+
sub add_attributes {
- my ($self, @a) = @_;
+ my ($self, @attr) = @_;
my ($a, $vendor, $id, $type, $value);
-
+ my @a = ();
$self->set_error;
+
+ # scan for WiMAX TLV
+ my %request_tlvs;
+ for my $attr (@attr) {
+ my $attr_name = $attr->{'Name'};
+ $id = defined $dict_name{$attr_name}{'id'} ? $dict_name{$attr_name}{'id'} : int($attr_name);
+ $vendor = vendorID($attr);
+ if (exists($dict_name{$attr_name}{'tlv'})) {
+ # this is a TLV attribute
+ my $tlv = $dict_name{$attr_name}{'tlv'};
+ # insert TLV type so we can order them by type inside of the container attribute
+ $attr->{'TLV_ID'} = $id;
+
+ unless (exists($request_tlvs{$tlv})) {
+ # this is a first attribute of this TLV in the request
+ my $new_attr = {
+ Name => $tlv, Type => 'tlv',
+ Value => [ $attr ]
+ };
+ $request_tlvs{$tlv} = $new_attr;
+ push @a, $new_attr;
+ } else {
+ my $tlv_list = $request_tlvs{$tlv}->{'Value'};
+ next unless ref($tlv_list); # should not happen
+ push @{$tlv_list}, $attr;
+ }
+ } else {
+ # normal attrbute, just copy over
+ push @a, $attr;
+ }
+ }
for $a (@a) {
$id = defined $dict_name{$a->{'Name'}}{'id'} ? $dict_name{$a->{'Name'}}{'id'} : int($a->{'Name'});
$type = defined $a->{'Type'} ? $a->{'Type'} : $dict_name{$a->{'Name'}}{'type'};
- $vendor = defined $a->{'Vendor'} ? ( defined $dict_vendor_name{ $a->{'Vendor'} }{'id'} ? $dict_vendor_name{ $a->{'Vendor'} }{'id'} : int($a->{'Vendor'}) ) : ( defined $dict_name{$a->{'Name'}}{'vendor'} ? $dict_vendor_name{ $dict_name{$a->{'Name'}}{'vendor'} }{'id'} : 'not defined' );
- if ($type eq "string") {
- $value = $a->{'Value'};
- if ($id == 2 && $vendor eq 'not defined' ) {
- $self->gen_authenticator();
- $value = $self->encrypt_pwd($value);
- }
- $value = substr($value, 0, 253);
- } elsif ($type eq "integer") {
- my $enc_value;
- if ( defined $dict_val{$id}{$a->{'Value'}}{'id'} ) {
- $enc_value = $dict_val{$id}{$a->{'Value'}}{'id'};
- } else {
- $enc_value = int($a->{'Value'});
- }
- $value = pack('N', $enc_value);
- } elsif ($type eq "ipaddr") {
- $value = inet_aton($a->{'Value'});
- } elsif ($type eq "avpair") {
- $value = $a->{'Name'}.'='.$a->{'Value'};
- $value = substr($value, 0, 253);
- } elsif ($type eq 'sublist') {
- # Digest attributes look like:
- # Digest-Attributes = 'Method = "REGISTER"'
- my $digest = $a->{'Value'};
- my @pairs;
- if (ref($digest)) {
- next unless ref($digest) eq 'HASH';
- foreach my $key (keys %{$digest}) {
- push @pairs, [ $key => $digest->{$key} ];
- }
- } else {
- # string
- foreach my $z (split(/\"\; /, $digest)) {
- my ($subname, $subvalue) = split(/\s+=\s+\"/, $z, 2);
- $subvalue =~ s/\"$//;
- push @pairs, [ $subname => $subvalue ];
- }
- }
- $value = '';
- foreach my $da (@pairs) {
- my ($subname, $subvalue) = @{$da};
- my $subid = $dict_val{$id}->{$subname}->{'id'};
- next unless defined($subid);
- $value .= pack('C C', $subid, length($subvalue) + 2) . $subvalue;
- }
- } else {
- next;
- }
- print STDERR "Adding attribute $a->{Name} ($id) with value '$a->{Value}'\n" if $debug;
+ $vendor = vendorID($a);
+
+ if ($vendor eq WIMAX_VENDOR) {
+ # WiMAX uses non-standard VSAs - include the continuation byte
+ }
+
+ unless (defined($value = $self->encodeValue($vendor, $id, $type, $a->{'Name'}, $a->{'Value'}))) {
+ print STDERR "Unable to encode attribute $a->{Name} ($id, $type, $vendor) with value '$a->{Value}'\n" if $debug;
+ next;
+ }
+ print STDERR "Adding attribute $a->{Name} ($id, $type, $vendor) with value '$a->{Value}'\n" if $debug;
if ( $vendor eq 'not defined' ) {
$self->{'attributes'} .= pack('C C', $id, length($value) + 2) . $value;
} else {
+ # VSA
+ # pack vendor-ID + vendor-type + vendor-length
+ if ($vendor eq WIMAX_VENDOR) {
+ # add continuation byte
+ $value = pack('N C C C', $vendor, $id, length($value) + 3, 0) . $value;
+ } else {
$value = pack('N C C', $vendor, $id, length($value) + 2) . $value;
- $self->{'attributes'} .= pack('C C', $dict_name{'Vendor-Specific'}{'id'}, length($value) + 2) . $value;
+ }
+ # add the normal RADIUS attribute header: type + length
+ $self->{'attributes'} .= pack('C C', $dict_name{'Vendor-Specific'}{'id'}, length($value) + 2) . $value;
}
}
return 1;
@@ -430,7 +668,10 @@
sub load_dictionary {
shift;
my ($file) = @_;
- my ($fh, $cmd, $name, $id, $type, $vendor);
+ my ($fh, $cmd, $name, $id, $type, $vendor, $dict_def_vendor, $tlv);
+
+ $dict_def_vendor = 'not defined';
+ undef($tlv);
unless ($file) {
$file = "/etc/raddb/dictionary";
@@ -445,25 +686,53 @@
chomp;
($cmd, $name, $id, $type, $vendor) = split(/\s+/);
next if (!$cmd || $cmd =~ /^#/);
- if (lc($cmd) eq 'attribute') {
- if( !$vendor ) {
- $dict_id{'not defined'}{$id}{'name'} = $name;
- $dict_id{'not defined'}{$id}{'type'} = $type;
+ $cmd = lc($cmd);
+ if ($cmd eq 'attribute') {
+ if ( !$vendor ) {
+ if ( defined($dict_def_vendor)) {
+ # Vendor was previously defined via BEGIN-VENDOR
+ $vendor = $dict_def_vendor;
+ } else {
+ $vendor = 'not defined';
+ }
+ }
+
+ $dict_name{$name}{'id'} = $id;
+ $dict_name{$name}{'vendor'} = $vendor if $vendor;
+ $dict_name{$name}{'type'} = $type;
+
+ if (defined($tlv)) {
+ # inside of a TLV definition
+ $dict_id{$vendor}{$id}{'tlv'} = $tlv;
+ $dict_name{$name}{'tlv'} = $tlv;
+ # IDs of TLVs are only unique within the master attribute, not in the dictionary
+ # so we have to use a composite key
+ $dict_id{$vendor}{$tlv.'/'.$id}{'name'} = $name;
+ $dict_id{$vendor}{$tlv.'/'.$id}{'type'} = $type;
} else {
- $dict_id{$vendor}{$id}{'name'} = $name;
- $dict_id{$vendor}{$id}{'type'} = $type;
+ $dict_id{$vendor}{$id}{'name'} = $name;
+ $dict_id{$vendor}{$id}{'type'} = $type;
}
- $dict_name{$name}{'id'} = $id;
- $dict_name{$name}{'type'} = $type;
- $dict_name{$name}{'vendor'} = $vendor if $vendor;
- } elsif (lc($cmd) eq 'value') {
+ } elsif ($cmd eq 'value') {
next unless exists($dict_name{$name});
$dict_val{$dict_name{$name}->{'id'}}->{$type}->{'name'} = $id;
$dict_val{$dict_name{$name}->{'id'}}->{$id}->{'id'} = $type;
- } elsif (lc($cmd) eq 'vendor') {
+ } elsif ($cmd eq 'vendor') {
$dict_vendor_name{$name}{'id'} = $id;
$dict_vendor_id{$id}{'name'} = $name;
- } elsif (lc($cmd) eq '$include') {
+ } elsif ($cmd eq 'begin-vendor') {
+ $dict_def_vendor = $name;
+ } elsif ($cmd eq 'end-vendor') {
+ $dict_def_vendor = 'not defined';
+ } elsif ($cmd eq 'begin-tlv') {
+ # FreeRADIUS dictionary syntax for defining WiMAX TLV
+ if (exists($dict_name{$name}) and $dict_name{$name}{'type'} eq 'tlv') {
+ # This name was previously defined as an attribute with TLV type
+ $tlv = $name;
+ }
+ } elsif ($cmd eq 'end-tlv') {
+ undef($tlv);
+ } elsif ($cmd eq '$include') {
my @path = split("/", $file);
pop @path; # remove the filename at the end
my $path = ( $name =~ /^\// ) ? $name : join("/", @path, $name);
@@ -471,7 +740,7 @@
}
}
$fh->close;
-
+# print Dumper(\%dict_name);
1;
}
@@ -521,8 +790,13 @@
if (!ref($self)) {
return $error_comment;
} else {
- return $self->{'error_comment'};
- }
+ return $self->{'error_comment'};
+ }
+}
+
+sub get_active_node {
+ my ($self) = @_;
+ return $self->{'node_addr_a'};
}
sub hmac_md5 {
@@ -596,7 +870,7 @@
=item new ( Host => HOST, Secret => SECRET [, TimeOut => TIMEOUT]
[,Service => SERVICE] [, Debug => Bool] [, LocalAddr => hostname[:port]]
- [,Rfc3579MessageAuth => Bool])
+ [,Rfc3579MessageAuth => Bool] [,NodeList= NodeListArrayRef])
Creates & returns a blessed reference to a Radius object, or undef on
failure. Error status may be retrieved with C<Authen::Radius::get_error>
@@ -616,6 +890,18 @@
Optional parameter C<Rfc3579MessageAuth> with a Perl "true" value turns on generating
of Message-Authenticator for Access-Request (RFC3579, section 3.2).
+
+Optional parameter C<NodeList> may contain a Perl reference to an array, containing a list of
+Radius Cluster nodes. Each nodes in the list can be specified using a hostname or IP (with an optional
+port number), i.e. 'radius1.mytel.com' or 'radius.myhost.com:1812'. Radius Cluster contains a set of Radius
+servers, at any given moment of time only one server is considered to be "active"
+(so requests are send to this server).
+How the active node is determined? Initially in addition to the C<NodeList>
+parameter you may supply the C<Host> parameter and specify which server should
+become the first active node. If this parameter is absent, or the current
+active node does not reply anymore, the process of "discovery" will be
+performed: a request will be sent to all nodes and the consecutive communication
+continues with the node, which will be the first to reply.
=back
@@ -658,6 +944,9 @@
C<Name> and C<Value> pairs will contain values as translated by the
dictionary (if one was loaded). The C<Code> and C<RawValue> pairs always
contain the raw attribute type & value as received from the server.
+If some attribute doesn't exist in dictionary or type of attribute not specified
+then corresponding C<Value> undefined and C<Name> set to attribute ID (C<Code>
+value).
=item clear_attributes
@@ -683,10 +972,10 @@
that failure may be due to a failed recv() or a bad Radius response
authenticator. Use C<get_error> to find out.
-If the DETECT_BAD_ID parameter is provided and contains a non-zero value, then
-mathing of packet indentifier is performed before authenticator check and EBADID
-error returned in case when packet indentifier from response doesn't match to
-request. If the DETECT_BAD_ID is not provided or contains zero value then
+If the DETECT_BAD_ID parameter is supplied and contains a non-zero value, then
+calculation of the packet indentifier is performed before authenticator check
+and EBADID error returned in case when packet indentifier from the response
+doesn't match to the request. If the DETECT_BAD_ID is not provided or contains zero value then
EBADAUTH returned in such case.
=item get_error
@@ -703,6 +992,11 @@
Returns the last error explanation for the current object. Error explanation
is generated by system call.
+
+=item get_active_node
+
+Returns currently active radius node in standard numbers-and-dots notation with
+port delimited by colon.
=back
Modified: trunk/libauthen-radius-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libauthen-radius-perl/debian/changelog?rev=66157&op=diff
==============================================================================
--- trunk/libauthen-radius-perl/debian/changelog (original)
+++ trunk/libauthen-radius-perl/debian/changelog Fri Dec 24 04:15:30 2010
@@ -1,8 +1,18 @@
-libauthen-radius-perl (0.17-2) UNRELEASED; urgency=low
+libauthen-radius-perl (0.20-1) UNRELEASED; urgency=low
+ [ Jonathan Yu ]
+ * New upstream release
+ + Improved support for CoA
+ + Adds support for dictionaries in FreeRADIUS format
+ + Partial support for WiMAX attributes
+ + Now supports multiple RADIUS servers (i.e. a cluster)
+ * Standards-Version 3.9.1 (no changes)
+ * Use new 3.0 (quilt) source format
+
+ [ gregor herrmann ]
* debian/rules: switch order of arguments to dh.
- -- gregor herrmann <gregoa at debian.org> Wed, 28 Jul 2010 14:32:11 -0400
+ -- Jonathan Yu <jawnsy at cpan.org> Thu, 23 Dec 2010 23:28:11 -0500
libauthen-radius-perl (0.17-1) unstable; urgency=low
Modified: trunk/libauthen-radius-perl/debian/control
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libauthen-radius-perl/debian/control?rev=66157&op=diff
==============================================================================
--- trunk/libauthen-radius-perl/debian/control (original)
+++ trunk/libauthen-radius-perl/debian/control Fri Dec 24 04:15:30 2010
@@ -1,11 +1,11 @@
Source: libauthen-radius-perl
Section: perl
Priority: extra
-Build-Depends: debhelper (>= 7.0.8), quilt (>= 0.46-7)
+Build-Depends: debhelper (>= 7)
Maintainer: Debian Perl Group <pkg-perl-maintainers at lists.alioth.debian.org>
Uploaders: Niko Tyni <ntyni at iki.fi>, gregor herrmann <gregoa at debian.org>,
Italo Valcy <italo at dcc.ufba.br>, Jonathan Yu <jawnsy at cpan.org>
-Standards-Version: 3.8.3
+Standards-Version: 3.9.1
Homepage: http://search.cpan.org/dist/RadiusPerl/
Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libauthen-radius-perl/
Vcs-Browser: http://svn.debian.org/viewsvn/pkg-perl/trunk/libauthen-radius-perl/
Added: trunk/libauthen-radius-perl/debian/source/format
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libauthen-radius-perl/debian/source/format?rev=66157&op=file
==============================================================================
--- trunk/libauthen-radius-perl/debian/source/format (added)
+++ trunk/libauthen-radius-perl/debian/source/format Fri Dec 24 04:15:30 2010
@@ -1,0 +1,1 @@
+3.0 (quilt)
Modified: trunk/libauthen-radius-perl/raddb/dictionary
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libauthen-radius-perl/raddb/dictionary?rev=66157&op=diff
==============================================================================
--- trunk/libauthen-radius-perl/raddb/dictionary (original)
+++ trunk/libauthen-radius-perl/raddb/dictionary Fri Dec 24 04:15:30 2010
@@ -36,6 +36,7 @@
$INCLUDE dictionary.xtradius
$INCLUDE dictionary.quintum
$INCLUDE dictionary.cisco
+$INCLUDE dictionary.rfc2869
#
# Following are the proper new names. Use these.
More information about the Pkg-perl-cvs-commits
mailing list