1#! /usr/bin/perl 2# 3# 4# $Id: Simple.pm 75 2009-08-12 22:08:28Z lem $ 5 6package Net::Radius::Server::Match::Simple; 7 8use 5.008; 9use strict; 10use warnings; 11 12our $VERSION = do { sprintf "%0.3f", 1+(q$Revision: 75 $ =~ /\d+/g)[0]/1000 }; 13 14use NetAddr::IP 4; 15use Net::Radius::Server::Base qw/:match/; 16use base qw/Net::Radius::Server::Match/; 17__PACKAGE__->mk_accessors(qw/addr attr code peer_addr peer_port port/); 18 19sub _match_addr 20{ 21 my $self = shift; 22 my $peer = shift; 23 my $mpeer = shift; 24 25 if (ref($mpeer) eq 'Regexp') 26 { 27 if ($peer =~ m/$mpeer/) 28 { 29 $self->log(4, "_match_addr ok: $mpeer matches $peer"); 30 return NRS_MATCH_OK; 31 } 32 } 33 elsif (ref($mpeer) eq 'NetAddr::IP') 34 { 35 my $pip = NetAddr::IP->new($peer); 36 if (!$pip) 37 { 38 $self->log 39 (4, 40 "_match_addr fails: Cannot convert $peer to a NetAddr::IP"); 41 return NRS_MATCH_FAIL; 42 } 43 44 if ($mpeer->contains($pip)) 45 { 46 $self->log(4, "_match_addr ok: $mpeer contains $pip"); 47 return NRS_MATCH_OK; 48 } 49 } 50 elsif ($peer eq $mpeer) 51 { 52 $self->log(4, "_match_addr ok: $mpeer eq $peer"); 53 return NRS_MATCH_OK; 54 } 55 56 $self->log(3, "_match_addr fails: Don't know how to handle '$mpeer'"); 57 return NRS_MATCH_FAIL; 58} 59 60sub _match_port 61{ 62 my $self = shift; 63 my $port = shift; 64 my $mport = shift; 65 66 if (ref($mport) eq 'Regexp') 67 { 68 if ($port =~ m/$mport/) 69 { 70 $self->log(4, "_match_port ok: $mport matches $port"); 71 return NRS_MATCH_OK; 72 } 73 } 74 else 75 { 76 if ($port == $mport) 77 { 78 $self->log(4, "_match_port ok: $mport == $port"); 79 return NRS_MATCH_OK; 80 } 81 } 82 83 $self->log(3, "_match_port fails: Don't know how to handle '$mport'"); 84 return NRS_MATCH_FAIL; 85} 86 87sub match_peer_addr 88{ 89 my $self = shift; 90 my $peer = $_[0]->{peer_addr}; 91 my $mpeer = $self->peer_addr; 92 93 $self->log(4, "Invoked match_peer_addr"); 94 return $self->_match_addr($peer, $mpeer); 95} 96 97sub match_addr 98{ 99 my $self = shift; 100 my $peer = $_[0]->{addr}; 101 my $mpeer = $self->addr; 102 103 $self->log(4, "Invoked match_addr"); 104 return $self->_match_addr($peer, $mpeer); 105} 106 107sub match_port 108{ 109 my $self = shift; 110 my $port = $_[0]->{port}; 111 my $mport = $self->port; 112 113 $self->log(4, "Invoked match_port"); 114 return $self->_match_port($port, $mport); 115} 116 117sub match_peer_port 118{ 119 my $self = shift; 120 my $port = $_[0]->{peer_port}; 121 my $mport = $self->peer_port; 122 123 $self->log(4, "Invoked match_peer_port"); 124 return $self->_match_port($port, $mport); 125} 126 127sub match_attr 128{ 129 my $self = shift; 130 my $req = $_[0]->{request}; 131 132 my %conds = @{$self->attr}; 133 134 while (my ($a, $v) = each %conds) 135 { 136 my $V = $req->attr($a); 137 $self->log(4, "match_attr: ($a, $v, " . ($V || 'undef value') . ")"); 138 if (defined $V) 139 { 140 if (ref($v) eq 'Regexp') 141 { 142 if ($V =~ m/$v/) 143 { 144 $self->log(4, "match_attr: Regexp $v matches $V ($a)"); 145 next; 146 } 147 } 148 elsif (ref($v) eq 'NetAddr::IP') 149 { 150 my $ip = NetAddr::IP->new($V); 151 if ($ip and $v->contains($ip)) 152 { 153 $self->log(4, "match_attr: $v contains $ip ($a)"); 154 next; 155 } 156 } 157 else 158 { 159 if ($V eq $v) 160 { 161 $self->log(4, "match_attr: $V eq $v ($a)"); 162 next; 163 } 164 } 165 } 166 $self->log(3, "match_attr: No match - Return FAIL"); 167 return NRS_MATCH_FAIL; 168 } 169 $self->log(4, "match_attr: Default - Return OK"); 170 return NRS_MATCH_OK; 171} 172 173sub match_code 174{ 175 my $self = shift; 176 my $req = $_[0]->{request}; 177 178 if (ref($self->code) eq 'Regexp') 179 { 180 my $re = $self->code; 181 if ($req->code =~ m/$re/) 182 { 183 $self->log(4, "match_code: match: $re did not match " 184 . $req->code); 185 return NRS_MATCH_OK; 186 } 187 } 188 else 189 { 190 if ($req->code eq $self->code) 191 { 192 $self->log(4, "match_code: match: " 193 . $self->code . " eq " 194 . $req->code); 195 return NRS_MATCH_OK; 196 } 197 } 198 $self->log(3, "match_code: fail by default"); 199 return NRS_MATCH_FAIL; 200} 201 202# Preloaded methods go here. 203 20442; 205__END__ 206 207=head1 NAME 208 209Net::Radius::Server::Match::Simple - Simple match methods for RADIUS requests 210 211=head1 SYNOPSIS 212 213 use Net::Radius::Server::Match::Simple; 214 215 my $match = Net::Radius::Server::Match::Simple->new 216 ({ 217 code => 'Access-Request', 218 attr => [ 219 'User-Name' => qr/(?i)\@my\.domain\.?$/, 220 'NAS-IP-Address' => NetAddr::IP->new('127.0.0.0/24'), 221 'Framed-Protocol' => 'PPP', 222 ], 223 }); 224 my $match_sub = $match->mk; 225 226=head1 DESCRIPTION 227 228C<Net::Radius::Server::Match::Simple> implements simple but effective 229packet matcher method factories for use in C<Net::Radius::Server> 230rules. 231 232See C<Net::Radius::Server::Match> for general usage guidelines. The 233relevant attributes that control the matching of RADIUS requests are: 234 235=over 236 237=item C<attr> 238 239Controls matching of a given attribute in the request packet. Must be 240called with a listref where even elements represent the name of a 241RADIUS attribute to match. The odd elements can be any of the 242following: 243 244=over 245 246=item * 247 248A scalar, in which case an exact match with the attribute contents 249must occur for this method to return C<NRS_MATCH_OK>. 250 251=item * 252 253A regexp, in which case the attribute's content must match the regexp 254for this method to return C<NRS_MATCH_OK>. 255 256=item * 257 258A C<NetAddr::IP> subnet, in which case the attribute matches if its 259value can be converted to a C<NetAddr::IP> object and it is contained 260in the given subnet. This is very useful to perform sanity check on 261your RADIUS requests. 262 263=back 264 265All the conditions specified in this way must match in order for the 266method to return C<NRS_MATCH_OK>. Otherwise, C<NRS_MATCH_FAIL> will be 267returned. 268 269This would match if the User-Name attribute in the RADIUS request 270contains a (case insensitive) "@foo.domain" realm AND the 271NAS-IP-Address attribute contains '127.0.0.1'. 272 273=item C<code> 274 275Matches the RADIUS packet code. The following types of attributes can 276be specified: 277 278=over 279 280=item * 281 282A scalar, in which case an exact match with the code must occur for 283this method to return C<NRS_MATCH_OK>. 284 285=item * 286 287A regexp, in which case the code's name must match the regexp for this 288method to return C<NRS_MATCH_OK>. 289 290=back 291 292See Net::Radius::Packet(3) for more information on atribute and type 293representation. 294 295=item C<peer_addr> and C<addr> 296 297Match the address of either the peer or the local socket used to 298receive the request. The following specifications can be used for the 299match: 300 301=over 302 303=item * 304 305A scalar, in which case an exact match with the address must occur for 306this method to return C<NRS_MATCH_OK>. 307 308=item * 309 310A regexp, in which case the address must match the regexp 311for this method to return C<NRS_MATCH_OK>. 312 313=item * 314 315A C<NetAddr::IP> subnet, in which case the address matches if its 316value can be converted to a C<NetAddr::IP> object and it is contained 317in the given subnet. 318 319=back 320 321=item C<peer_port> and C<port> 322 323Match the port of either the peer or the local socket used to 324receive the request. The following specifications can be used for the 325match: 326 327=over 328 329=item * 330 331A scalar, in which case an exact match with the port must occur for 332this method to return C<NRS_MATCH_OK>. 333 334=item * 335 336A regexp, in which case the port must match the regexp for this method 337to return C<NRS_MATCH_OK>. 338 339=back 340 341Note that ports are usually numeric (ie, 1812 instead of "radacct"). 342 343=back 344 345=head2 EXPORT 346 347None by default. 348 349 350=head1 HISTORY 351 352 $Log$ 353 Revision 1.3 2006/12/14 15:52:25 lem 354 Fix CVS tags 355 356 357=head1 SEE ALSO 358 359Perl(1), NetAddr::IP(3), Net::Radius::Server(3), 360Net::Radius::Server::Match(3), Net::Radius::Packet(3). 361 362=head1 AUTHOR 363 364Luis E. Muñoz, E<lt>luismunoz@cpan.orgE<gt> 365 366=head1 COPYRIGHT AND LICENSE 367 368Copyright (C) 2006 by Luis E. Muñoz 369 370This library is free software; you can redistribute it and/or modify 371it under the same terms as Perl 5.8.6 itself. 372 373=cut 374 375 376