File Coverage

blib/lib/Net/Radius/Server/Match/LDAP.pm

Criterion	Covered	Total	%
statement	21	21	100.0
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	28	28	100.0

#! /usr/bin/perl
#
#
# $Id: LDAP.pm 75 2009-08-12 22:08:28Z lem $

package Net::Radius::Server::Match::LDAP;

use 5.008;
use strict;
use warnings;

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

use Net::LDAP;
use Carp qw/croak/;
use Net::Radius::Server::Base qw/:match/;
use base qw/Net::Radius::Server::Match/;
__PACKAGE__->mk_accessors(qw/ldap_uri ldap_opts bind_dn bind_opts search_opts
			  store_result max_tries tls_opts authenticate_from
			  /);

sub _expand
{
    my $self = shift;
    my $r_list = shift || [];
    my $r_data = shift || {};

    my @r = ();

    die $self->description . ": Odd number of arguments\n"
	if @$r_list % 2;

    for (my $i = 0;
	 $i < @$r_list;
	 $i += 2)
    {
	my $k = $r_list->[$i];
	my $v = $r_list->[$i + 1];

	if ($k =~ m/^_nrs_(.+)$/ and ref($v) eq 'CODE')
	{
	    push @r, $1, $v->($self, $r_data);
	}
	else
	{
	    push @r, $k, $v;
	}
    }

    @r;				# Return the resulting set of arguments
}

sub _connect
{
    my $self = shift;
    my @args = $self->_expand($self->ldap_opts);

    $self->log(4, "Connecting to LDAP: " . $self->ldap_uri . " "
	       . join(', ', @args));

    $self->{_ldap} = Net::LDAP->new($self->ldap_uri, @args);

    die $self->description .
	": Failed to connect to LDAP server ", $self->ldap_uri, " ($!)\n"
	unless $self->{_ldap};
}

sub _bind
{
    my $self = shift;
    my $data = shift;

    $self->_connect($data, @_);

    my @args = $self->_expand($self->bind_opts, @_);

    my $dn = $self->bind_dn;

    if (ref($dn) eq 'CODE')
    {
	$dn = $dn->($self, $data, @_);
    }

    if ($self->authenticate_from)
    {
	my $attr = $self->authenticate_from;
	my $pass = undef;
	if (ref($attr) eq 'CODE')
	{
	    $pass = $attr->($self, $data, @_);
	}
	else
	{
	    $pass = $data->{request}->password($data->{secret}, $attr);
	}
	push @args, (password => $pass);
    }

    $self->log(4, "Binding to LDAP: " . ($dn || '(No DN)'));
    my $r = $self->{_ldap}->bind($dn, @args);

    # At this stage, a failure to bind is a fatal error...
    if ($r->code)
    {
	$self->log(2, "LDAP bind failure: ". $r->error);
	return;
    }
    return 1;
}

sub mk
{
    my $proto = shift;
    croak "->mk() cannot have arguments when in object-method mode\n"
	if ref($proto) and $proto->isa('UNIVERSAL') and @_;

    my $self = ref($proto) ? $proto : $proto->new(@_);
    die "Failed to create new object\n" unless $self;

    die $self->description . ": Must specify ldap_uri property\n"
	unless $self->ldap_uri;

    $self->_bind(@_) unless $self->authenticate_from;

    return sub { $self->_match(@_) };
}

sub match_ldap_uri
{
    my $self = shift;
    my $data = shift;

    my $r;
    my $tries = 0;

    if ($self->authenticate_from
	and not $self->_bind($data, @_))
    {
	$self->log(2, "Not matched due to bind() failure - Aborting");
	return NRS_MATCH_FAIL;
    }

    return NRS_MATCH_OK if $self->authenticate_from
	and not $self->search_opts;

    do
    {
	$r = $self->{_ldap}->search($self->_expand($self->search_opts,
						   $data, @_));;
	if ($r->code)
	{
	    # Let's do a few attempts to query just in case...
	    if ($tries++ > ($self->max_tries || 2))
	    {
		$self->log(2, "Failed to issue the query - Aborting");
		return NRS_MATCH_FAIL;
	    }

	    $self->log(2, "Failure to query: " . $r->error);
	    unless ($self->_bind($data, @_))
	    {
		$self->log(2, "bind() failure");
		return NRS_MATCH_FAIL if $self->authenticate_from;
	    }
	}
    } until (!$r->code);

    if ($self->store_result)
    {
	$self->log(4, "LDAP result stored");
	$data->{$self->store_result} = $r;
    }
    else
    {
	$self->log(4, "LDAP result discarded");
    }

    my $c = $r->count;
    if ($c)
    {
	$self->log(4, "LDAP query returned $c entries - match");
	return NRS_MATCH_OK;
    }
    else
    {
	$self->log(3, "LDAP query returned no entries - fail");
	return NRS_MATCH_FAIL;
    }
}

42;

__END__