1package Net::Radius::Server::NS; 2 3use 5.008; 4use strict; 5use warnings; 6use Net::Radius::Packet; 7use base qw/Net::Server::MultiType Net::Radius::Server/; 8use Net::Radius::Server::Base qw/:all/; 9 10our $VERSION = do { sprintf "%0.3f", 1+(q$Revision: 89 $ =~ /\d+/g)[0]/1000 }; 11 12# Verify that the required configuration keys are present. Initialize 13# whatever we'll require for request processing, such as dictionaries, 14# RADIUS setup file and 'secret' sources. 15sub options 16{ 17 my $self = shift; 18 my $prop = $self->{server}; 19 my $ref = shift; 20 21 $self->SUPER::options($ref, @_); 22 23 for ( qw(nrs_rule_script nrs_secret_script nrs_dictionary_script) ) 24 { 25 $prop->{$_} = [] unless exists $prop->{$_}; 26 $ref->{$_} = $prop->{$_}; 27 } 28} 29 30sub configure 31{ 32 my $self = shift; # A Net::Server-derived object 33 my $s = $self->{server}; 34 35 $self->SUPER::configure(@_); 36 37 # We need to have a few keys defined before proceeding. 38 die __PACKAGE__, " definitions are missing\n" 39 unless (exists $s->{nrs_rule_script} 40 and exists $s->{nrs_secret_script} 41 and exists $s->{nrs_dictionary_script}); 42 43 for (qw/nrs_dictionary_script nrs_rule_script nrs_secret_script/) 44 { 45 die __PACKAGE__, ": Exactly one $_ must be specified\n" 46 if @{$s->{$_}} != 1; 47 } 48 49 my ($d_method, $s_method, $rules); 50 51 eval { $d_method = do ($s->{nrs_dictionary_script}->[0]) }; 52 warn "Dictionary script ", $s->{nrs_dictionary_script}->[0], 53 " produced output: $@\n" if $@; 54 die "Dictionary script ", $s->{nrs_dictionary_script}->[0], 55 " must return a coderef (returned " 56 . ($d_method||'false/undef') . ")\n" 57 unless ref($d_method) eq 'CODE'; 58 59 eval { $s_method = do ($s->{nrs_secret_script}->[0]) }; 60 warn "Secret script ", $s->{nrs_secret_script}->[0], 61 " produced output: $@\n" if $@; 62 die "Secret script ", $s->{nrs_secret_script}->[0], 63 " must return a coderef (returned " 64 . ($s_method||'false/undef') . ")\n" 65 unless ref($s_method) eq 'CODE'; 66 67 eval { $rules = do ($s->{nrs_rule_script}->[0]) }; 68 warn "Rule script produced output: $@\n" if $@; 69 die "Rule script must return a listref (returned " 70 . ($rules||'false/undef') . ")\n" 71 unless ref($rules) eq 'ARRAY'; 72 73 $self->{_nrs} = { 74 secret => $s_method, 75 dict => $d_method, 76 rules => $rules, 77 }; 78} 79 80# Add the processing handler that is responsible for each packet 81sub process_request 82{ 83 my $self = shift; 84 my $prop = $self->{server}; 85 my $data = { 86 packet => $prop->{udp_data}, 87 peer_addr => $prop->{peeraddr}, 88 peer_host => $prop->{peerhost}, 89 peer_port => $prop->{peerport}, 90 port => $prop->{sockport}, 91 sockaddr => $prop->{sockaddr}, 92 server => $self, 93 }; 94 95 if (length($data->{packet}) < 18) 96 { 97 $self->log(2, "Packet too short - Ignoring"); 98 return; 99 } 100 101 $data->{secret} = $self->{_nrs}->{secret}->($data); 102 $data->{dict} = $self->{_nrs}->{dict}->($data); 103 $data->{response} = new Net::Radius::Packet $data->{dict}; 104 $data->{request} = Net::Radius::Packet->new($data->{dict}, 105 $data->{packet}); 106 107 if (not defined $data->{request}) 108 { 109 $self->log(2, "Failed to decode RADIUS packet (garbage?)"); 110 return; 111 } 112 113 $self->log(2, "Received from " . ($data->{peer_addr} || '[no peer]') 114 . ' (' . $data->{request}->code . ' ' 115 . join(', ', map { "$_ => " . $data->{request}->attr($_) } 116 grep { $_ !~ /(?i)password|-message/ } 117 $data->{request}->attributes) 118 . ') '); 119 120 $self->log(4, "Request: " . $data->{request}->str_dump); 121 122 # Verify that the authenticator in the packet matches the packet 123 # data. Discard the packet if this check fails 124 125 if (grep { $data->{request}->code eq $_ } 126 qw/Accounting-Request 127 Disconnect-Request Disconnect-ACK Disconnect-NAK 128 CoA-Request CoA-ACK CoA-NAK/) 129 { 130 if (auth_acct_verify($data->{packet}, $data->{secret})) 131 { 132 $self->log(4, $data->{request}->code . 133 ' with good secret from ' . 134 $data->{peer_addr}); 135 } 136 else 137 { 138 # Bad secret - Ignore request 139 $self->log(2, $data->{request}->code . 140 ' with bad secret from ' . 141 $data->{peer_addr}); 142 return; 143 } 144 } 145 146 my $res = undef; 147 for my $r (@{$self->{_nrs}->{rules}}) 148 { 149 $res = $r->eval($data); 150 unless (defined $res) 151 { 152 $self->log(4, $r->description . ": Did not match"); 153 next; 154 } 155 156 if ($res & NRS_SET_DISCARD) 157 { 158 $self->log(2, $r->description . ": Requested discard"); 159 return; 160 } 161 162 if ($res & NRS_SET_SKIP) 163 { 164 $self->log(4, $r->description . ": Requested skip"); 165 next; 166 } 167 168 if ($res & NRS_SET_RESPOND) 169 { 170 $self->log(4, $r->description . ": Requested respond"); 171 last; 172 } 173 } 174 175 unless (defined $res) 176 { 177 $self->log(2, "Discard: No matching rule"); 178 return; 179 } 180 181 if ($res & NRS_SET_RESPOND) 182 { 183 $self->log(2, "Sent " . $data->{response}->code . ' ' 184 . join(', ', map { "$_ => " . $data->{response}->attr($_) } 185 grep { $_ !~ /(?i)password|-message/ } 186 $data->{response}->attributes) . " to request from " 187 . ($data->{peer_addr} || '[no peer]') 188 . ' (' . $data->{request}->code . ' ' 189 . join(', ', map { "$_ => " . $data->{request}->attr($_) } 190 grep { $_ !~ /(?i)password|-message/ } 191 $data->{request}->attributes) 192 . ') '); 193 $self->log(3, "Responding"); 194 my $reply_packet = auth_resp($data->{response}->pack, 195 $data->{secret}); 196 $self->{server}->{client}->send($reply_packet); 197 $self->log(4, "Response: " . 198 Net::Radius::Packet->new($data->{dict}, 199 $reply_packet)->str_dump); 200 } 201 else 202 { 203 $self->log(2, "Ignoring request from " . 204 ($data->{peer_addr} || '[no peer]') 205 . ' (' . $data->{request}->code . ' ' 206 . join(', ', map { "$_ => " . $data->{request}->attr($_) } 207 grep { $_ !~ /(?i)password|-message/ } 208 $data->{request}->attributes) 209 . ') '); 210 } 211} 212 21342; 214 215__END__ 216 217=head1 NAME 218 219Net::Radius::Server::NS - Use Net::Server to provide a Net::Radius::Server 220 221=head1 SYNOPSIS 222 223 use Net::Radius::Server::NS; 224 225=head1 DESCRIPTION 226 227C<Net::Radius::Server::NS> leverages C<Net::Server> to receive, 228process and respond RADIUS requests using the C<Net::Radius::Server> 229framework. 230 231The C<nrsd> script included in the C<Net::Radius::Server> distribution 232ties in with this module and performs an invocation suitable for 233running a production RADIUS server. Usually, the invocation will look 234like the following example: 235 236 nrsd --conf_file nrsd.cfg 237 238The configuration file (or any other means of configuration supported 239by Net::Server(3)) must include the following entries: 240 241=over 242 243=item nrs_rule_script 244 245Specify the name of a Perl script that will initialize the rules used 246to process RADIUS requests. Rules will usually be objects of either 247Net::Radius::Server::Rule(3) or a derived class. 248 249Invocation of the script is done through a C<require>. 250 251The script must return a reference to the list of rules to 252apply. Rules will be applied using their respective C<-E<gt>eval()> 253methods in the order they appear in the list. Each C<-E<gt>eval()> 254method will receive the same, fully initialized invocation 255hashref. See C<Net::Radius::Server> for more information in the 256contents of the invocation hashref. 257 258=item nrs_secret_script 259 260Specify the name of a Perl script that will provide a method used to 261determine what shared secret to use in decoding incoming RADIUS 262packets. 263 264Invocation of the script is done through a C<require>. 265 266The script must return a reference to a function that will be called 267for each request. The return value of this sub must be the RADIUS 268shared secret that must be used to decode the request packet and to 269encode the eventual response. 270 271At the time this sub is invoked, the RADIUS packet is not yet 272decoded. Therefore, only the following entries in the invocation 273hashref are available: packet, peer_addr, peer_host, peer_port, port, 274sockaddr and server. 275 276See C<Net::Radius::Server> for more information in the contents of the 277invocation hashref. 278 279=item nrs_dictionary_script 280 281Specify the name of a Perl script that will provide a method used to 282determine what dictionary to use in decoding incoming RADIUS packets. 283 284Invocation of the script is done through a C<require>. 285 286The script must return a reference to a function that will be called 287for each request. The return value of this sub must be the RADIUS 288dictionary that must be used to decode the request packet and to 289encode the eventual response. The RADIUS dictionary will usually be a 290C<Net::Radius::Dictionary> object. 291 292At the time this sub is invoked, the RADIUS packet is not yet 293decoded. Therefore, only the following entries in the invocation 294hashref are available: packet, peer_addr, peer_host, peer_port, port, 295sockaddr, server and secret. 296 297See C<Net::Radius::Server> for more information in the contents of the 298invocation hashref. 299 300=back 301 302The output of any of the scripts will be logged, as these are not 303expected to produce output under normal circumstances. 304 305=head2 EXPORT 306 307None by default. 308 309=head1 HISTORY 310 311 $Log$ 312 Revision 1.8 2006/12/14 16:33:17 lem 313 Rules and methods will only report failures in log level 3 and 314 above. Level 4 report success and failure, for deeper debugging 315 316 Revision 1.7 2006/12/14 16:25:33 lem 317 Improved logging messages - Use log level 2 for normal 318 operation. Level 1 is very un-verbose. Levels 3 and 4 provide 319 increasing debug messages 320 321 Revision 1.6 2006/12/14 15:52:25 lem 322 Fix CVS tags 323 324 325=head1 SEE ALSO 326 327Perl(1), nrsd(8), Net::Server(3), Net::Radius::Dictionary(3), 328Net::Radius::Server(3). 329 330=head1 AUTHOR 331 332Luis E. Muñoz, E<lt>luismunoz@cpan.orgE<gt> 333 334=head1 COPYRIGHT AND LICENSE 335 336Copyright (C) 2006 by Luis E. Muñoz 337 338This library is free software; you can redistribute it and/or modify 339it under the same terms as Perl 5.8.6 itself. 340 341=cut 342