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