package Yaa::LookupMap::Driver::LDAP;

# inherit everything from Yaa::LookupMap
@ISA = qw(Yaa::LookupMap);

# set debugging constant if YAA_DEBUG environment variable is set
BEGIN {
	use constant DEBUG => ((defined $ENV{YAA_DEBUG}) ? 1 : 0);
	require File::Basename if (DEBUG);
}

use strict;
use Net::LDAP;
use Net::LDAP::Filter;

use vars qw($VERSION);

=head1 NAME

Yaa::LookupMap::Driver::LDAP - ldap lookup map driver

This driver queries LDAP backend in order to perform lookup.

WARNING: Do not use this class standalone!

=cut

=head1 SYNOPSIS

my $ldap_map = Yaa::LookupMap->factory(

	driver => 'SQL',
);

my $result = $ldap_map->lookup($key);

# prints out column some_column if sql query returned anything

print $result->getMatchValueByKey('some_atttr') if (defined $result);

B<Result keys>: This driver returns result object with keys B<named by attributes returned by LDAP search>.

=cut

######################################################
#                GLOBAL VARIABLES                    #
######################################################
my $VERSION = "0.1";

######################################################
#               OBJECT CONSTRUCTOR                   #
######################################################

=head1 OBJECT CONSTRUCTOR

Object constructor options:

B<ldap_host> - hostname or LDAP URI ldap server address (default: localhost)

B<ldap_port> - ldap server port (default: 389)

B<ldap_version> - ldap protocol version {2|3} (default: 3)

B<ldap_tls> - start TLS/SSL secured session after connect {0|1} (default: 0)

B<ldap_tls_verify> - certificate very mode {'none' | 'optional' | 'require'} (default: none)

B<ldap_tls_sslversion> - TLS/SSL version to use {'sslv2' | 'sslv3' | 'sslv2/3' | 'tlsv1'} (default: tlsv1)

B<ldap_tls_ciphers> - cipher suite to use (default: ALL)

B<ldap_tls_clientcert> - client certificate file (default: undef)

B<ldap_tls_clientkey> - client key file (default: undef)

B<ldap_tls_capath> - ca directory (default: undef)

B<ldap_tls_cafile> - ca file (default: undef)

B<ldap_bind> - bind to ldap server? {0|1} (default: 0)

B<ldap_bind_dn> - ldap bind distinguished name (default: undef)

B<ldap_bind_pw> - ldap bind password (default: undef)
	
B<ldap_search_base> - ldap search base (default: undef)

B<ldap_search_scope> - ldap search scope {'base' | 'one' | 'sub'} (default: sub)

B<ldap_search_deref> - deref object aliases during search? {'never' | 'search' | 'find' | 'always'} (default: never)

B<ldap_search_timelimit> - search time limit in seconds (default: 10)

B<ldap_search_sizelimit> - maximum number of search results (default: 100)

B<ldap_search_attrs> - array of returned search attributes. result object will contain the same keys (default: undef)

B<ldap_search_filter> - ldap search filter (default: undef)

B<debug> - object debug { 0 - 8 } (default: 0)

The ldap_search_filter option can contain one or more of the following magic placeholders:

- B<%m>: complete email address (user@example.org)

- B<%u>: user part of email address (user)

- B<%d>: domain part of email address (example.org)

B<Warning>:
if LDAP query returns more than one attribute with the same name
(objectClass attribute is often defined more than once),
result object will contain key named after several times defined attribute in ldap search result 
and the key value will contain values of all several times defined attributes separated with '\n' character.

=cut
sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	
	# call parent constructor
	my $self = Yaa::LookupMap->new();

	##################################################
	#               PUBLIC VARS                      #
	##################################################
	
	##################################################
	#              PRIVATE VARS                      #
	##################################################
	# ldap connection
	$self->{_ldap} = undef;

	bless($self, $class);
	
	# clear parameters
	$self->clearParams();

	# set object properties	
	$self->setParams(@_);

	return $self;
}

sub clearParams {
	my ($self) = @_;
	
	$self->_ldapDisconnect();
	$self->{error} = undef;
	
	# host data
	$self->{ldap_host} = "localhost";
	$self->{ldap_port} = 389;
	
	# protocol version
	$self->{ldap_version} = 3;

	# secure communication
	$self->{ldap_tls} = 0;
	$self->{ldap_tls_verify} = 'none';
	$self->{ldap_tls_sslversion} = 'tlsv1';
	$self->{ldap_tls_ciphers} = 'ALL';
	$self->{ldap_tls_clientcert} = undef;
	$self->{ldap_tls_clientkey} = undef;
	$self->{ldap_tls_capath} = undef;
	$self->{ldap_tls_cafile} = undef;

	# bind creds.
	$self->{ldap_bind} = 0;
	$self->{ldap_bind_dn} = undef;
	$self->{ldap_bind_pw} = undef;
	
	# search settings
	$self->{ldap_search_base} = undef;
	$self->{ldap_search_scope} = 'sub';
	$self->{ldap_search_deref} = 'never';
	$self->{ldap_search_timelimit} = 10;
	$self->{ldap_search_sizelimit} = 100;
	@{$self->{ldap_search_attrs}} = [];
	$self->{ldap_search_filter} = undef;
	
	# debug
	$self->{debug} = DEBUG;

	return 1;
}

####################################################
#               PRIVATE METHODS                    #
####################################################

sub _lookup {
	my ($self, $key) = @_;
	return undef unless ($self->_ldapConnect());
	if (! defined $key) {
		$self->{error} = "Unable to search by undefined search key.";
		return undef;
	}
	elsif (! defined $self->{ldap_search_filter}) {
		$self->{error}  = "Attribute ldap_search_filter is not defined.";
		return undef;
	}
	
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": startup.\n" if (DEBUG);

	# generate query filter
	my $filter = $self->_ldapGenerateFilter($key);

	# check search filter	
	unless (defined $filter) {
		$self->{error} = "Invalid search filter.";
		print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": ", $self->{error}, "\n" if (DEBUG);
		return undef;
	}
	
	# run search
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": performing ldap search.\n" if (DEBUG);
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": search base: ", $self->{ldap_search_base}, "\n" if (DEBUG);
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": search scope: ", $self->{ldap_search_scope}, "\n" if (DEBUG);
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": deref: ", $self->{ldap_search_deref}, "\n" if (DEBUG);
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": time limit: ", $self->{ldap_search_timelimit}, ", size limit: ", $self->{ldap_search_sizelimit}, "\n" if (DEBUG);
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": search filter: ", $filter->as_string(), "\n" if (DEBUG);
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": fetching attributes: ", join(", ", @{$self->{ldap_search_attrs}}), "\n" if (DEBUG);
	my $search = $self->{_ldap}->search(
		base => $self->{ldap_search_base},
		scope => $self->{ldap_search_scope},
		deref => $self->{ldap_search_deref},
		sizelimit => $self->{ldap_search_sizelimit},
		timelimit => $self->{ldap_search_timelimit},
		filter => $filter,
		attrs => [ @{$self->{ldap_search_attrs}}]
	);
	
	# check search
	if ($search->is_error()) {
		$self->{error} = "Error performing LDAP search: " . $search->error_desc();
		print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": ", $self->{error}, "\n" if (DEBUG);
		return undef;
	}

	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _lookup(), line ", __LINE__, ": ldap search returned ", $search->count(), " matches.\n" if (DEBUG);
	
	# construct result
	my $result = Yaa::LookupMap::Result->new();
	
	while (defined (my $entry = $search->shift_entry())) {
		my $r;
		foreach ($entry->attributes()) {
			$r->{$_} = join("\n", $entry->get_value($_));
		}
		$result->addMatch($r);
	}
	
	# this is it, folx
	return $result;
}

sub _ldapGenerateFilter {
	my ($self, $key) = @_;
	my ($user, $domain);
	
	if ($key =~ m/^([\w\-\.]+)@(.+)$/) {
		$user = $1; $domain = $2;
	} else {
		$user = $key;
	}
	
	my $str = $self->{ldap_search_filter};
	
	# %% -> %
	$str =~ s/%%/%/g;
	# %m -> $key
	$str =~ s/%m/$key/g;
	# %d -> $domain
	$str =~ s/%d/$domain/g;
	# %u -> $user
	$str =~ s/%u/$user/g;
	
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _ldapGenerateFilter(), line ", __LINE__, ": generated filter for lookup key '$key': '", $str, "'\n" if (DEBUG);
	return Net::LDAP::Filter->new($str);
}

sub _ldapConnect {
	my ($self) = @_;
	
	return 1 if (defined $self->{_ldap});
	
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _ldapConnect(), line ", __LINE__, ": Connecting to ldap server '", $self->{ldap_host}, "'\n" if (DEBUG);
	
	$self->{error} = undef;
	
	unless (defined $self->{ldap_host}) {
		$self->{error} = "Parameter ldap_host is not defined.";
		return 0;
	}

	# try to connect
	$self->{_ldap} = Net::LDAP->new(
		$self->{ldap_host},
		port => $self->{ldap_port},
		debug => $self->{ldap_debug},
		version => $self->{ldap_version}
	);
	
	# connected?
	unless (defined $self->{_ldap}) {
		$self->{error} = "Unable to connect to LDAP server: " . $@;
		print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _ldapConnect(), line ", __LINE__, ": ", $self->{error}, "\n" if (DEBUG);
		return 0;
	}
	
	# ssl/tls?
	if ($self->{ldap_tls} && $self->{ldap_version} eq '3') {
		my $result = $self->{_ldap}->start_tls(
			verify => $self->{ldap_tls_verify},
			sslversion => $self->{ldap_tls_sslversion},
			ciphers => $self->{ldap_tls_ciphers},
			clientcert => $self->{ldap_tls_clientcert},
			clientkey => $self->{ldap_tls_clientkey},
			capath => $self->{ldap_tls_capath},
			cafile => $self->{ldap_tls_cafile}
		);
		
		if ($result->is_error()) {
			$self->{error} = "Unable to start TLS/SSL: " . $result->error_desc();
			print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _ldapConnect(), line ", __LINE__, ": ", $self->{error}, "\n" if (DEBUG);
			goto end;
		}
	}
	
	# do we need to bind?
	if ($self->{ldap_bind}) {
		# anonymous bind?
		unless (defined $self->{ldap_bind_dn}) {
			my $result = $self->{_ldap}->bind();
			if ($result->is_error()) {
				$self->{error} = "Unable to bind to LDAP server: " . $result->error_desc();
				print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _ldapConnect(), line ", __LINE__, ": ", $self->{error}, "\n" if (DEBUG);
				goto end;
			}
		}
		
		# non anonymous bind
		my $result = $self->{_ldap}->bind($self->{ldap_bind_dn}, password => $self->{ldap_bind_pw});
		
		if ($result->is_error()) {
			$self->{error} = "Unable to bind to LDAP server: " . $result->error_desc();
			print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _ldapConnect(), line ", __LINE__, ": ", $self->{error}, "\n" if (DEBUG);
			goto end;
		}
	}
	
	end:
	if (defined $self->{error}) {
		$self->{_ldap} = undef;
		return 0;
	}
	
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _ldapConnect(), line ", __LINE__, ": Successfully connected.\n" if (DEBUG);
	return 1;
}

sub _ldapDisconnect {
	my ($self) = @_;
	
	return 1 unless (defined $self->{_ldap});
	my $result = $self->{_ldap}->disconnect();
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _ldapDisconnect(), line ", __LINE__, ": disconnecting from LDAP host.\n" if (DEBUG);
	$self->{_ldap} = undef;
	return $result;
}

sub DESTROY {
	my ($self) = @_;
	return $self->_ldapDisconnect();
}

1;

=head1 SEE ALSO

For general class usage, please see perldoc Yaa::LookupMap.

=cut

=head1 AUTHOR

Branko F. Gracnar <bfg@frost.ath.cx>
http://frost.ath.cx/~bfg

=cut

=head1 LICENSE

This software is released under BSD-style license. If you like this software, send me a nice postcard from somewhere to the snail mail address published on my website.

=cut

