1############################################################################# 2# # 3# Radius Client module for Perl 5 # 4# # 5# Written by Carl Declerck <carl@miskatonic.inbe.net>, (c)1997 # 6# All Rights Reserved. See the Perl Artistic License 2.0 # 7# for copying & usage policy. # 8# # 9# Modified by Olexander Kapitanenko, Andrew Zhilenko # 10# and the rest of PortaOne team (c) 2002-2013 # 11# Current maintainer's contact: perl-radius@portaone.com # 12# # 13# See the file 'Changes' in the distribution archive. # 14# # 15############################################################################# 16 17package Authen::Radius; 18 19use strict; 20use warnings; 21use v5.10; 22use FileHandle; 23use IO::Socket; 24use IO::Select; 25use Digest::MD5; 26use Data::Dumper; 27use Data::HexDump; 28use Net::IP qw(ip_bintoip ip_compress_address ip_expand_address ip_iptobin); 29use Time::HiRes qw(time); 30 31use vars qw($VERSION @ISA @EXPORT); 32 33require Exporter; 34 35@ISA = qw(Exporter); 36@EXPORT = qw(ACCESS_REQUEST ACCESS_ACCEPT ACCESS_REJECT ACCESS_CHALLENGE 37 ACCOUNTING_REQUEST ACCOUNTING_RESPONSE ACCOUNTING_STATUS 38 DISCONNECT_REQUEST DISCONNECT_ACCEPT DISCONNECT_REJECT 39 STATUS_SERVER 40 COA_REQUEST COA_ACCEPT COA_REJECT COA_ACK COA_NAK); 41 42$VERSION = '0.32'; 43 44my (%dict_id, %dict_name, %dict_val, %dict_vendor_id, %dict_vendor_name ); 45my ($request_id) = $$ & 0xff; # probably better than starting from 0 46my ($radius_error, $error_comment) = ('ENONE', ''); 47my $debug = 0; 48 49use constant WIMAX_VENDOR => '24757'; 50use constant WIMAX_CONTINUATION_BIT => 0b10000000; 51 52use constant NO_VENDOR => 'not defined'; 53 54use constant DEFAULT_DICTIONARY => '/usr/local/share/Authen-Radius/dictionary'; 55 56# 57# we'll need to predefine these attr types so we can do simple password 58# verification without having to load a dictionary 59# 60 61# ATTRIBUTE User-Name 1 string 62# ATTRIBUTE User-Password 2 string 63# ATTRIBUTE NAS-IP-Address 4 ipaddr 64$dict_id{ NO_VENDOR() }{1}{type} = 'string'; 65$dict_id{ NO_VENDOR() }{2}{type} = 'string'; 66$dict_id{ NO_VENDOR() }{4}{type} = 'ipaddr'; 67 68# ATTRIBUTE Vendor-Specific 26 octets 69use constant ATTR_VENDOR => 26; 70 71use constant ACCESS_REQUEST => 1; 72use constant ACCESS_ACCEPT => 2; 73use constant ACCESS_REJECT => 3; 74use constant ACCOUNTING_REQUEST => 4; 75use constant ACCOUNTING_RESPONSE => 5; 76use constant ACCOUNTING_STATUS => 6; 77use constant ACCESS_CHALLENGE => 11; 78use constant STATUS_SERVER => 12; 79use constant DISCONNECT_REQUEST => 40; 80use constant DISCONNECT_ACCEPT => 41; 81use constant DISCONNECT_REJECT => 42; 82use constant COA_REQUEST => 43; 83use constant COA_ACCEPT => 44; 84use constant COA_ACK => 44; 85use constant COA_REJECT => 45; 86use constant COA_NAK => 45; 87 88my $HMAC_MD5_BLCKSZ = 64; 89my $RFC3579_MSG_AUTH_ATTR_ID = 80; 90my $RFC3579_MSG_AUTH_ATTR_LEN = 18; 91my %SERVICES = ( 92 'radius' => 1812, 93 'radacct' => 1813, 94 'radius-acct' => 1813, 95); 96 97sub new { 98 my $class = shift; 99 my %h = @_; 100 my ($host, $port, $service); 101 my $self = {}; 102 103 bless $self, $class; 104 105 $self->set_error; 106 $debug = $h{'Debug'}; 107 108 if (!$h{'Host'} && !$h{'NodeList'}) { 109 return $self->set_error('ENOHOST'); 110 } 111 112 $service = $h{'Service'} ? $h{'Service'} : 'radius'; 113 my $serv_port = getservbyname($service, 'udp'); 114 if (!$serv_port && !exists($SERVICES{$service})) { 115 return $self->set_error('EBADSERV'); 116 } elsif (!$serv_port) { 117 $serv_port = $SERVICES{$service}; 118 } 119 120 $self->{'timeout'} = $h{'TimeOut'} ? $h{'TimeOut'} : 5; 121 $self->{'localaddr'} = $h{'LocalAddr'}; 122 $self->{'secret'} = $h{'Secret'}; 123 $self->{'message_auth'} = $h{'Rfc3579MessageAuth'}; 124 125 if ($h{'NodeList'}) { 126 # contains resolved node list in text representation 127 $self->{'node_list_a'} = {}; 128 foreach my $node_a (@{$h{'NodeList'}}) { 129 my ($n_host, $n_port) = split(/:/, $node_a); 130 $n_port ||= $serv_port; 131 my @hostinfo = gethostbyname($n_host); 132 if (!scalar(@hostinfo)) { 133 print STDERR "Can't resolve node hostname '$n_host': $! - skipping it!\n" if $debug; 134 next; 135 } 136 137 my $ip = inet_ntoa($hostinfo[4]); 138 print STDERR "Adding ".$ip.':'.$n_port." to node list.\n" if $debug; 139 # store split address to avoid additional parsing later 140 $self->{'node_list_a'}->{$ip.':'.$n_port} = [$ip, $n_port]; 141 } 142 143 if (!scalar(keys %{$self->{'node_list_a'}})) { 144 return $self->set_error('ESOCKETFAIL', 'Empty node list.'); 145 } 146 } 147 148 if ($h{'Host'}) { 149 ($host, $port) = split(/:/, $h{'Host'}); 150 $port ||= $serv_port; 151 print STDERR "Using Radius server $host:$port\n" if $debug; 152 153 my @hostinfo = gethostbyname($host); 154 if (!scalar(@hostinfo)) { 155 if ($self->{'node_list_a'}) { 156 print STDERR "Can't resolve hostname '$host'\n" if $debug; 157 return $self; 158 } 159 160 return $self->set_error('ESOCKETFAIL', "Can't resolve hostname '".$host."'."); 161 } 162 163 my $ip = inet_ntoa($hostinfo[4]); 164 165 # if Host used with NodeList - it must be from the list 166 if ($self->{'node_list_a'} && !exists($self->{'node_list_a'}->{$ip.':'.$port})) { 167 print STDERR "'$host' doesn't exist in node list - ignoring it!\n" if $debug; 168 return $self; 169 } 170 171 # set as active node 172 $self->{'node_addr_a'} = $ip.':'.$port; 173 174 my %io_sock_args = ( 175 Type => SOCK_DGRAM, 176 Proto => 'udp', 177 Timeout => $self->{'timeout'}, 178 LocalAddr => $self->{'localaddr'}, 179 PeerAddr => $host, 180 PeerPort => $port, 181 ); 182 $self->{'sock'} = IO::Socket::INET->new(%io_sock_args) 183 or return $self->set_error('ESOCKETFAIL', $@); 184 } 185 186 return $self; 187} 188 189sub send_packet { 190 my ($self, $type, $retransmit) = @_; 191 192 $self->{attributes} //= ''; 193 194 my $data; 195 my $length = 20 + length($self->{attributes}); 196 197 if (!$retransmit) { 198 $request_id = ($request_id + 1) & 0xff; 199 } 200 201 $self->set_error; 202 if ($type == ACCOUNTING_REQUEST || $type == DISCONNECT_REQUEST || $type == COA_REQUEST) { 203 $self->{authenticator} = "\0" x 16; 204 $self->{authenticator} = $self->calc_authenticator($type, $request_id, $length); 205 } else { 206 $self->gen_authenticator unless defined $self->{authenticator}; 207 } 208 209 if (($self->{message_auth} && ($type == ACCESS_REQUEST)) || ($type == STATUS_SERVER)) { 210 $length += $RFC3579_MSG_AUTH_ATTR_LEN; 211 $data = pack('C C n', $type, $request_id, $length) 212 . $self->{authenticator} 213 . $self->{attributes} 214 . pack('C C', $RFC3579_MSG_AUTH_ATTR_ID, $RFC3579_MSG_AUTH_ATTR_LEN) 215 . "\0" x ($RFC3579_MSG_AUTH_ATTR_LEN - 2); 216 217 my $msg_authenticator = $self->hmac_md5($data, $self->{secret}); 218 $data = pack('C C n', $type, $request_id, $length) 219 . $self->{authenticator} 220 . $self->{attributes} 221 . pack('C C', $RFC3579_MSG_AUTH_ATTR_ID, $RFC3579_MSG_AUTH_ATTR_LEN) 222 . $msg_authenticator; 223 if ($debug) { 224 print STDERR "RFC3579 Message-Authenticator: "._ascii_to_hex($msg_authenticator)." was added to request.\n"; 225 } 226 } else { 227 $data = pack('C C n', $type, $request_id, $length) 228 . $self->{authenticator} 229 . $self->{attributes}; 230 } 231 232 if ($debug) { 233 print STDERR "Sending request:\n"; 234 print STDERR HexDump($data); 235 } 236 my $res; 237 if (!defined($self->{'node_list_a'})) { 238 if ($debug) { print STDERR 'Sending request to: '.$self->{'node_addr_a'}."\n"; } 239 $res = $self->{'sock'}->send($data) || $self->set_error('ESENDFAIL', $!); 240 } else { 241 if (!$retransmit && defined($self->{'sock'})) { 242 if ($debug) { print STDERR 'Sending request to active node: '.$self->{'node_addr_a'}."\n"; } 243 $res = $self->{'sock'}->send($data) || $self->set_error('ESENDFAIL', $!); 244 } else { 245 if ($debug) { print STDERR "ReSending request to all cluster nodes.\n"; } 246 $self->{'sock'} = undef; 247 $self->{'sock_list'} = []; 248 my %io_sock_args = ( 249 Type => SOCK_DGRAM, 250 Proto => 'udp', 251 Timeout => $self->{'timeout'}, 252 LocalAddr => $self->{'localaddr'}, 253 ); 254 foreach my $node (keys %{$self->{'node_list_a'}}) { 255 if ($debug) { print STDERR 'Sending request to: '.$node."\n"; } 256 $io_sock_args{'PeerAddr'} = $self->{'node_list_a'}->{$node}->[0]; 257 $io_sock_args{'PeerPort'} = $self->{'node_list_a'}->{$node}->[1]; 258 my $new_sock = IO::Socket::INET->new(%io_sock_args) 259 or return $self->set_error('ESOCKETFAIL', $@); 260 $res = $new_sock->send($data) || $self->set_error('ESENDFAIL', $!); 261 if ($res) { 262 push @{$self->{'sock_list'}}, $new_sock; 263 } 264 $res ||= $res; 265 } 266 } 267 } 268 return $res; 269} 270 271sub recv_packet { 272 my ($self, $detect_bad_id) = @_; 273 my ($data, $type, $id, $length, $auth, $sh, $resp_attributes); 274 275 $self->set_error; 276 277 if (defined($self->{'sock_list'}) && scalar(@{$self->{'sock_list'}})) { 278 $sh = IO::Select->new(@{$self->{'sock_list'}}) or return $self->set_error('ESELECTFAIL'); 279 } elsif (defined($self->{'sock'})) { 280 $sh = IO::Select->new($self->{'sock'}) or return $self->set_error('ESELECTFAIL'); 281 } else { 282 return $self->set_error('ESELECTFAIL'); 283 } 284 my $timeout = $self->{'timeout'}; 285 my @ready; 286 my $from_addr_n; 287 my ($start_time, $end_time); 288 while ($timeout > 0){ 289 $start_time = time(); 290 @ready = $sh->can_read($timeout) or return $self->set_error('ETIMEOUT', $!); 291 $end_time = time(); 292 $timeout -= $end_time - $start_time; 293 $from_addr_n = $ready[0]->recv($data, 65536); 294 if (defined($from_addr_n)) { 295 last; 296 } 297 if (!defined($from_addr_n) && !defined($self->{'sock_list'})) { 298 return $self->set_error('ERECVFAIL', $!); 299 }elsif ($debug) { 300 print STDERR "Received error/event from one peer:".$!."\n"; 301 } 302 } 303 304 if ($debug) { 305 print STDERR "Received response:\n"; 306 print STDERR HexDump($data); 307 } 308 309 if (defined($self->{'sock_list'})) { 310 # the sending attempt was 'broadcast' to all cluster nodes 311 # switching to single active node 312 $self->{'sock'} = $ready[0]; 313 $self->{'sock_list'} = undef; 314 my ($node_port, $node_iaddr) = sockaddr_in($from_addr_n); 315 $self->{'node_addr_a'} = inet_ntoa($node_iaddr).':'.$node_port; 316 if ($debug) { print STDERR "Registering new active peeer:".$self->{'node_addr_a'}."\n"; } 317 } 318 319 ($type, $id, $length, $auth, $resp_attributes ) = unpack('C C n a16 a*', $data); 320 if ($detect_bad_id && defined($id) && ($id != $request_id) ) { 321 return $self->set_error('EBADID'); 322 } 323 324 if ($auth ne $self->calc_authenticator($type, $id, $length, $resp_attributes)) { 325 return $self->set_error('EBADAUTH'); 326 } 327 # rewrite attributes only in case of a valid response 328 $self->{'attributes'} = $resp_attributes; 329 my $rfc3579_msg_auth; 330 foreach my $a ($self->get_attributes()) { 331 if ($a->{Code} == $RFC3579_MSG_AUTH_ATTR_ID) { 332 $rfc3579_msg_auth = $a->{Value}; 333 last; 334 } 335 } 336 if (defined($rfc3579_msg_auth)) { 337 $self->replace_attr_value($RFC3579_MSG_AUTH_ATTR_ID, 338 "\0" x ($RFC3579_MSG_AUTH_ATTR_LEN - 2)); 339 my $hmac_data = pack('C C n', $type, $id, $length) 340 . $self->{'authenticator'} 341 . $self->{'attributes'}; 342 my $calc_hmac = $self->hmac_md5($hmac_data, $self->{'secret'}); 343 if ($calc_hmac ne $rfc3579_msg_auth) { 344 if ($debug) { 345 print STDERR "Received response with INVALID RFC3579 Message-Authenticator.\n"; 346 print STDERR 'Received '._ascii_to_hex($rfc3579_msg_auth)."\n"; 347 print STDERR 'Calculated '._ascii_to_hex($calc_hmac)."\n"; 348 } 349 return $self->set_error('EBADAUTH'); 350 } elsif ($debug) { 351 print STDERR "Received response with VALID RFC3579 Message-Authenticator.\n"; 352 } 353 } 354 355 return $type; 356} 357 358sub check_pwd { 359 my ($self, $name, $pwd, $nas) = @_; 360 361 $nas = eval { $self->{'sock'}->sockhost() } unless defined($nas); 362 $self->clear_attributes; 363 $self->add_attributes ( 364 { Name => 1, Value => $name, Type => 'string' }, 365 { Name => 2, Value => $pwd, Type => 'string' }, 366 { Name => 4, Value => $nas || '127.0.0.1', Type => 'ipaddr' } 367 ); 368 369 $self->send_packet(ACCESS_REQUEST); 370 my $rcv = $self->recv_packet(); 371 return (defined($rcv) and $rcv == ACCESS_ACCEPT); 372} 373 374sub clear_attributes { 375 my ($self) = @_; 376 377 $self->set_error; 378 379 delete $self->{'attributes'}; 380 delete $self->{'authenticator'}; 381 382 1; 383} 384 385sub _decode_enum { 386 my ( $name, $value) = @_; 387 388 if ( defined $value && defined( $dict_val{$name}{$value} ) ) { 389 $value = $dict_val{$name}{$value}{name}; 390 } 391 392 return $value; 393} 394 395sub _decode_string { 396 my ( $self, $vendor, $id, $name, $value, $has_tag ) = @_; 397 398 if ( $id == 2 && $vendor eq NO_VENDOR ) { 399 return '<encrypted>'; 400 } 401 402 if ($has_tag) { 403 my $tag = unpack('C', substr($value, 0, 1)); 404 # rfc2868 section-3.3 405 # If the Tag field is greater than 0x1F, it SHOULD be 406 # interpreted as the first byte of the following String field. 407 if ($tag > 31) { 408 print STDERR "Attribute $name has tag value $tag bigger than 31 - ignoring it!\n" if $debug; 409 $tag = undef; 410 } 411 else { 412 # cut extracted tag 413 substr($value, 0, 1, ''); 414 } 415 return ($value, $tag); 416 } 417 418 return ($value); 419} 420 421sub _decode_integer { 422 my ( $self, $vendor, $id, $name, $value, $has_tag ) = @_; 423 424 my $tag; 425 if ($has_tag) { 426 $tag = unpack('C', substr($value, 0, 1)); 427 if ($tag > 31) { 428 print STDERR "Attribute $name has tag value $tag bigger than 31 - ignoring it!\n" if $debug; 429 $tag = undef; 430 } 431 else { 432 substr($value, 0, 1, "\x00"); 433 } 434 } 435 436 $value = unpack('N', $value); 437 return (_decode_enum( $name, $value), $tag); 438} 439 440sub _decode_ipaddr { 441 my ( $self, $vendor, $id, $name, $value ) = @_; 442 return inet_ntoa($value); 443} 444 445sub _decode_ipv6addr { 446 my ( $self, $vendor, $id, $name, $value ) = @_; 447 448 my $binary_val = unpack( 'B*', $value ); 449 if ($binary_val) { 450 my $ip_val = ip_bintoip( $binary_val, 6 ); 451 if ($ip_val) { 452 return ip_compress_address( $ip_val, 6 ); 453 } 454 } 455 456 return undef; 457} 458 459sub _decode_ipv6prefix { 460 my ( $self, $vendor, $id, $name, $value ) = @_; 461 462 my ( $skip, $prefix_len, $prefix_val ) = unpack( 'CCB*', $value ); 463 if ( defined($prefix_len) && $prefix_len < 128 ) { 464 my $ip_val = ip_bintoip( $prefix_val, 6 ); 465 if ($ip_val) { 466 $value = ip_compress_address( $ip_val, 6 ); 467 if ( defined $value ) { 468 return "$value/$prefix_len"; 469 } 470 } 471 } 472 473 return undef; 474} 475 476sub _decode_ifid { 477 my ( $self, $vendor, $id, $name, $value ) = @_; 478 479 my @shorts = unpack( 'S>S>S>S>', $value ); 480 if ( @shorts == 4 ) { 481 return sprintf( '%x:%x:%x:%x', @shorts ); 482 } 483 484 return undef; 485} 486 487sub _decode_integer64 { 488 my ( $self, $vendor, $id, $name, $value ) = @_; 489 return unpack( 'Q>', $value ); 490} 491 492sub _decode_avpair { 493 my ( $self, $vendor, $id, $name, $value ) = @_; 494 495 $value =~ s/^.*=//; 496 return $value; 497} 498 499sub _decode_sublist { 500 my ( $self, $vendor, $id, $name, $value ) = @_; 501 502 # never got a chance to test it, since it seems that Digest attributes only come from clients 503 504 my ( $subid, $subvalue, $sublength, @values ); 505 while ( length($value) ) { 506 ( $subid, $sublength, $value ) = unpack( 'CCa*', $value ); 507 ( $subvalue, $value ) = unpack( 'a' . ( $sublength - 2 ) . ' a*', $value ); 508 push @values, "$dict_val{$name}{$subid}{name} = \"$subvalue\""; 509 } 510 511 return join( '; ', @values ); 512} 513 514sub _decode_octets { 515 my ( $self, $vendor, $id, $name, $value ) = @_; 516 return '0x'.unpack("H*", $value); 517} 518 519my %decoder = ( 520 # RFC2865 521 string => \&_decode_string, 522 integer => \&_decode_integer, 523 ipaddr => \&_decode_ipaddr, 524 date => \&_decode_integer, 525 time => \&_decode_integer, 526 octets => \&_decode_octets, 527 # RFC3162 528 ipv6addr => \&_decode_ipv6addr, 529 ipv6prefix => \&_decode_ipv6prefix, 530 ifid => \&_decode_ifid, 531 # RFC6929 532 integer64 => \&_decode_integer64, 533 # internal 534 avpair => \&_decode_avpair, 535 sublist => \&_decode_sublist, 536); 537 538sub _decode_value { 539 my ( $self, $vendor, $id, $type, $name, $value, $has_tag ) = @_; 540 541 if ( defined $type ) { 542 if ( exists $decoder{$type} ) { 543 my ($decoded, $tag) = $decoder{$type}->( $self, $vendor, $id, $name, $value, $has_tag ); 544 return wantarray ? ($decoded, $tag) : $decoded; 545 } 546 else { 547 if ($debug) { 548 print {*STDERR} "Unsupported type '$type' for attribute with id: '$id'.\n"; 549 } 550 } 551 } 552 else { 553 if ($debug) { 554 print {*STDERR} "Unknown type for attribute with id: '$id'. Check RADIUS dictionaries!\n"; 555 } 556 } 557 558 return undef; 559} ## end sub _decode_value 560 561sub get_attributes { 562 my $self = shift; 563 my ( $vendor, $vendor_id, $name, $id, $length, $value, $type, $rawvalue, $tag, @a ); 564 my $attrs = $self->{attributes} // ''; 565 566 $self->set_error; 567 568 while ( length($attrs) ) { 569 ( $id, $length, $attrs ) = unpack( 'CCa*', $attrs ); 570 ( $rawvalue, $attrs ) = unpack( 'a' . ( $length - 2 ) . 'a*', $attrs ); 571 572 if ( $id == ATTR_VENDOR ) { 573 ( $vendor_id, $id, $length, $rawvalue ) = unpack( 'NCCa*', $rawvalue ); 574 $vendor = $dict_vendor_id{$vendor_id}{name} // $vendor_id; 575 } 576 else { 577 $vendor = NO_VENDOR; 578 } 579 580 my $r = $dict_id{ $vendor }{ $id } // {}; 581 582 $name = $r->{name} // $id; 583 $type = $r->{type}; 584 585 ($value, $tag) = $self->_decode_value( $vendor, $id, $type, $name, $rawvalue, $r->{has_tag} ); 586 587 push( 588 @a, { 589 Name => $tag ? $name . ':' . $tag : $name, 590 AttrName => $name, 591 Code => $id, 592 Value => $value, 593 RawValue => $rawvalue, 594 Vendor => $vendor, 595 Tag => $tag, 596 } 597 ); 598 } ## end while ( length($attrs) ) 599 600 return @a; 601} ## end sub get_attributes 602 603# returns vendor's ID or 'not defined' string for the attribute 604sub vendorID ($) { 605 my ($attr) = @_; 606 if (defined $attr->{'Vendor'}) { 607 return ($dict_vendor_name{ $attr->{'Vendor'} }{'id'} // int($attr->{'Vendor'})); 608 } elsif (exists $dict_name{$attr->{'Name'}} ) { 609 # look up vendor by attribute name 610 my $vendor_name = $dict_name{$attr->{'Name'}}{'vendor'} or return NO_VENDOR; 611 my $vendor_id = $dict_vendor_name{$vendor_name}{'id'} or return NO_VENDOR; 612 return $vendor_id; 613 } 614 return NO_VENDOR; 615} 616 617sub _encode_enum { 618 my ( $name, $value, $format ) = @_; 619 620 if ( defined( $dict_val{$name}{$value} ) ) { 621 $value = $dict_val{$name}{$value}{id}; 622 } 623 624 return pack( $format, int($value) ); 625} 626 627sub _encode_string { 628 my ( $self, $vendor, $id, $name, $value, $tag ) = @_; 629 630 if ( $id == 2 && $vendor eq NO_VENDOR ) { 631 $self->gen_authenticator(); 632 return $self->encrypt_pwd($value); 633 } 634 635 # if ($vendor eq WIMAX_VENDOR) { 636 # # add the "continuation" byte 637 # # but no support for attribute splitting for now 638 # return pack('C', 0) . substr($_[0], 0, 246); 639 # } 640 641 if (defined $tag) { 642 $value = pack('C', $tag) . $value; 643 } 644 645 return $value; 646} 647 648sub _encode_integer { 649 my ( $self, $vendor, $id, $name, $value, $tag ) = @_; 650 $value = _encode_enum( $name, $value, 'N' ); 651 if (defined $tag) { 652 # tag added to 1st byte, not extending the value length 653 substr($value, 0, 1, pack('C', $tag) ); 654 } 655 return $value; 656} 657 658sub _encode_ipaddr { 659 my ( $self, $vendor, $id, $name, $value ) = @_; 660 return inet_aton($value); 661} 662 663sub _encode_ipv6addr { 664 my ( $self, $vendor, $id, $name, $value ) = @_; 665 666 my $expanded_val = ip_expand_address( $value, 6 ); 667 if ($expanded_val) { 668 $value = ip_iptobin( $expanded_val, 6 ); 669 if ( defined $value ) { 670 return pack( 'B*', $value ); 671 } 672 } 673 674 return undef; 675} 676 677sub _encode_ipv6prefix { 678 my ( $self, $vendor, $id, $name, $value ) = @_; 679 680 my ( $prefix_val, $prefix_len ) = split( /\//, $value, 2 ); 681 if ( defined $prefix_len ) { 682 my $expanded_val = ip_expand_address( $prefix_val, 6 ); 683 if ($expanded_val) { 684 $value = ip_iptobin( $expanded_val, 6 ); 685 if ( defined $value ) { 686 return pack( 'CCB*', 0, $prefix_len, $value ); 687 } 688 } 689 } 690 691 return undef; 692} 693 694sub _encode_ifid { 695 my ( $self, $vendor, $id, $name, $value ) = @_; 696 697 my @shorts = map { hex() } split( /:/, $value, 4 ); 698 if ( @shorts == 4 ) { 699 return pack( 'S>S>S>S>', @shorts ); 700 } 701 702 return undef; 703} 704 705sub _encode_integer64 { 706 my ( $self, $vendor, $id, $name, $value ) = @_; 707 return pack( 'Q>', $value ); 708} 709 710sub _encode_avpair { 711 my ( $self, $vendor, $id, $name, $value ) = @_; 712 713 $value = "$name=$value"; 714 return substr( $value, 0, 253 ); 715} 716 717sub _encode_sublist { 718 my ( $self, $vendor, $id, $name, $value ) = @_; 719 720 # Digest attributes look like: 721 # Digest-Attributes = 'Method = "REGISTER"' 722 723 my @pairs; 724 if ( ref($value) ) { 725 # hashref 726 return undef if ( ref($value) ne 'HASH' ); 727 foreach my $key ( keys %{$value} ) { 728 push @pairs, [ $key => $value->{$key} ]; 729 } 730 } 731 else { 732 # string 733 foreach my $z ( split( /\"\; /, $value ) ) { 734 my ( $subname, $subvalue ) = split( /\s+=\s+\"/, $z, 2 ); 735 $subvalue =~ s/\"$//; 736 push @pairs, [ $subname => $subvalue ]; 737 } 738 } 739 740 $value = ''; 741 foreach my $da (@pairs) { 742 my ( $subname, $subvalue ) = @{$da}; 743 my $subid = $dict_val{$name}->{$subname}->{id}; 744 next if ( !defined($subid) ); 745 $value .= pack( 'CC', $subid, length($subvalue) + 2 ) . $subvalue; 746 } 747 748 return $value; 749} ## end sub _encode_sublist 750 751sub _encode_octets { 752 my ( $self, $vendor, $id, $name, $value ) = @_; 753 754 my $new_value = ''; 755 foreach my $c ( split( //, $value ) ) { 756 $new_value .= pack( 'C', ord($c) ); 757 } 758 759 return $new_value; 760} 761 762sub _encode_byte { 763 my ( $self, $vendor, $id, $name, $value ) = @_; 764 return _encode_enum( $name, $value, 'C' ); 765} 766 767sub _encode_short { 768 my ( $self, $vendor, $id, $name, $value ) = @_; 769 return _encode_enum( $name, $value, 'n' ); 770} 771 772sub _encode_signed { 773 my ( $self, $vendor, $id, $name, $value ) = @_; 774 return pack( 'l>', $value ); 775} 776 777sub _encode_comboip { 778 my ( $self, $vendor, $id, $name, $value ) = @_; 779 780 if ( $value =~ m/^\d+\.\d+\.\d+.\d+/ ) { 781 # IPv4 address 782 return inet_aton($value); 783 } 784 785 # currently unsupported, use IPv4 786 return undef; 787} 788 789sub _encode_tlv { 790 my ( $self, $vendor, $id, $name, $value ) = @_; 791 792 return undef if ( ref($value) ne 'ARRAY' ); 793 794 my $new_value = ''; 795 foreach my $sattr ( sort { $a->{TLV_ID} <=> $b->{TLV_ID} } @{$value} ) { 796 my $sattr_name = $sattr->{Name}; 797 my $sattr_type = $sattr->{Type} // $dict_name{$sattr_name}{type}; 798 my $sattr_id = $dict_name{$sattr_name}{id} // int($sattr_name); 799 800 my $svalue = $self->_encode_value( $vendor, $sattr_id, $sattr_type, $sattr_name, $sattr->{Value} ); 801 if ( defined $svalue ) { 802 $new_value .= pack( 'CC', $sattr_id, length($svalue) + 2 ) . $svalue; 803 } 804 } 805 806 return $new_value; 807} 808 809my %encoder = ( 810 # RFC2865 811 string => \&_encode_string, 812 integer => \&_encode_integer, 813 ipaddr => \&_encode_ipaddr, 814 date => \&_encode_integer, 815 time => \&_encode_integer, 816 # RFC3162 817 ipv6addr => \&_encode_ipv6addr, 818 ipv6prefix => \&_encode_ipv6prefix, 819 ifid => \&_encode_ifid, 820 # RFC6929 821 integer64 => \&_encode_integer64, 822 # internal 823 avpair => \&_encode_avpair, 824 sublist => \&_encode_sublist, 825 octets => \&_encode_octets, 826 # WiMAX 827 byte => \&_encode_byte, 828 short => \&_encode_short, 829 signed => \&_encode_signed, 830 'combo-ip' => \&_encode_comboip, 831 tlv => \&_encode_tlv, 832); 833 834sub _encode_value { 835 my ( $self, $vendor, $id, $type, $name, $value, $tag ) = @_; 836 837 if ( defined $type ) { 838 if ( exists $encoder{$type} ) { 839 return $encoder{$type}->( $self, $vendor, $id, $name, $value, $tag ); 840 } 841 else { 842 if ($debug) { 843 print {*STDERR} "Unsupported type '$type' for attribute with name: '$name'.\n"; 844 } 845 } 846 } 847 else { 848 if ($debug) { 849 print {*STDERR} "Unknown type for attribute with name: '$name'. Check RADIUS dictionaries!\n"; 850 } 851 } 852 853 return undef; 854} ## end sub _encode_value 855 856sub add_attributes { 857 my ($self, @attr) = @_; 858 my ($a, $vendor, $id, $type, $value, $need_tag); 859 my @a = (); 860 $self->set_error; 861 862 # scan for WiMAX TLV 863 my %request_tlvs; 864 for my $attr (@attr) { 865 my $attr_name = $attr->{Name}; 866 # tagged attribute in 'name:tag' form 867 if ($attr_name =~ /^([\w-]+):(\d+)$/) { 868 $attr->{Name} = $1; 869 $attr->{Tag} = $2; 870 $attr_name = $1; 871 } 872 873 if (! exists $dict_name{$attr_name}) { 874 # no dictionaries loaded, $attr_name must be attribute ID 875 push @a, $attr; 876 next; 877 } 878 879 $id = $dict_name{$attr_name}{id} // int($attr_name); 880 $vendor = vendorID($attr); 881 if (exists($dict_name{$attr_name}{'tlv'})) { 882 # this is a TLV attribute 883 my $tlv = $dict_name{$attr_name}{'tlv'}; 884 # insert TLV type so we can order them by type inside of the container attribute 885 $attr->{'TLV_ID'} = $id; 886 887 unless (exists($request_tlvs{$tlv})) { 888 # this is a first attribute of this TLV in the request 889 my $new_attr = { 890 Name => $tlv, Type => 'tlv', 891 Value => [ $attr ] 892 }; 893 $request_tlvs{$tlv} = $new_attr; 894 push @a, $new_attr; 895 } else { 896 my $tlv_list = $request_tlvs{$tlv}->{'Value'}; 897 next unless ref($tlv_list); # should not happen 898 push @{$tlv_list}, $attr; 899 } 900 } else { 901 # normal attribute, just copy over 902 push @a, $attr; 903 } 904 } 905 906 for $a (@a) { 907 if (exists $dict_name{ $a->{Name} }) { 908 my $def = $dict_name{ $a->{Name} }; 909 $id = $def->{id}; 910 # allow to override Type (why?) 911 $type = $a->{Type} // $def->{type}; 912 $need_tag = $a->{Tag} // $def->{has_tag}; 913 } 914 else { 915 # ID must be a value for Name 916 $id = int($a->{Name}); 917 $type = $a->{Type}; 918 $need_tag = $a->{Tag}; 919 } 920 921 # we do not support 0 value for Tag 922 if ($need_tag) { 923 $a->{Tag} //= 0; 924 if ($a->{Tag} < 1 || $a->{Tag} > 31) { 925 print STDERR "Tag value is out of range [1..31] for attribute ".$a->{Name} if $debug; 926 next; 927 } 928 } 929 930 $vendor = vendorID($a); 931 if ($vendor eq WIMAX_VENDOR) { 932 #TODO WiMAX uses non-standard VSAs - include the continuation byte 933 } 934 935 unless (defined($value = $self->_encode_value($vendor, $id, $type, $a->{Name}, $a->{Value}, $a->{Tag}))) { 936 printf STDERR "Unable to encode attribute %s (%s, %s, %s) with value '%s'\n", 937 $a->{Name}, $id // '?', $type // '?', $vendor, $a->{Value} 938 if $debug; 939 next; 940 } 941 942 if ($debug) { 943 printf STDERR "Adding attribute %s (%s, %s, %s) with value '%s'%s\n", 944 $a->{Name}, $id, $type, $vendor, 945 $a->{Value}, 946 ($a->{Tag} ? sprintf(' (tag:%d)', $a->{Tag}) : ''); 947 } 948 949 if ( $vendor eq NO_VENDOR ) { 950 # tag already included in $value, if any 951 $self->{'attributes'} .= pack('C C', $id, length($value) + 2) . $value; 952 } else { 953 # VSA 954 # pack vendor-ID + vendor-type + vendor-length 955 if ($vendor eq WIMAX_VENDOR) { 956 # add continuation byte 957 $value = pack('N C C C', $vendor, $id, length($value) + 3, 0) . $value; 958 } else { 959 # tag already included in $value, if any 960 $value = pack('N C C', $vendor, $id, length($value) + 2) . $value; 961 } 962 963 # add the normal RADIUS attribute header: type + length 964 $self->{'attributes'} .= pack('C C', ATTR_VENDOR, length($value) + 2) . $value; 965 } 966 } 967 968 return 1; 969} 970 971sub replace_attr_value { 972 my ($self, $id, $value) = @_; 973 my $length = length($self->{'attributes'}); 974 my $done = 0; 975 my $cur_pos = 0; 976 while ($cur_pos < $length) { 977 my ($cur_id, $cur_len) = unpack('C C', substr($self->{'attributes'}, $cur_pos, 2)); 978 if ($cur_id == $id) { 979 if (length($value) != ($cur_len - 2)) { 980 if ($debug) { 981 print STDERR "Trying to replace attribute ($id) with value which has different length\n"; 982 } 983 last; 984 } 985 substr($self->{'attributes'}, $cur_pos + 2, $cur_len - 2, $value); 986 $done = 1; 987 last; 988 } 989 $cur_pos += $cur_len; 990 } 991 return $done; 992} 993 994sub calc_authenticator { 995 my ($self, $type, $id, $length, $attributes) = @_; 996 my ($hdr, $ct); 997 998 $self->set_error; 999 1000 $hdr = pack('C C n', $type, $id, $length); 1001 $ct = Digest::MD5->new; 1002 $ct->add ($hdr, $self->{'authenticator'}, 1003 (defined($attributes)) ? $attributes : $self->{'attributes'}, 1004 $self->{'secret'}); 1005 $ct->digest(); 1006} 1007 1008sub gen_authenticator { 1009 my ($self) = @_; 1010 my ($ct); 1011 1012 $self->set_error; 1013 sub rint { int rand(2 ** 32 - 1) }; 1014 $self->{'authenticator'} = 1015 pack "L4", rint(), rint(), rint(), rint(); 1016} 1017 1018sub encrypt_pwd { 1019 my ($self, $pwd) = @_; 1020 my ($i, $ct, @pwdp, @encrypted); 1021 1022 $self->set_error; 1023 $ct = Digest::MD5->new(); 1024 1025 my $non_16 = length($pwd) % 16; 1026 $pwd .= "\0" x (16 - $non_16) if $non_16; 1027 @pwdp = unpack('a16' x (length($pwd) / 16), $pwd); 1028 for $i (0..$#pwdp) { 1029 my $authent = $i == 0 ? $self->{'authenticator'} : $encrypted[$i - 1]; 1030 $ct->add($self->{'secret'}, $authent); 1031 $encrypted[$i] = $pwdp[$i] ^ $ct->digest(); 1032 } 1033 return join('',@encrypted); 1034} 1035use vars qw(%included_files); 1036 1037sub load_dictionary { 1038 shift; 1039 my $file = shift; 1040 # options, format => {freeradius|gnuradius|default} 1041 my %opt = @_; 1042 my $freeradius_dict = (($opt{format} // '') eq 'freeradius') ? 1 : 0; 1043 my $gnuradius_dict = (($opt{format} // '') eq 'gnuradius') ? 1 : 0; 1044 1045 my ($cmd, $name, $id, $type, $vendor, $tlv, $extra, $has_tag); 1046 my $dict_def_vendor = NO_VENDOR; 1047 1048 $file ||= DEFAULT_DICTIONARY; 1049 1050 # prevent infinite loop in the include files 1051 return undef if exists($included_files{$file}); 1052 $included_files{$file} = 1; 1053 my $fh = FileHandle->new($file) or die "Can't open dictionary '$file' ($!)\n"; 1054 printf STDERR "Loading dictionary %s using %s format\n", $file, ($freeradius_dict ? 'FreeRADIUS' : 'default') if $debug; 1055 1056 while (my $line = <$fh>) { 1057 chomp $line; 1058 next if ($line =~ /^\s*$/ || $line =~ /^#/); 1059 1060 if ($freeradius_dict) { 1061 # ATTRIBUTE name number type [options] 1062 ($cmd, $name, $id, $type, $extra) = split(/\s+/, $line); 1063 $vendor = undef; 1064 } 1065 elsif ($gnuradius_dict) { 1066 # ATTRIBUTE name number type [vendor] [flags] 1067 ($cmd, $name, $id, $type, $vendor, undef) = split(/\s+/, $line); 1068 # flags looks like '[LR-R-R]=P' 1069 $vendor = NO_VENDOR if ($vendor && ($vendor eq '-' || $vendor =~ /^\[/)); 1070 } 1071 else { 1072 # our default format (Livingston radius) 1073 ($cmd, $name, $id, $type, $vendor) = split(/\s+/, $line); 1074 } 1075 1076 $cmd = lc($cmd); 1077 if ($cmd eq 'attribute') { 1078 # Vendor was previously defined via BEGIN-VENDOR 1079 $vendor ||= $dict_def_vendor // NO_VENDOR; 1080 1081 $has_tag = 0; 1082 if ($extra && $extra !~ /^#/) { 1083 my(@p) = split(/,/, $extra); 1084 $has_tag = grep /has_tag/, @p; 1085 } 1086 1087 $dict_name{ $name } = { 1088 id => $id, 1089 type => $type, 1090 vendor => $vendor, 1091 has_tag => $has_tag, 1092 }; 1093 1094 if (defined($tlv)) { 1095 # inside of a TLV definition 1096 $dict_id{$vendor}{$id}{'tlv'} = $tlv; 1097 $dict_name{$name}{'tlv'} = $tlv; 1098 # IDs of TLVs are only unique within the master attribute, not in the dictionary 1099 # so we have to use a composite key 1100 $dict_id{$vendor}{$tlv.'/'.$id}{'name'} = $name; 1101 $dict_id{$vendor}{$tlv.'/'.$id}{'type'} = $type; 1102 } else { 1103 $dict_id{$vendor}{$id} = { 1104 name => $name, 1105 type => $type, 1106 has_tag => $has_tag, 1107 }; 1108 } 1109 } elsif ($cmd eq 'value') { 1110 next unless exists($dict_name{$name}); 1111 $dict_val{$name}->{$type}->{'name'} = $id; 1112 $dict_val{$name}->{$id}->{'id'} = $type; 1113 } elsif ($cmd eq 'vendor') { 1114 $dict_vendor_name{$name}{'id'} = $id; 1115 $dict_vendor_id{$id}{'name'} = $name; 1116 } elsif ($cmd eq 'begin-vendor') { 1117 $dict_def_vendor = $name; 1118 if (! $freeradius_dict) { 1119 # force format 1120 $freeradius_dict = 1; 1121 print STDERR "Detected BEGIN-VENDOR, switch to FreeRADIUS dictionary format\n" if $debug; 1122 } 1123 } elsif ($cmd eq 'end-vendor') { 1124 $dict_def_vendor = NO_VENDOR; 1125 } elsif ($cmd eq 'begin-tlv') { 1126 # FreeRADIUS dictionary syntax for defining WiMAX TLV 1127 if (exists($dict_name{$name}) and $dict_name{$name}{'type'} eq 'tlv') { 1128 # This name was previously defined as an attribute with TLV type 1129 $tlv = $name; 1130 } 1131 } elsif ($cmd eq 'end-tlv') { 1132 undef($tlv); 1133 } elsif ($cmd eq '$include') { 1134 my @path = split("/", $file); 1135 pop @path; # remove the filename at the end 1136 my $path = ( $name =~ /^\// ) ? $name : join("/", @path, $name); 1137 load_dictionary('', $path, %opt); 1138 } 1139 } 1140 $fh->close; 1141# print Dumper(\%dict_name); 1142 1; 1143} 1144 1145sub clear_dictionary { 1146 shift; 1147 %dict_id = (); 1148 %dict_name = (); 1149 %dict_val = (); 1150 %dict_vendor_id = (); 1151 %dict_vendor_name = (); 1152 %included_files = (); 1153} 1154 1155sub set_timeout { 1156 my ($self, $timeout) = @_; 1157 1158 $self->{'timeout'} = $timeout; 1159 $self->{'sock'}->timeout($timeout) if (defined $self->{'sock'}); 1160 if (defined $self->{'sock_list'}) { 1161 foreach my $sock (@{$self->{'sock_list'}}) { 1162 $sock->timeout($timeout); 1163 } 1164 } 1165 1166 1; 1167} 1168 1169sub set_error { 1170 my ($self, $error, $comment) = @_; 1171 $@ = undef; 1172 $radius_error = $self->{'error'} = (defined($error) ? $error : 'ENONE'); 1173 $error_comment = $self->{'error_comment'} = (defined($comment) ? $comment : ''); 1174 undef; 1175} 1176 1177sub get_error { 1178 my ($self) = @_; 1179 1180 if (!ref($self)) { 1181 return $radius_error; 1182 } else { 1183 return $self->{'error'}; 1184 } 1185} 1186 1187sub strerror { 1188 my ($self, $error) = @_; 1189 1190 my %errors = ( 1191 'ENONE', 'none', 1192 'ESELECTFAIL', 'select creation failed', 1193 'ETIMEOUT', 'timed out waiting for packet', 1194 'ESOCKETFAIL', 'socket creation failed', 1195 'ENOHOST', 'no host specified', 1196 'EBADAUTH', 'bad response authenticator', 1197 'ESENDFAIL', 'send failed', 1198 'ERECVFAIL', 'receive failed', 1199 'EBADSERV', 'unrecognized service', 1200 'EBADID', 'response to unknown request' 1201 ); 1202 1203 if (!ref($self)) { 1204 return $errors{$radius_error}; 1205 } 1206 return $errors{ (defined($error) ? $error : $self->{'error'} ) }; 1207} 1208 1209sub error_comment { 1210 my ($self) = @_; 1211 1212 if (!ref($self)) { 1213 return $error_comment; 1214 } else { 1215 return $self->{'error_comment'}; 1216 } 1217} 1218 1219sub get_active_node { 1220 my ($self) = @_; 1221 return $self->{'node_addr_a'}; 1222} 1223 1224sub hmac_md5 { 1225 my ($self, $data, $key) = @_; 1226 my $ct = Digest::MD5->new; 1227 1228 if (length($key) > $HMAC_MD5_BLCKSZ) { 1229 $ct->add($key); 1230 $key = $ct->digest(); 1231 } 1232 my $ipad = $key ^ ("\x36" x $HMAC_MD5_BLCKSZ); 1233 my $opad = $key ^ ("\x5c" x $HMAC_MD5_BLCKSZ); 1234 $ct->reset(); 1235 $ct->add($ipad, $data); 1236 my $digest1 = $ct->digest(); 1237 $ct->reset(); 1238 $ct->add($opad, $digest1); 1239 return $ct->digest(); 1240} 1241 1242sub _ascii_to_hex { 1243 my ($string) = @_; 1244 my $hex_res = ''; 1245 foreach my $cur_chr (unpack('C*',$string)) { 1246 $hex_res .= sprintf("%02X ", $cur_chr); 1247 } 1248 return $hex_res; 1249} 1250 1251 12521; 1253__END__ 1254 1255=head1 NAME 1256 1257Authen::Radius - provide simple Radius client facilities 1258 1259=head1 SYNOPSIS 1260 1261 use Authen::Radius; 1262 1263 $r = new Authen::Radius(Host => 'myserver', Secret => 'mysecret'); 1264 print "auth result=", $r->check_pwd('myname', 'mypwd'), "\n"; 1265 1266 $r = new Authen::Radius(Host => 'myserver', Secret => 'mysecret'); 1267 Authen::Radius->load_dictionary(); 1268 $r->add_attributes ( 1269 { Name => 'User-Name', Value => 'myname' }, 1270 { Name => 'Password', Value => 'mypwd' }, 1271# RFC 2865 http://www.ietf.org/rfc/rfc2865.txt calls this attribute 1272# User-Password. Check your local RADIUS dictionary to find 1273# out which name is used on your system 1274# { Name => 'User-Password', Value => 'mypwd' }, 1275 { Name => 'h323-return-code', Value => '0' }, # Cisco AV pair 1276 { Name => 'Digest-Attributes', Value => { Method => 'REGISTER' } } 1277 ); 1278 $r->send_packet(ACCESS_REQUEST) and $type = $r->recv_packet(); 1279 print "server response type = $type\n"; 1280 for $a ($r->get_attributes()) { 1281 print "attr: name=$a->{'Name'} value=$a->{'Value'}\n"; 1282 } 1283 1284=head1 DESCRIPTION 1285 1286The C<Authen::Radius> module provides a simple class that allows you to 1287send/receive Radius requests/responses to/from a Radius server. 1288 1289=head1 CONSTRUCTOR 1290 1291=over 4 1292 1293=item new ( Host => HOST, Secret => SECRET [, TimeOut => TIMEOUT] 1294 [,Service => SERVICE] [, Debug => Bool] [, LocalAddr => hostname[:port]] 1295 [,Rfc3579MessageAuth => Bool] [,NodeList= NodeListArrayRef]) 1296 1297Creates & returns a blessed reference to a Radius object, or undef on 1298failure. Error status may be retrieved with C<Authen::Radius::get_error> 1299(errorcode) or C<Authen::Radius::strerror> (verbose error string). 1300 1301The default C<Service> is C<radius>, the alternative is C<radius-acct>. 1302If you do not specify port in the C<Host> as a C<hostname:port>, then port 1303specified in your F</etc/services> will be used. If there is nothing 1304there, and you did not specify port either then default is 1645 for 1305C<radius> and 1813 for C<radius-acct>. 1306 1307Optional parameter C<Debug> with a Perl "true" value turns on debugging 1308(verbose mode). 1309 1310Optional parameter C<LocalAddr> may contain local IP/host bind address from 1311which RADIUS packets are sent. 1312 1313Optional parameter C<Rfc3579MessageAuth> with a Perl "true" value turns on generating 1314of Message-Authenticator for Access-Request (RFC3579, section 3.2). 1315The Message-Authenticator is always generated for Status-Server packets. 1316 1317Optional parameter C<NodeList> may contain a Perl reference to an array, containing a list of 1318Radius Cluster nodes. Each nodes in the list can be specified using a hostname or IP (with an optional 1319port number), i.e. 'radius1.mytel.com' or 'radius.myhost.com:1812'. Radius Cluster contains a set of Radius 1320servers, at any given moment of time only one server is considered to be "active" 1321(so requests are send to this server). 1322How the active node is determined? Initially in addition to the C<NodeList> 1323parameter you may supply the C<Host> parameter and specify which server should 1324become the first active node. If this parameter is absent, or the current 1325active node does not reply anymore, the process of "discovery" will be 1326performed: a request will be sent to all nodes and the consecutive communication 1327continues with the node, which will be the first to reply. 1328 1329=back 1330 1331=head1 METHODS 1332 1333=over 4 1334 1335=item load_dictionary ( [ DICTIONARY ], [format => 'freeradius' | 'gnuradius'] ) 1336 1337Loads the definitions in the specified Radius dictionary file (standard 1338Livingston radiusd format). Tries to load C</usr/local/share/Authen-Radius/dictionary> when no 1339argument is specified, or dies. C<format> should be specified if dictionary has 1340other format (currently supported: FreeRADIUS and GNU Radius) 1341 1342NOTE: you need to load valid dictionary if you plan to send RADIUS requests 1343with attributes other than just C<User-Name>/C<Password>. 1344 1345=item check_pwd ( USERNAME, PASSWORD [,NASIPADDRESS] ) 1346 1347Checks with the RADIUS server if the specified C<PASSWORD> is valid for user 1348C<USERNAME>. Unless C<NASIPADDRESS> is specified, the script will attempt 1349to determine it's local IP address (IP address for the RADIUS socket) and 1350this value will be placed in the NAS-IP-Address attribute. 1351This method is actually a wrapper for subsequent calls to 1352C<clear_attributes>, C<add_attributes>, C<send_packet> and C<recv_packet>. It 1353returns 1 if the C<PASSWORD> is correct, or undef otherwise. 1354 1355=item add_attributes ( { Name => NAME, Value => VALUE [, Type => TYPE] [, Vendor => VENDOR] [, Tag => TAG ] }, ... ) 1356 1357Adds any number of Radius attributes to the current Radius object. Attributes 1358are specified as a list of anon hashes. They may be C<Name>d with their 1359dictionary name (provided a dictionary has been loaded first), or with 1360their raw Radius attribute-type values. The C<Type> pair should be specified 1361when adding attributes that are not in the dictionary (or when no dictionary 1362was loaded). Values for C<TYPE> can be 'C<string>', 'C<integer>', 'C<ipaddr>', 1363'C<ipv6addr>', 'C<ipv6prefix>', 'C<ifid>' or 'C<avpair>'. The C<VENDOR> may be 1364Vendor's name from the dictionary or their integer id. For tagged attributes 1365(RFC2868) tag can be specified in C<Name> using 'Name:Tag' format, or by 1366using C<Tag> pair. TAG value is expected to be an integer, within [1:31] range 1367(zero value isn't supported). 1368 1369 1370=item get_attributes 1371 1372Returns a list of references to anon hashes with the following key/value 1373pairs : { Name => NAME, Code => RAWTYPE, Value => VALUE, RawValue => 1374RAWVALUE, Vendor => VENDOR, Tag => TAG, AttrName => NAME }. Each hash 1375represents an attribute in the current object. The C<Name> and C<Value> pairs 1376will contain values as translated by the dictionary (if one was loaded). The 1377C<Code> and C<RawValue> pairs always contain the raw attribute type & value as 1378received from the server. If some attribute doesn't exist in dictionary or 1379type of attribute not specified then corresponding C<Value> undefined and 1380C<Name> set to attribute ID (C<Code> value). For tagged attribute (RFC2868), it 1381will include the tag into the C<NAME> as 'Name:Tag'. Original Name is stored in 1382C<AttrName>. Also value of tag is stored in C<Tag> (undef for non-tagged 1383attributes). 1384 1385=item clear_attributes 1386 1387Clears all attributes for the current object. 1388 1389=item send_packet ( REQUEST_TYPE, RETRANSMIT ) 1390 1391Packs up a Radius packet based on the current secret & attributes and 1392sends it to the server with a Request type of C<REQUEST_TYPE>. Exported 1393C<REQUEST_TYPE> methods are C<ACCESS_REQUEST>, C<ACCESS_ACCEPT>, 1394C<ACCESS_REJECT>, C<ACCESS_CHALLENGE>, C<ACCOUNTING_REQUEST>, C<ACCOUNTING_RESPONSE>, 1395C<ACCOUNTING_STATUS>, C<STATUS_SERVER>, C<DISCONNECT_REQUEST>, C<DISCONNECT_ACCEPT>, 1396C<DISCONNECT_REJECT>, C<COA_REQUEST>, C<COA_ACCEPT>, C<COA_REJECT>, C<COA_ACK>, 1397and C<COA_NAK>. 1398Returns the number of bytes sent, or undef on failure. 1399 1400If the RETRANSMIT parameter is provided and contains a non-zero value, then 1401it is considered that we are re-sending the request, which was already sent 1402previously. In this case the previous value of packet identifier is used. 1403 1404=item recv_packet ( DETECT_BAD_ID ) 1405 1406Receives a Radius reply packet. Returns the Radius Reply type (see possible 1407values for C<REQUEST_TYPE> in method C<send_packet>) or undef on failure. Note 1408that failure may be due to a failed recv() or a bad Radius response 1409authenticator. Use C<get_error> to find out. 1410 1411If the DETECT_BAD_ID parameter is supplied and contains a non-zero value, then 1412calculation of the packet identifier is performed before authenticator check 1413and EBADID error returned in case when packet identifier from the response 1414doesn't match to the request. If the DETECT_BAD_ID is not provided or contains zero value then 1415EBADAUTH returned in such case. 1416 1417=item set_timeout ( TIMEOUT ) 1418 1419Sets socket I/O activity timeout. C<TIMEOUT> should be specified in floating seconds 1420since the epoch. 1421 1422=item get_error 1423 1424Returns the last C<ERRORCODE> for the current object. Errorcodes are one-word 1425strings always beginning with an 'C<E>'. 1426 1427=item strerror ( [ ERRORCODE ] ) 1428 1429Returns a verbose error string for the last error for the current object, or 1430for the specified C<ERRORCODE>. 1431 1432=item error_comment 1433 1434Returns the last error explanation for the current object. Error explanation 1435is generated by system call. 1436 1437=item get_active_node 1438 1439Returns currently active radius node in standard numbers-and-dots notation with 1440port delimited by colon. 1441 1442=back 1443 1444=head1 AUTHOR 1445 1446Carl Declerck <carl@miskatonic.inbe.net> - original design 1447Alexander Kapitanenko <kapitan at portaone.com> and Andrew 1448Zhilenko <andrew at portaone.com> - later modifications. 1449 1450PortaOne Development Team <perl-radius at portaone.com> is 1451the current module's maintainer at CPAN. 1452 1453=cut 1454 1455