File Coverage

blib/lib/Net/Radius/Server/PAM.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Net::Radius::Server::PAM;

use 5.008;
use strict;
use warnings;
use Authen::PAM;
use Carp qw/croak/;
use Net::Radius::Packet;
use base qw/Net::Radius::Server::Match Net::Radius::Server::Set::Simple/;
use Net::Radius::Server::Base qw/:all/;

our $VERSION = do { sprintf "%0.3f", 1+(q$Revision: 75 $ =~ /\d+/g)[0]/1000 };

__PACKAGE__->mk_accessors(qw/service store_result/);

sub mk { croak __PACKAGE__ . " factories are ->fmatch() and ->fset()\n" }

sub fmatch	{ Net::Radius::Server::Match::mk(@_); }
sub fset	{ Net::Radius::Server::Set::mk(@_); }

sub _delay_dummy { 1; }

sub _pam_init
{
    my $self = shift;
    my $r_data = shift;

    my $store = '_pamh';
    $store = $self->store_result if $self->store_result;

    if ($r_data->{$store})
    {
	$self->log(4, "Already authenticated");
	return PAM_SUCCESS();
    }

    my $req = $r_data->{request};
    my $secret = $r_data->{secret};

    my $u_attr = 'User-Name';
    my $p_attr = 'User-Password';

    # Fail if no user and password
    return PAM_ABORT() unless $req->attr($u_attr) and $req->attr($p_attr);

    my $user = $req->attr($u_attr);
    my $pass = $req->password($secret, $p_attr);

    my $pamh = new Authen::PAM
	(
	 ($self->service || 'login'), $user, sub
	 {
	     my @res;
	     while (@_)
	     {
		 my $msg_type = shift;
		 my $msg = shift;
		 $self->log(4, "(_conv_f) $msg_type -> $msg");
		 push @res, (0, $pass);
	     }
	     push @res, PAM_SUCCESS();
	     return @res;
	 },
	 );

    unless (ref($pamh))
    {
	$self->log(2, "Failed to init PAM: $pamh");
	return PAM_ABORT();
    }

    if ($pamh->pam_fail_delay(0) != PAM_SUCCESS()
	and $pamh->pam_set_item(PAM_FAIL_DELAY(),
				\&_delay_dummy) != PAM_SUCCESS())
    {
	$self->log(2, "Cannot avoid PAM delay on failure");
    }

    my $res = $pamh->pam_authenticate(0x0);
    if ($res == PAM_SUCCESS())
    {
	$self->log(4, "Store pamh in $store");
	$r_data->{$store} = $pamh;
	$self->log(4, "Authentication succesful");
    }
    else
    {
	$self->log(2, "Failed to authenticate: $res");
    }

    return $res;
}

sub _match
{
    my $self = shift;
    my $r_data = shift;

    if ($self->_pam_init($r_data, @_) == PAM_SUCCESS())
    {
	return NRS_MATCH_OK;
    }
    else
    {
	return NRS_MATCH_FAIL;
    }
}

sub _set
{
    my $self = shift;
    my $r_data = shift;

    $self->code('Access-Accept') unless $self->code;

    return NRS_SET_CONTINUE
	unless $self->_pam_init($r_data, @_) == PAM_SUCCESS();

    my $store = '_pamh';
    $store = $self->store_result if $self->store_result;

    my $pamh = $r_data->{$store};
    my $req = $r_data->{request};
    my $res = $r_data->{response};

    # Convert environment to RADIUS attribues;
    my %env = $pamh->pam_getenvlist;
    while (my ($k, $v) = each %env)
    {
	next unless defined $r_data->{dict}->attr_num($k);
	$self->log(4, "Set attr $k => $v");
	$res->set_attr($k, $v);
    }

    $self->SUPER::_set($r_data, @_);
}

42;

__END__