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