1#! /usr/bin/perl
2#
3#
4# $Id: Proxy.pm 75 2009-08-12 22:08:28Z lem $
5
6package Net::Radius::Server::Set::Proxy;
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 IO::Select;
15use IO::Socket::INET;
16use Net::Radius::Packet 1.51;
17use Net::Radius::Dictionary;
18use Net::Radius::Server::Base qw/:set/;
19use base qw/Net::Radius::Server::Set/;
20__PACKAGE__->mk_accessors(qw/
21			  server port secret dictionary result
22			  timeout tries
23			  /);
24
25sub _proxy
26{
27    my $self	= shift;
28    my $r_data	= shift;
29    my $secret	= shift;
30    my $dict	= shift;
31
32    my $req	= $r_data->{request};
33    my $pass	= $req->password($r_data->{secret});
34
35    # Construct a packet for our server, passing all the attributes
36    # from the original packet - Note that the dict may be different
37    # XXX - It may be more efficient to take the chance and use
38    # ->{request} instead of re-decoding the packet
39    my $p = new Net::Radius::Packet $dict, $r_data->{packet};
40
41    # Send password protected with our shared secret
42    $p->set_password($pass, $secret) if $p->attr('User-Password');
43
44    my $packet	= undef;
45    my $tries	= 0;
46    my $reply	= undef;
47
48    # Format packet properly according to type
49    if ($req->code =~ m/Accounting-Request/)
50    {
51	$p->set_authenticator("\x0" x 16);
52	$packet = auth_resp($p->pack, $secret);
53    }
54    else
55    {
56	$packet = $p->pack();
57    }
58
59    # Attempt to send the request to the real RADIUS server
60    while ($tries < $self->tries)
61    {
62	if ($self->{_socket}->send($packet))
63	{
64	    if ($self->{_select}->can_read($self->timeout))
65	    {
66		last if $self->{_socket}->recv($reply, 1024);
67		$self->log(2, "[$tries] Failed to recv(): $!");
68	    }
69	    else
70	    {
71		$self->log(2, "[$tries] Timeout waiting for server response");
72	    }
73	}
74	else
75	{
76	    $self->log(1, "[$tries] Send failed: $!");
77	}
78	$tries ++;
79    }
80
81    # No reply - Simply drop this packet and wait
82    unless (defined $reply and length($reply) > 0)
83    {
84	$self->log(2, "Server reply is undef or empty");
85	return;
86    }
87
88    # Compose reply to the client depending on the packet type
89    $r_data->{response} = new Net::Radius::Packet $dict, $reply;
90
91    unless ($r_data->{response})
92    {
93	$self->log(2, "Failed to parse response packet from server");
94	return;
95    }
96
97    # Adjust authenticators according to the response type
98    my $res = $r_data->{response};
99    if ($res->code =~ m/
100	Access-Accept
101	|Access-Reject
102	|Access-Challenge
103	|Accounting-Response/x)
104    {
105	$res->set_authenticator($req->authenticator);
106    }
107    elsif ($res->code =~ m/Accounting-Request/)
108    {
109	$res->set_authenticator("\x0" x 16);
110    }
111
112    # Copy response packet back to our client
113    $self->log(4, "Copying packet to my response");
114    return 1;
115}
116
117sub _set
118{
119    my $self = shift;
120    my $r = $self->set_server(@_);
121    unless ($r)
122    {
123	$self->log(3, "Failure: Return CONTINUE by default");
124	return NRS_SET_CONTINUE;
125    }
126
127    if ($self->can('result'))
128    {
129	my $r = $self->result;
130	$self->log(4, "Return $r as given result");
131	return $r;
132    }
133    else
134    {
135	$self->log(4, "Return CONTINUE | RESPOND  as given result");
136	return NRS_SET_CONTINUE | NRS_SET_RESPOND;
137    }
138}
139
140sub set_server
141{
142    my $self = shift;
143    my $r_data = shift;
144
145    $self->timeout(3) unless $self->timeout;
146    $self->tries(2) unless $self->tries;
147
148    my $secret = $self->secret || $r_data->{secret};
149    my $port = $self->port || $r_data->{port};
150    my $dict = defined $self->dictionary
151	? Net::Radius::Dictionary->new($self->dictionary)
152	: $r_data->{dict};
153
154    $self->log(4, "Creating udp socket to " . $self->server . ":$port");
155    $self->{_socket} = IO::Socket::INET->new
156	(
157	 PeerAddr	=> $self->server,
158	 PeerPort	=> $port,
159	 Proto		=> 'udp',
160	 );
161
162    unless ($self->{_socket})
163    {
164	$self->log(2, "Failed to create socket: $!");
165	return;
166    }
167
168    $self->{_select} = new IO::Select $self->{_socket};
169    unless ($self->{_select})
170    {
171	$self->log(2, "Failed to select object: $!");
172	return;
173    }
174
175    $self->log(4, "Proxying request to "
176	       . $self->server . ":$port");
177    $self->_proxy($r_data, $secret, $dict);
178}
179
18042;
181
182__END__
183
184=head1 NAME
185
186Net::Radius::Server::Set::Server - Proxy the RADIUS request to a RADIUS server
187
188=head1 SYNOPSIS
189
190  use Net::Radius::Server::Set::Proxy;
191  use Net::Radius::Server::Base qw/:set/;
192
193
194  my $proxy = Net::Radius::Server::Set::Proxy->new
195    ({
196       server => $real_server_ip,
197       port => $real_server_port,
198       dictionary => $dictionary_file,
199       tries => 2,
200       timeout => 3,
201       result => NRS_SET_RESPOND,
202      });
203  my $proxy_sub = $proxy->mk;
204
205=head1 DESCRIPTION
206
207C<Net::Radius::Server::Set::Proxy> allows for proxying the (matching)
208RADIUS requests through a RADIUS server. The following attributes are
209supported:
210
211=over
212
213=item B<server>
214
215This entry is mandatory and specifies the address of the server to
216which the RADIUS request must be sent.
217
218=item B<port>
219
220The port in the RADIUS server where the current request must be
221sent. Defaults to the current port.
222
223=item B<secret>
224
225The RADIUS shared secret to be used to protect the interaction with
226the server. Defaults to the secret used to handle the current request.
227
228=item B<dictionary>
229
230Dictionary to use for packet coding/decoding when talking to the
231RADIUS server. If left unspecified, the currently configured
232dictionary will be used to handle that interaction as well.
233
234=item B<timeout>
235
236How many seconds before retrying request to the real RADIUS
237server. Defaults to 3 seconds.
238
239=item B<tries>
240
241How many attempts to proxy the request to the real RADIUS
242server. Defaults to 2 attempts.
243
244=item B<result>
245
246The result to be returned by the method. See Net::Server::Base(3) for
247more information.
248
249=back
250
251When proxying is succesful, C<$self-E<gt>result> will be returned (if
252specified). Otherwise, C<NRS_SET_CONTINUE | NRS_SET_RESPOND> will be
253returned by default.
254
255Upon a failure in the proxying, C<NRS_SET_CONTINUE> is returned.
256
257=head2 EXPORT
258
259None by default.
260
261
262=head1 HISTORY
263
264  $Log$
265  Revision 1.13  2007/01/03 00:29:58  lem
266  Improve check for non-responses
267
268  Revision 1.12  2006/12/14 16:33:17  lem
269  Rules and methods will only report failures in log level 3 and
270  above. Level 4 report success and failure, for deeper debugging
271
272  Revision 1.11  2006/12/14 15:52:25  lem
273  Fix CVS tags
274
275
276=head1 SEE ALSO
277
278Perl(1), Net::Radius::Server(3), Net::Radius::Server::Radius(3),
279Net::Radius::Packet(3).
280
281=head1 AUTHOR
282
283Luis E. Muñoz, E<lt>luismunoz@cpan.orgE<gt>
284
285=head1 COPYRIGHT AND LICENSE
286
287Copyright (C) 2006 by Luis E. Muñoz
288
289This library is free software; you can redistribute it and/or modify
290it under the same terms as Perl 5.8.6 itself.
291
292=cut
293
294
295