# AuthRADIUS.pm
#
# Object for handling Authentication from remote radius servers
#
# Author: Mike McCauley (mikem@open.com.au)
# Copyright (C) 1997 Open System Consultants
# $Id: AuthRADIUS.pm,v 1.36 2000/08/28 21:57:26 mikem Exp mikem $

package Radius::AuthRADIUS;
use Radius::AuthGeneric;
use Radius::Radius;
use Radius::Select;
use Socket;
use Fcntl;
use strict;

use vars qw($VERSION @ISA);
BEGIN 
{
    @ISA = qw(Radius::AuthGeneric);
}

# This is a hash of requests for which we are awaiting replies
# ie these are the original requests as received from our client
# Each entry is an array of 3 refs to Radius packets. The first element
# is the original packet we received, the second is the packet we
# forwarded, the 3rd is the reply packet we are constructing
# and which was originally passed to handle_request
my %pendingRequests;

# If CachePasswords is enable, This hash caches the time, password
# and reply last Access-Accept for each use
my %passwordCache;

# We maintain a separate socket for each distinct LocalAddress. All
# instances of AuthRADIUS with the same LocalAddress share the same
# socket for sending requests.
# Each socket is an instance of FileHandle
my %sockets;

# Make sure we get reinitialized on sighup
push(@main::reinitFns, \&reinitialize);

#####################################################################
# Constructs a new handler
sub new
{
    my ($class, $file) = @_;

    my $self = $class->SUPER::new($file);

    # Only validate if configuring from a file. If being constructed
    # by code, we asssume they know what they are doing
    if ($file)
    {
	$self->log($main::LOG_WARNING, 
	       "No Secret defined for $class at '$main::config_file' line $.")
	    if !defined $self->{Secret};
	$self->log($main::LOG_WARNING, 
	       "No Host defined for $class at '$main::config_file' line $.")
	    if !defined $self->{Host};
    }
    return $self;
}

#####################################################################
# Do per-instance default initialization
sub initialize
{
    my ($self) = @_;

    $self->SUPER::initialize;
    $self->{AuthPort} = 1645;
    $self->{AcctPort} = 1646;
    $self->{Retries} = 3;
    $self->{RetryTimeout} = 5;
    $self->{CachePasswordExpiry} = 86400; # 1 day
    $self->{LocalAddress} = $main::config->{BindAddress};
    $self->{roundRobinCounter} = 0;
}

#####################################################################
# Override the keyword function in Configurable
sub keyword
{
    my ($self, $file, $keyword, $value) = @_;

    if ($keyword eq 'Host')
    {
	$self->addHost($value);
    }
    elsif ($keyword eq 'Secret')
    {
	$self->{Secret} = $value;
    }
    elsif ($keyword eq 'AuthPort')
    {
	$self->{AuthPort} = $value;
    }
    elsif ($keyword eq 'AcctPort')
    {
	$self->{AcctPort} = $value;
    }
    elsif ($keyword eq 'Retries')
    {
	$self->{Retries} = int $value;
    }
    elsif ($keyword eq 'RetryTimeout')
    {
	$self->{RetryTimeout} = int $value;
    }
    elsif ($keyword eq 'StripFromRequest')
    {
	$self->{StripFromRequest} = $value;
    }
    elsif ($keyword eq 'AddToRequest')
    {
	$self->{AddToRequest} = $value;
    }
    elsif ($keyword eq 'NoForwardAuthentication')
    {
 	$self->{NoForwardAuthentication} = $value;
    }
    elsif ($keyword eq 'NoForwardAccounting')
    {
 	$self->{NoForwardAccounting} = $value;
    }
    elsif ($keyword eq 'IgnoreReject')
    {
 	$self->{IgnoreReject} = $value;
    }
    elsif ($keyword eq 'Synchronous')
    {
 	$self->{Synchronous} = $value;
    }
    elsif ($keyword eq 'LocalAddress')
    {
	$self->{LocalAddress} = $value;
    }
    elsif ($keyword eq 'ReplyHook')
    {
	# Get a reference to the code block
	$self->{ReplyHook} = eval($value);
	&main::log($main::LOG_ERR, 
		   "Compilation error in ReplyHook(): $@")
	    if $@;
    }
    elsif ($keyword eq 'NoReplyHook')
    {
	# Get a reference to the code block
	$self->{NoReplyHook} = eval($value);
	&main::log($main::LOG_ERR, 
		   "Compilation error in NoReplyHook(): $@")
	    if $@;
    }
    elsif ($keyword eq 'UseOldAscendPasswords')
    {
	$self->{UseOldAscendPasswords} = $value;
    }
    elsif ($keyword eq 'CachePasswords')
    {
	$self->{CachePasswords} = $value;
    }
    elsif ($keyword eq 'CachePasswordExpiry')
    {
	$self->{CachePasswordExpiry} = $value;
    }
    elsif ($keyword eq 'ServerHasBrokenPortNumbers')
    {
	# Some Radius servers (GRIC on NT) exhibit broken behaviour
	# in that the reply does not come from the same UDP port
	# that the request was sent to!
	$self->{ServerHasBrokenPortNumbers} = $value;
    }
    else
    {
	return $self->SUPER::keyword($file, $keyword, $value);
    }
    return 1;
}

#####################################################################
# Handle a request
sub handle_request
{
    my ($self, $p, $rp, $extra_checks) = @_;

    $self->log($main::LOG_DEBUG, "Handling with Radius::AuthRADIUS");

    if (   $p->code eq 'Access-Request'
	|| $p->code eq 'Accounting-Request')
    {
	# Do not Forward if NoForwardAuthentication or
	# NoForwardAccounting flag From a contribution by
	# Vincent Gillet <vgi@oleane.net>
	# If you have several of these, you will want
	# AuthByPolicy ContinuueWhileIgnore
	if ((   defined $self->{NoForwardAuthentication}
	     && $p->code eq 'Access-Request') 
	    ||
	    (   defined $self->{NoForwardAccounting} 
	     && $p->code eq 'Accounting-Request'))
	{
	    my $type = $p->code;
	    &Radius::Log::log($main::LOG_DEBUG, 
	      "Request type $type not forwarded to AuthRADIUS");
	    return ($main::IGNORE); # No reply
	}
  
	# Forward the request:
	my $fp = new Radius::Radius $main::dictionary;

	# Remember who this instance of AuthRADIUS is
	$fp->{ThisAuth} = $self;
	
	# copy it into a new request
	$fp->set_code($p->code);
	$fp->set_identifier($self->next_identifier);

	# Use the same authenticator that came in the request, because if
	# it is an Access-Request, it might contain a CHAP random challenge
	# and if it is an Accounting-Request, the correct authenticator
	# (all 0s) will be set in assemble_packet before transmission
	$fp->set_authenticator($p->authenticator);

	# Copy the attributes
	$fp->add_attr_list($p);

	# Decode the incoming password and reencode it with the secret
	# for the next hop
	my $password = $p->decodedPassword();
	if (defined $password)
	{
	    $fp->changeAttrByNum
		($Radius::Radius::USER_PASSWORD, 
		 $fp->encode_password
		 ($password, $self->{Secret}, defined $self->{UseOldAscendPasswords}));
	}

	my $port;

	if ($fp->code eq 'Accounting-Request')
	{
	    # Send it out the Accounting port
	    $port = $self->{AcctPort};
	    # Change or set the Acct-Delay
	    $fp->changeAttrByNum($Radius::Radius::ACCT_DELAY_TIME, 
                time - $p->{RecvTime});
	}
	else
	{
	    # Send it to the authentication port
	    $port = $self->{AuthPort};

	    if (defined $self->{RejectEmptyPassword} 
		&& $password eq '')
	    {
		$self->log($main::LOG_DEBUG, "AuthRADIUS rejected because of an empty password");
		return ($main::REJECT, 'Empty password');
	    }

	}

	# Add and strip attributes before forwarding
	if (defined $self->{StripFromRequest})
	{
	    map {$fp->delete_attr($_)} (split(/\s*,\s*/, $self->{StripFromRequest}));
	}
	if (defined $self->{AddToRequest})
	{
	    my $s = &Radius::Util::format_special($self->{AddToRequest}, $p, $rp);
	    $fp->parse($s);
	}
	
	$self->forwardToNextHost($fp, $p, $rp, $port);
	if (defined $self->{Synchronous})
	{
	    # Here we process replies until the request we are doing
	    # has either been replied to or timed out
	    # CAUTION: while this is happening, no other incoming requests
	    # will be handled: If the remote server is down
	    # you may get a serious performance hit
	    # Wait for activity on the reply socket or timeouts
	    my $waitfor;
	    vec($waitfor, fileno($self->getSock()), 1);
	    while (! defined $p->{RadiusResult})
	    {
		# Wait up to a second for activity on the socket
		select($waitfor, undef, undef, 1)
		&handle_radius_socket_read(fileno($self->getSock()), 
					   $self->getSock());
	        &Radius::Select::process_timeouts();
	    }
	    return ($p->{RadiusResult});
	}
	else
	{
	    return ($main::IGNORE); # Dont reply for us
	}
    }
    else
    {
	my $type = $p->code;
	&Radius::Log::log($main::LOG_WARNING, 
	     "Request type $type could not be handled by AuthRADIUS");
	return ($main::ACCEPT); # Send a reply on our behalf
    }
}

#####################################################################
# Finds and returns a socket for use by this instance.
# There is a separate socket for each distinct LocalAddress. All
# instances of AuthRADIUS with the same LocalAddress share the 
# same socket.
# If a socket does not exist for the LocalAddress, creates one.
sub getSock
{
    my ($self) = @_;

    if (!exists $sockets{$self->{LocalAddress}})
    {
	# This could have been done with FileHandle, but this is much
	# more lightweight. It makes a reference to a TYPEGLOB
	# and Perl can use a typeglob ref as an IO handle
	$sockets{$self->{LocalAddress}} = do { local *FH };

	socket($sockets{$self->{LocalAddress}}, Socket::PF_INET, Socket::SOCK_DGRAM, 
	       scalar getprotobyname('udp'))
	    || die "Could not create Radius forwarding socket in AuthRADIUS: $!";

	my $bind_address = &Radius::Util::format_special($self->{LocalAddress});
	bind($sockets{$self->{LocalAddress}},
	     scalar &Socket::sockaddr_in
	     (0, Socket::inet_aton($bind_address)))
	    || die "Could not bind to LocalAddress $bind_address in AuthRADIUS: $!";
    
	# On some hosts, select sometimes incorrectly says that there
	# is a reply waiting, even when there isnt. 
	# Set the socket non-blocking to prevent waiting forever
	if ($^O ne 'MSWin32')
	{
	    # Win95 does not support fcntl or non-blocking sockets yet.
	    fcntl($sockets{$self->{LocalAddress}}, F_SETFL, 
		  fcntl($sockets{$self->{LocalAddress}}, F_GETFL, 0) | O_NONBLOCK)
		|| die "Could not fcntl forwarding socket in AuthRADIUS: $!";
	}
	&Radius::Select::add_file(fileno($sockets{$self->{LocalAddress}}), 1, undef, undef, 
	  \&Radius::AuthRADIUS::handle_radius_socket_read, 
	  $sockets{$self->{LocalAddress}});
    }
    return $sockets{$self->{LocalAddress}};
}

#####################################################################
# Reinitialize this instance
sub reinitialize
{
    my ($self) = @_;

    # Since select will have forgotten about our sockets, and in any
    # case, the socket addresses may have changed, we have to
    # recreate our sockets
    %sockets = ();
}

#####################################################################
# This is called by Select::select whenever our forwarding socket
# becomes readable. Read at most one packet from the socket and
# dispatch it.
# The packets received here will be replies to requests 
# we have forwarded
# to another radius server. We have to forward the 
# reply back to the original
# requester and cross the original request off our timeout list
sub handle_radius_socket_read
{
    my ($fileno, $socket) = @_;

    my $p;   # The reply we just received
    if ($p = Radius::Radius->newRecvFrom($socket, $main::dictionary))
    {
	my $identifier = $p->identifier; # The ID of the received packet

	# We do this an a longwinded way because some 5.003 versions get
	# confused otherwise. First get the ref, see if its valid, then
	# deref later
	my ($port, $addr) = Socket::unpack_sockaddr_in($p->{RecvFrom});
	my $ip = Socket::inet_ntoa($addr);
	my $key = $port.$addr.$identifier;

	my $ref = $pendingRequests{$key};
	# Maybe its a reply from a server with broken port numbers?
	if (!defined $ref)
	{
	    $key = 'BROKENPORT'.$addr.$identifier;
	    $ref = $pendingRequests{$key};
	}


	if (!defined $ref)
	{
	    &main::log($main::LOG_WARNING, 
		       "Unknown reply received in AuthRADIUS for request $identifier from $ip:$port");
	    return 1;
	}
	else
	{
	    &main::log($main::LOG_DEBUG,
		       "Received reply in AuthRADIUS for req $identifier from $ip:$port");
	}

	# sp is the packet we forwarded to the remote radius
	# op is the original request we received triggered this whole
	# thing off
	my ($op, $sp, $rp) = @$ref;
	if (defined $sp)
	{
	    # Check out the reply we got
	    my $self = $sp->{ThisAuth};

	    # Cross it off our pending list
	    $pendingRequests{$key} = undef;
	    
	    # Cross it of our timeout list
	    &Radius::Select::remove_timeout($sp->{TimeoutHandle})
		|| $self->log($main::LOG_ERR, "Timeout $sp->{TimeoutHandle} was not in the timeout list");

	    # Be a bit lenient. Even if the auth is bad
	    # process it anyway. Lots of servers dont
	    # do authentication properly
	    if (! $p->check_authenticator($self->{Secret}, 
					 $sp->sent_authenticator))
	    {
		$self->log($main::LOG_WARNING, 
				  "Bad authenticator received in reply to ID $identifier");
	    }
	    # synthesize a reply 
	    # to the original request and send 
	    # it back to the original requester. It already has
	    # the identifier and authenticator set.
	    $rp->set_code($p->code);
	    
	    # Maybe decode and reencode any Tunnel-Password
	    # for the next hop
	    my $tpa = $p->get_attr('Tunnel-Password');
	    if (defined $tpa)
	    {
		my ($tp, $tag) = $sp->decode_tunnel_password($tpa, $self->{Secret});
		$tp = $op->encode_tunnel_password($tp, $op->{Client}->{Secret}, $tag);
		$p->change_attr('Tunnel-Password', $tp);
	    }
	    $rp->add_attr_list($p);

	    # Add and strip attributes before replying
	    $self->adjustReply($op, $rp);

	    # Run the reply hook if there is one
	    if (defined $self->{ReplyHook})
	    {
		# We use an eval so an error in the hook wont 
		# kill us.
		eval{ &{$self->{ReplyHook}}(\$p, \$rp, \$op, \$sp); };
		&main::log($main::LOG_ERR, "Error in ReplyHook(): $@")
		    if $@;
	    }

	    # Maybe cache the results in case we lose contact with 
	    # the remote server later
	    if (defined $self->{CachePasswords})
	    {
		$self->cacheReply($op, $rp)
		    if $p->code eq 'Access-Accept';
		$self->clearCachedReply($op)
		    if $p->code eq 'Access-Reject';
	    }

	    # RadiusResult tells Synchronous mode that we have
	    # finished with this packet and what the result was
	    if (defined $self->{Synchronous})
	    {
		if ($p->code eq 'Access-Accept'
		    || $p->code eq 'Accounting-Response')
		{
		    $op->{RadiusResult} = $main::ACCEPT; 
		}
		elsif ($p->code eq 'Access-Challenge')
		{
		    $op->{RadiusResult} = $main::CHALLENGE; 
		}
		else
		{
		    $op->{RadiusResult} = $main::REJECT; 
		}
	    }
	    else
	    {
		# Send this new reply packet back to wherever the 
		# original packet came from
		$op->{Client}->replyTo($rp, $op)
		    unless defined $self->{IgnoreReject} 
		           && $p->code eq 'Access-Reject';
	    }
	}
	else
	{
	    &main::log($main::LOG_WARNING, 
			      "Reply received for unknown request ID $identifier");
	}
	return 1; # we got something
    }
}

#####################################################################
# handle_timeout
# This is called from within Select::process_timeouts for each packet
# we have forwarded but not received a reply within the timeout period
# All we do is call the per-instance method for the instance that
# set the timeout. The args are the same as were passed to add_timeout
# fp is the packet we forwarded, $p is the original request packet, 
# $rp is the reply packet currently being constructed, and whic
# was originally passsed to handle_request as $rp
sub handle_timeout
{
    my ($handle, $this, $fp, $p, $rp) = @_;

    $this->timeout($fp, $p, $rp);
}

#####################################################################
# timeout
# 
sub timeout
{
    my ($self, $fp, $p, $rp) = @_;

    my ($port, $addr) = Socket::unpack_sockaddr_in($fp->{SendTo});

    my $key = $port.$addr.$fp->identifier;
    $key = 'BROKENPORT'.$addr.$fp->identifier 
	if defined $self->{ServerHasBrokenPortNumbers};

    if ($fp->{Retries}++ < $self->{Retries})
    {
	# We havent exhausted our retries, retransmit
	my $now = time;

	# REVISIT: need a log message here?

	# Need special treatment for retrans of Accounting-Requests
	# and anything else with Acct-Delay in it. Retransmission
	# requires that Acct-Delay be increased, which requires that
	# the Identifier be changed, which means we have to save
	# a new packet in the PendingRequests list. Gag.
	if (defined $fp->getAttrByNum($Radius::Radius::ACCT_DELAY_TIME))
	{
	    # Remove the old last transmission from our pending list
	    $pendingRequests{$key} = undef;
	    
	    # Create a new identifier
	    $fp->set_identifier($self->next_identifier);

	    # Change the Acct-Delay
	    $fp->changeAttrByNum($Radius::Radius::ACCT_DELAY_TIME, 
                $now - $p->{RecvTime});
	    $key = $port.$addr.$fp->identifier;
	    $key = 'BROKENPORT'.$addr.$fp->identifier 
		if defined $self->{ServerHasBrokenPortNumbers};

	    # Save the new packet in PendingRequests list
	    $pendingRequests{$key} 
	        = [ $p, $fp, $rp ];
	}

        my $id = $fp->identifier;
        $self->log($main::LOG_DEBUG, "Timed out, retransmitting");

	# Now resend it to the same place as before
	$fp->assemble_packet($self->{Secret});
	$fp->sendTo($self->getSock(), $fp->{SendTo});

	# And register another timeout
	$fp->{TimeoutHandle} = 
	    &Radius::Select::add_timeout($now + $self->{RetryTimeout},
				 \&Radius::AuthRADIUS::handle_timeout,
				 $self, $fp, $p, $rp);
    }
    else
    {
	# No reply after all the retries, so silently drop it
	# Cross it off our pending list
	$pendingRequests{$key} = undef;
	
	$self->log($main::LOG_INFO, 
			  "AuthRADIUS: No reply after $self->{Retries} retransmissions to $port for $p->{OriginalUserName}  ($p->{Identifier})");
	$self->forwardToNextHost($fp, $p, $rp, $port);
    }
}

#####################################################################
# next_identifier
# Return the next identifier to be used 
sub next_identifier
{
    my ($self) = @_;

    return $self->{NextIdentifier} = ($self->{NextIdentifier} + 1) % 256;
}


#####################################################################
# forwardToNextHost
# Send the packet to the next host in the list of hosts
# for this RADIUS. We use Retries and HostRetries stored in the 
# forwarded request packet to tell where we are up to in the list
# of hosts and retries for each host
# $fp is the packet that was sent to the remote server
# $p is the original requets packet
# $rp is the reply packet under construction
sub forwardToNextHost
{
    my ($self, $fp, $p, $rp, $port) = @_;

tryagain:
    my $hostlist = $self->{Host}[$fp->{HostRetries}++];

    if (defined $hostlist)
    {
	# Choose the "next" address in the round-robin list
	my $addr = $hostlist->[$self->{roundRobinCounter}++ % @$hostlist];
	$fp->{Retries} = 0;
	my $destport = Socket::pack_sockaddr_in($port, $addr);

	# Remember it. We keep a hash where the key is the 
	# port and address
	# of the host we sent to, concated with the identifier
	$port = 'BROKENPORT' if defined $self->{ServerHasBrokenPortNumbers};
	$pendingRequests{$port.$addr.$fp->identifier} 
        = [ $p, $fp, $rp ];
	
	# and send it
	$fp->assemble_packet($self->{Secret});
	$fp->sendTo($self->getSock(), $destport);
	
	# Arrange for retransmission timeout
	# We remember the timeout handle so we can remove 
	# it if we get a reply
	$fp->{TimeoutHandle} = 
	    &Radius::Select::add_timeout(time + $self->{RetryTimeout},
			   \&Radius::AuthRADIUS::handle_timeout,
			   $self, $fp, $p, $rp);
    }
    else
    {
	# There was no reply from any host.

	# See if we have a cached reply from before
	if (defined $self->{CachePasswords})
	{
	    my $cachedreply = $self->cachedReply($p);
	    if ($cachedreply)
	    {
		$self->log($main::LOG_DEBUG, 
			   "AuthRADIUS: Using cached reply");	
		$cachedreply->set_identifier($p->identifier());
		$cachedreply->set_authenticator($p->authenticator());
		$p->{Client}->replyTo($cachedreply, $p);
	    }
	    else
	    {
		$self->log($main::LOG_INFO, 
			   "AuthRADIUS: No response from any RADIUS hosts, and no cached password available. Ignoring");
	    }
	}
	else
	{
	    $self->log($main::LOG_INFO, 
		       "AuthRADIUS: No response from any RADIUS hosts. Ignoring");
	}

	# RadiusResult tells Synchronous mode that we have
	# finished with this packet and what the result was
	$p->{RadiusResult} = $main::IGNORE; 

	# Run the no-reply hook if there is one
	if (defined $self->{NoReplyHook})
	{
	    # We use an eval so an error in the hook wont 
	    # kill us.
	    eval{ &{$self->{NoReplyHook}}(\$p, \$fp, \$rp); };
	    &main::log($main::LOG_ERR, "Error in NoReplyHook(): $@")
		if $@;
	}
    }
}

#####################################################################
# Record the fact that an access request was accepted, so we can
# maybe refer to it later if we lose contact with the remote server
# $p is the original request, $rp is the resulting reply
# Only PAP passwords can be cached
sub cacheReply
{
    my ($self, $p, $rp) = @_;

    my $user_name = $p->getUserName();
    my $password = $p->decodedPassword();
    if (defined $password)
    {
	$passwordCache{$user_name} = [time, $password, $rp];
    }
}

#####################################################################
sub clearCachedReply
{
    my ($self, $p, $rp) = @_;

    my $user_name = $p->getUserName();
    delete $passwordCache{$user_name};
}

#####################################################################
# Look for a previously cached password and reply for this user
sub cachedReply
{
    my ($self, $p) = @_;

    
    my $user_name = $p->getUserName();
    my $submitted_password = $p->decodedPassword();
    if (exists $passwordCache{$user_name})
    {
	# Get the cached password, and the time it was accepted
	my ($time, $password, $rp) = @{$passwordCache{$user_name}};
	if ($time > time - $self->{CachePasswordExpiry}
	    && $submitted_password eq $password)
	{
	    return $rp;
	}
    }
    return undef; # No suitable cached reply available
}

#####################################################################
# Add a new host to the list of hosts to proxy to.
# The host name is resolved to a list of addresses
# The host name may consist of multiple names separated by 
# commas
sub addHost
{
    my ($self, $hname) = @_;

    my $host;
    foreach $host (split(/\s*,\s*/, $hname))
    {
	# If there are multiple addresses, remember them 
	# for round-robin
	my ($name, $aliases, $addrtype, $length, @addrs) 
	    = gethostbyname($host);
	# Check that there is a valid address for this name
	if (@addrs)
	{
	    push(@{$self->{Host}}, \@addrs);
	}
	else
	{
	    $self->log($main::LOG_WARNING, 
		       "Host $hname has no IP address at '$main::config_file' line $.")
	}
    }
}

1;