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