File Coverage

blib/lib/Net/LDAP/Server.pm

Criterion	Covered	Total	%
statement	24	85	28.2
branch	0	24	0.0
condition	0	6	0.0
subroutine	8	12	66.6
pod	2	2	100.0
total	34	129	26.3

# ===========================================================================
# Net::LDAP::Server
#
# LDAP server side protocol handling
#
# Alessandro Ranellucci
# Hans Klunder
# Copyright (c) 2005-2007.
#
# See below for documentation.
#
package Net::LDAP::Server;
use strict;
use warnings;

use Convert::ASN1 qw(asn_read);
use Net::LDAP::ASN qw(LDAPRequest LDAPResponse);
use Net::LDAP::Constant qw(LDAP_OPERATIONS_ERROR LDAP_UNWILLING_TO_PERFORM);
use Net::LDAP::Entry;
use Data::Dumper;

our $VERSION = '0.43';
use fields qw(in out);

our %respTypes=(
	'bindRequest' => 'bindResponse',
	'unbindRequest' => '',
	'searchRequest' => 'searchResDone',
	'modifyRequest' => 'modifyResponse',
	'addRequest'  => 'addResponse',
	'delRequest' => 'delResponse',
	'modDNRequest' => 'modDNResponse',
	'compareRequest' => 'compareResponse',
	'extendedReq' => 'extendedResp',
	'abandonRequest' => ''
);
our %functions=(
	'bindRequest' => 'bind',
	'unbindRequest' => 'unbind',
	'searchRequest' => 'search',
	'modifyRequest' => 'modify',
	'addRequest'  => 'add',
	'delRequest' => 'delete',
	'modDNRequest' => 'modifyDN',
	'compareRequest' => 'compare',
	'extendedReq' => 'extended',
	'abandonRequest' => 'abandon'
);
our @reqTypes = keys %respTypes;

sub new {
    my ($proto, $input, $output) = @_;
	my $class = ref($proto) || $proto;
	my $self = fields::new($class);

    #print STDERR Dumper($input);
    #print STDERR Dumper($output);

	$self->{in} = $input;
	$self->{out} = $output || $input;
	return $self;
}

sub handle {
	my Net::LDAP::Server $self = shift;
	my $in = $self->{in};
	my $out = $self->{out};

    #print STDERR Dumper($in);
    #print STDERR Dumper($out);

	asn_read($in, my $pdu);
	#print '-' x 80,"\n";
	#print "Received:\n";
	#Convert::ASN1::asn_dump(\*STDOUT,$pdu);
	my $request = $LDAPRequest->decode($pdu);
	my $mid = $request->{'messageID'}
		or return 1;

	#print "messageID: $mid\n";
	#print Dumper($request);

	my $reqType;
	foreach my $type (@reqTypes) {
		if (defined $request->{$type}) {
			$reqType = $type;
			last;
		}
	}
	return 1 if !exists $respTypes{$reqType};  # unknown request type: let's hangup
	my $respType = $respTypes{$reqType};

	# here we can do something with the request of type $reqType
	my $reqData = $request->{$reqType};
	my $method = $functions{$reqType};
	my $result;
	if ($self->can($method)){
		if ($method eq 'search') {
			my @entries;
			eval { ($result,@entries) = $self->search($reqData, $request) };

			foreach my $entry (@entries) {
				my $data;
				# default is to return a searchResEntry
				my $sResType = 'searchResEntry';
				if (ref $entry eq 'Net::LDAP::Entry') {
					$data = $entry->{'asn'};
				} elsif (ref $entry eq 'Net::LDAP::Reference') {
					$data = $entry->{'asn'};
					$sResType = 'searchResRef';
				} else{
					$data = $entry;
				}

				my $response;
				#  is the full message specified?
				if (defined $data->{'protocolOp'}) {
					$response = $data;
					$response->{'messageID'} = $mid;
				} else {
					$response = {
						'messageID' => $mid,
       				   	'protocolOp' => {
	       			   		 $sResType => $data
	       		   		}
	       		   	};
				}
				my $pdu = $LDAPResponse->encode($response);
				if ($pdu) {
					print $out $pdu;
				} else {
					$result = undef;
					last;
				}
			}
		} else {
			eval { $result = $self->$method($reqData, $request) };
		}
		$result = _operations_error() unless $result;
	} else {
		$result = {
			'matchedDN' => '',
			'errorMessage' => sprintf("%s operation is not supported by %s", $method, ref $self),
			'resultCode' => LDAP_UNWILLING_TO_PERFORM
		};
	}

	# and now send the result to the client
	print $out &_encode_result($mid, $respType, $result) if $respType;

	return 0;
}

sub _encode_result {
	my ($mid, $respType, $result) = @_;

	my $response = {
		'messageID' => $mid,
      	'protocolOp' => {
			$respType => $result
		}
	};
	my $pdu = $LDAPResponse->encode($response);

	# if response encoding failed return the error
	if (!$pdu) {
		$response->{'protocolOp'}->{$respType} = _operations_error();
		$pdu = $LDAPResponse->encode($response);
	};

	return $pdu;
}

sub _operations_error {
	my $err = $@;
	$err =~ s/ at .+$//;
	return {
		'matchedDN' => '',
		'errorMessage' => $err,
		'resultCode' => LDAP_OPERATIONS_ERROR
	};
}

1;

__END__