r51106 - in /branches/upstream/libauthen-radius-perl/current: Changes README Radius.pm test.pl
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Sun Jan 17 17:06:06 UTC 2010
Author: jawnsy-guest
Date: Sun Jan 17 17:05:22 2010
New Revision: 51106
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=51106
Log:
[svn-upgrade] Integrating new upstream version, libauthen-radius-perl (0.17)
Modified:
branches/upstream/libauthen-radius-perl/current/Changes
branches/upstream/libauthen-radius-perl/current/README
branches/upstream/libauthen-radius-perl/current/Radius.pm
branches/upstream/libauthen-radius-perl/current/test.pl
Modified: branches/upstream/libauthen-radius-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libauthen-radius-perl/current/Changes?rev=51106&op=diff
==============================================================================
--- branches/upstream/libauthen-radius-perl/current/Changes (original)
+++ branches/upstream/libauthen-radius-perl/current/Changes Sun Jan 17 17:05:22 2010
@@ -1,5 +1,13 @@
Revision history for Perl extension Radius.
+0.17 Thu Jan 14 09:20:00 2010
+ - Support for RFC3579 - Message-Authenticator
+
+0.16 Mon Dec 14 13:34:00 2009
+ - Generate random authenticators
+ - Support for CoA request (thanks to Oleg Gawriloff for the patch)
+ - Ability to specify the source IP/port for outgoing packets
+
0.15 Mon Oct 05 12:00:00 2009
- Bugfixes in error handling
Modified: branches/upstream/libauthen-radius-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libauthen-radius-perl/current/README?rev=51106&op=diff
==============================================================================
--- branches/upstream/libauthen-radius-perl/current/README (original)
+++ branches/upstream/libauthen-radius-perl/current/README Sun Jan 17 17:05:22 2010
@@ -1,4 +1,4 @@
-This is RadiusPerl version 0.14. RadiusPerl is a Perl 5 module (Radius.pm)
+This is RadiusPerl version 0.16. RadiusPerl is a Perl 5 module (Radius.pm)
which allows you to communicate with a Radius server from Perl. You can
just authenticate usernames/passwords via Radius, or comletely imitate
AAA requests and process server response.
@@ -17,9 +17,10 @@
I welcome any feedback, enhancements, new ideas etc. for this module. Please
send them to carl at miskatonic.inbe.net or to the andrew at portaone.com (current
-maintainer of the module).
+maintainer of the module). Please note that I am not able to provide services
+for debugging your scripts or RADIUS servers.
-RadiusPerl is (c)1997 Carl Declerck.
+\RadiusPerl is (c)1997 Carl Declerck.
See the Perl Artistic License 2.0
(http://www.perlfoundation.org/artistic_license_2_0) for copying and
Modified: branches/upstream/libauthen-radius-perl/current/Radius.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libauthen-radius-perl/current/Radius.pm?rev=51106&op=diff
==============================================================================
--- branches/upstream/libauthen-radius-perl/current/Radius.pm (original)
+++ branches/upstream/libauthen-radius-perl/current/Radius.pm Sun Jan 17 17:05:22 2010
@@ -7,12 +7,12 @@
# policy. #
# #
# Modified by Olexander Kapitanenko <kapitan at portaone.com>, #
-# Andrew Zhilenko <andrew at portaone.com>, 2002-2007. #
+# Andrew Zhilenko <andrew at portaone.com>, 2002-2010. #
# #
# See the file 'Changes' in the distrution archive. #
# #
#############################################################################
-# $Id: Radius.pm,v 1.21 2009/09/02 11:27:29 psv Exp $
+# $Id: Radius.pm,v 1.33 2010/01/14 08:20:50 andrew Exp $
package Authen::Radius;
@@ -30,9 +30,10 @@
@ISA = qw(Exporter);
@EXPORT = qw(ACCESS_REQUEST ACCESS_ACCEPT ACCESS_REJECT
- ACCOUNTING_REQUEST ACCOUNTING_RESPONSE ACCOUNTING_STATUS
- DISCONNECT_REQUEST);
-$VERSION = '0.15';
+ ACCOUNTING_REQUEST ACCOUNTING_RESPONSE ACCOUNTING_STATUS
+ DISCONNECT_REQUEST
+ COA_REQUEST);
+$VERSION = '0.17';
my (%dict_id, %dict_name, %dict_val, %dict_vendor_id, %dict_vendor_name );
my ($request_id) = $$ & 0xff; # probably better than starting from 0
@@ -55,6 +56,11 @@
use constant ACCOUNTING_RESPONSE => 5;
use constant ACCOUNTING_STATUS => 6;
use constant DISCONNECT_REQUEST => 40;
+use constant COA_REQUEST => 43;
+
+my $HMAC_MD5_BLCKSZ = 64;
+my $RFC3579_MSG_AUTH_ATTR_ID = 80;
+my $RFC3579_MSG_AUTH_ATTR_LEN = 18;
sub new {
my $class = shift;
@@ -65,7 +71,7 @@
bless $self, $class;
$self->set_error;
- $debug = $h{Debug};
+ $debug = $h{'Debug'};
return $self->set_error('ENOHOST') unless $h{'Host'};
($host, $port) = split(/:/, $h{'Host'});
@@ -80,20 +86,26 @@
if (exists($services{$service})) {
$port = $services{$service};
} else {
- return $self->set_error('EBADSERV');
+ return $self->set_error('EBADSERV');
}
}
$self->{'timeout'} = $h{'TimeOut'} ? $h{'TimeOut'} : 5;
$self->{'secret'} = $h{'Secret'};
+ $self->{'message_auth'} = $h{'Rfc3579MessageAuth'};
print STDERR "Using Radius server $host:$port\n" if $debug;
- $self->{'sock'} = new IO::Socket::INET(
+ my %io_sock_args = (
PeerAddr => $host,
PeerPort => $port,
Type => SOCK_DGRAM,
Proto => 'udp',
TimeOut => $self->{'timeout'}
- ) or return $self->set_error('ESOCKETFAIL', $@);
+ );
+ if ($h{'LocalAddr'}) {
+ $io_sock_args{'LocalAddr'} = $h{'LocalAddr'};
+ }
+ $self->{'sock'} = new IO::Socket::INET(%io_sock_args)
+ or return $self->set_error('ESOCKETFAIL', $@);
$self;
}
@@ -107,15 +119,38 @@
$request_id = ($request_id + 1) & 0xff;
}
$self->set_error;
- if ($type == ACCOUNTING_REQUEST || $type == DISCONNECT_REQUEST) {
- $self->{'authenticator'} = "\0" x 16;
- $self->{'authenticator'} =
- $self->calc_authenticator($type, $request_id, $length)
+ if ($type == ACCOUNTING_REQUEST || $type == DISCONNECT_REQUEST
+ || $type == COA_REQUEST) {
+ $self->{'authenticator'} = "\0" x 16;
+ $self->{'authenticator'} =
+ $self->calc_authenticator($type, $request_id, $length)
} else {
- $self->gen_authenticator unless defined $self->{'authenticator'};
- }
- $data = pack('C C n', $type, $request_id, $length)
+ $self->gen_authenticator unless defined $self->{'authenticator'};
+ }
+
+ if ($self->{'message_auth'} && ($type == ACCESS_REQUEST)) {
+ $length += $RFC3579_MSG_AUTH_ATTR_LEN;
+ $data = pack('C C n', $type, $request_id, $length)
+ . $self->{'authenticator'}
+ . $self->{'attributes'}
+ . pack('C C', $RFC3579_MSG_AUTH_ATTR_ID, $RFC3579_MSG_AUTH_ATTR_LEN)
+ . "\0" x ($RFC3579_MSG_AUTH_ATTR_LEN - 2);
+
+ my $msg_authenticator = $self->hmac_md5($data, $self->{'secret'});
+ $data = pack('C C n', $type, $request_id, $length)
+ . $self->{'authenticator'}
+ . $self->{'attributes'}
+ . pack('C C', $RFC3579_MSG_AUTH_ATTR_ID, $RFC3579_MSG_AUTH_ATTR_LEN)
+ . $msg_authenticator;
+ if ($debug) {
+ print STDERR "RFC3579 Message-Authenticator: "._ascii_to_hex($msg_authenticator).
+ " was added to request.\n";
+ }
+ } else {
+ $data = pack('C C n', $type, $request_id, $length)
. $self->{'authenticator'} . $self->{'attributes'};
+ }
+
if ($debug) {
print STDERR "Sending request:\n";
print STDERR HexDump($data);
@@ -139,7 +174,7 @@
}
($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');
+ return $self->set_error('EBADID');
}
if ($auth ne $self->calc_authenticator($type, $id, $length, $resp_attributes)) {
@@ -147,6 +182,31 @@
}
# rewrtite attributes only in case of valid response
$self->{'attributes'} = $resp_attributes;
+ my $rfc3579_msg_auth;
+ foreach my $a ($self->get_attributes()) {
+ 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,
+ "\0" x ($RFC3579_MSG_AUTH_ATTR_LEN - 2));
+ my $hmac_data = pack('C C n', $type, $id, $length)
+ . $self->{'authenticator'}
+ . $self->{'attributes'};
+ my $calc_hmac = $self->hmac_md5($hmac_data, $self->{'secret'});
+ if ($calc_hmac ne $rfc3579_msg_auth) {
+ if ($debug) {
+ print STDERR "Received response with INVALID RFC3579 Message-Authenticator.\n";
+ print STDERR 'Received '._ascii_to_hex($rfc3579_msg_auth)."\n";
+ print STDERR 'Calculated '._ascii_to_hex($calc_hmac)."\n";
+ }
+ return $self->set_error('EBADAUTH');
+ } elsif ($debug) {
+ print STDERR "Received response with VALID RFC3579 Message-Authenticator.\n";
+ }
+ }
return $type;
}
@@ -213,10 +273,10 @@
my ($subid, $subvalue, $sublength, @values);
$value = ''; my $subrawvalue = $rawvalue;
while (length($subrawvalue)) {
- ($subid, $sublength, $subrawvalue) = unpack('C C a*', $subrawvalue);
- ($subvalue, $subrawvalue) = unpack('a' . ($sublength - 2) . ' a*', $subrawvalue);
- my $subname = $dict_val{$id}->{$subid}->{'name'};
- push @values, "$subname = \"$subvalue\"";
+ ($subid, $sublength, $subrawvalue) = unpack('C C a*', $subrawvalue);
+ ($subvalue, $subrawvalue) = unpack('a' . ($sublength - 2) . ' a*', $subrawvalue);
+ my $subname = $dict_val{$id}->{$subid}->{'name'};
+ push @values, "$subname = \"$subvalue\"";
}
$value = join("; ", @values);
}
@@ -263,7 +323,7 @@
$value = $a->{'Name'}.'='.$a->{'Value'};
$value = substr($value, 0, 253);
} elsif ($type eq 'sublist') {
- # Digest attributes look like:
+ # Digest attributes look like:
# Digest-Attributes = 'Method = "REGISTER"'
my $digest = $a->{'Value'};
my @pairs;
@@ -301,6 +361,28 @@
return 1;
}
+sub replace_attr_value {
+ my ($self, $id, $value) = @_;
+ my $length = length($self->{'attributes'});
+ my $done = 0;
+ my $cur_pos = 0;
+ while ($cur_pos < $length) {
+ my ($cur_id, $cur_len) = unpack('C C', substr($self->{'attributes'}, $cur_pos, 2));
+ if ($cur_id == $id) {
+ if (length($value) != ($cur_len - 2)) {
+ if ($debug) {
+ print STDERR "Trying to replace attribute ($id) with value which has different length\n";
+ }
+ last;
+ }
+ substr($self->{'attributes'}, $cur_pos + 2, $cur_len - 2, $value);
+ $done = 1;
+ last;
+ }
+ $cur_pos += $cur_len;
+ }
+ return $done;
+}
sub calc_authenticator {
my ($self, $type, $id, $length, $attributes) = @_;
@@ -311,8 +393,8 @@
$hdr = pack('C C n', $type, $id, $length);
$ct = Digest::MD5->new;
$ct->add ($hdr, $self->{'authenticator'},
- (defined($attributes)) ? $attributes : $self->{'attributes'},
- $self->{'secret'});
+ (defined($attributes)) ? $attributes : $self->{'attributes'},
+ $self->{'secret'});
$ct->digest();
}
@@ -321,12 +403,9 @@
my ($ct);
$self->set_error;
-
- $ct = Digest::MD5->new;
- # the following could be improved a lot
- $ct->add (sprintf("%08x%04x", time, $$), $self->{'attributes'} || '');
-
- $self->{'authenticator'} = $ct->digest();
+ sub rint { int rand(2 ** 32 - 1) };
+ $self->{'authenticator'} =
+ pack "L4", rint(), rint(), rint(), rint();
}
sub encrypt_pwd {
@@ -398,20 +477,20 @@
sub set_error {
my ($self, $error, $comment) = @_;
- $@ = undef;
+ $@ = undef;
$radius_error = $self->{'error'} = (defined($error) ? $error : 'ENONE');
- $error_comment = $self->{'error_comment'} = (defined($comment) ? $comment : '');
+ $error_comment = $self->{'error_comment'} = (defined($comment) ? $comment : '');
undef;
}
sub get_error {
my ($self) = @_;
- if (!ref($self)) {
- return $radius_error;
- } else {
- return $self->{'error'};
- }
+ if (!ref($self)) {
+ return $radius_error;
+ } else {
+ return $self->{'error'};
+ }
}
sub strerror {
@@ -430,21 +509,49 @@
'EBADID', 'response to unknown request'
);
- if (!ref($self)) {
+ if (!ref($self)) {
return $errors{$radius_error};
- }
+ }
return $errors{ (defined($error) ? $error : $self->{'error'} ) };
}
sub error_comment {
my ($self) = @_;
- if (!ref($self)) {
- return $error_comment;
- } else {
+ if (!ref($self)) {
+ return $error_comment;
+ } else {
return $self->{'error_comment'};
- }
-}
+ }
+}
+
+sub hmac_md5 {
+ my ($self, $data, $key) = @_;
+ my $ct = Digest::MD5->new;
+
+ if (length($key) > $HMAC_MD5_BLCKSZ) {
+ $ct->add($key);
+ $key = $ct->digest();
+ }
+ my $ipad = $key ^ ("\x36" x $HMAC_MD5_BLCKSZ);
+ my $opad = $key ^ ("\x5c" x $HMAC_MD5_BLCKSZ);
+ $ct->reset();
+ $ct->add($ipad, $data);
+ my $digest1 = $ct->digest();
+ $ct->reset();
+ $ct->add($opad, $digest1);
+ return $ct->digest();
+}
+
+sub _ascii_to_hex {
+ my ($string) = @_;
+ my $hex_res = '';
+ foreach my $cur_chr (unpack('C*',$string)) {
+ $hex_res .= sprintf("%02X ", $cur_chr);
+ }
+ return $hex_res;
+}
+
1;
__END__
@@ -487,7 +594,9 @@
=over 4
-=item new ( Host => HOST, Secret => SECRET [, TimeOut => TIMEOUT] [,Service => SERVICE] [, Debug => Bool])
+=item new ( Host => HOST, Secret => SECRET [, TimeOut => TIMEOUT]
+ [,Service => SERVICE] [, Debug => Bool] [, LocalAddr => hostname[:port]]
+ [,Rfc3579MessageAuth => Bool])
Creates & returns a blessed reference to a Radius object, or undef on
failure. Error status may be retrieved with C<Authen::Radius::get_error>
@@ -502,6 +611,12 @@
Optional parameter C<Debug> with a Perl "true" value turns on debugging
(verbose mode).
+Optional parameter C<LocalAddr> may contain local IP/host bind address from
+which RADIUS packets are sent.
+
+Optional parameter C<Rfc3579MessageAuth> with a Perl "true" value turns on generating
+of Message-Authenticator for Access-Request (RFC3579, section 3.2).
+
=back
=head1 METHODS
@@ -513,12 +628,12 @@
Loads the definitions in the specified Radius dictionary file (standard
Livingston radiusd format). Tries to load 'C</etc/raddb/dictionary>' when no
argument is specified, or dies. NOTE: you need to load valid dictionary
-if you plan to send Radius requests with other attributes than just
+if you plan to send RADIUS requests with attributes other than just
C<User-Name>/C<Password>.
=item check_pwd ( USERNAME, PASSWORD [,NASIPADDRESS] )
-Checks with the Radius server if the specified C<PASSWORD> is valid for user
+Checks with the RADIUS server if the specified C<PASSWORD> is valid for user
C<USERNAME>. Unless C<NASIPADDRESS> is specified, the script will attempt
to determine it's local IP address (IP address for the RADIUS socket) and
this value will be placed in the NAS-IP-Address attribute.
@@ -554,7 +669,7 @@
sends it to the server with a Request type of C<REQUEST_TYPE>. Exported
C<REQUEST_TYPE> methods are 'C<ACCESS_REQUEST>', 'C<ACCESS_ACCEPT>' ,
'C<ACCESS_REJECT>', 'C<ACCOUNTING_REQUEST>', 'C<ACCOUNTING_RESPONSE>',
-and 'C<DISCONNECT_REQUEST>'.
+'C<DISCONNECT_REQUEST>' and 'C<COA_REQUEST>'.
Returns the number of bytes sent, or undef on failure.
If the RETRANSMIT parameter is provided and contains a non-zero value, then
@@ -594,8 +709,10 @@
=head1 AUTHOR
Carl Declerck <carl at miskatonic.inbe.net> - original design
-Alexander Kapitanenko <kapitan at portaone.com> and Andrew Zhilenko <andrew at portaone.com> - later modifications.
-Andrew Zhilenko <andrew at portaone.com> is a current module's maintaner at CPAN.
+Alexander Kapitanenko <kapitan at portaone.com> and Andrew
+Zhilenko <andrew at portaone.com> - later modifications.
+
+Andrew Zhilenko <andrew at portaone.com> is the current module's maintaner at CPAN.
=cut
Modified: branches/upstream/libauthen-radius-perl/current/test.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libauthen-radius-perl/current/test.pl?rev=51106&op=diff
==============================================================================
--- branches/upstream/libauthen-radius-perl/current/test.pl (original)
+++ branches/upstream/libauthen-radius-perl/current/test.pl Sun Jan 17 17:05:22 2010
@@ -1,4 +1,4 @@
-# $Id: test.pl,v 1.7 2004/12/18 04:38:30 andrew Exp $
+# $Id: test.pl,v 1.8 2009/12/31 13:18:47 psv Exp $
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
@@ -7,7 +7,7 @@
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
-BEGIN {print "1..4\n";}
+BEGIN {print "1..5\n";}
END {print "not ok 1\n" unless $loaded;}
use Authen::Radius;
$loaded = 1;
@@ -42,6 +42,21 @@
}
}
+sub hex_to_ascii
+{
+ ## Convert each two-digit hex number back to an ASCII character.
+ (my $str = shift) =~ s/([a-fA-F0-9]{2})/chr(hex $1)/eg;
+ return $str;
+}
+my $key = "Jefe";
+my $data = "what do ya want for nothing?";
+my $etalon_digest = hex_to_ascii("750c783e6ab0b503eaa86e310a5db738");
+my $digest = Authen::Radius::hmac_md5(undef, $data, $key);
+if ($etalon_digest eq $digest) {
+ print "ok 5\n";
+} else {
+ print "not ok 5\n";
+}
exit;
More information about the Pkg-perl-cvs-commits
mailing list