#!/usr/bin/perl
#
# Brent Baccala <baccala@freesoft.org>     26 Sep 2000
#
# This script is designed for use with openldap's shell
# backend.  In the slapd.conf file, it should be configured as the
# external program for the operations "search", "add", "modify",
# "modrdn", and "delete".  It reads the requests from slapd on STDIN and
# forwards them to another LDAP server, using Graham Barr's Net::LDAP
# package.
#
# If you know nothing about LDAP, suffice it to say that we're dealing
# with a directory of objects, each identified by a unique
# Distinguished Name (DN) and each containing a list of attributes,
# each attribute possibly missing, non-unique or duplicated.  One of
# the most important attributes is "objectclass", which is an ASCII
# string defining the type of object.  The server uses a schema
# definition to define which attributes are possible and/or required
# for each objectclass.



use Net::LDAP qw(:all);
use Net::LDAP::Entry;
require MIME::Base64;


# The LDAP host and port to forward the requests to

$LDAPhost = "localhost";
$LDAPport = 2345;

# Trace file to see what this script is doing.
# Comment the line out if you don't want a trace file.

# $tracefile = "perl.out";

# Regular expression that matches attributes and pseudo-attributes that
# should be filtered out from add/modify requests, either because they
# aren't really attributes (msgid, suffix), or because they are generated
# by the server and would cause it to barf if set explicitly.

$ignores = "((msgid)|(suffix)|(creatorsName)|(createTimestamp)|(modifiersName)|(modifyTimestamp))";

# Regular expression that matches the possible changetypes that can
# appear in a change request.  See slapd.replog(5)

$changetypes = "((add)|(replace)|(delete)|(modrdn))";

# In a search request, the server feeds us the scope and dereference fields
# in the numeric form used by the protocol.  ldapsearch(1) takes these
# fields as arguments in symbolic form.  These arrays convert between
# the two representations.

@scopes = ("base", "one", "sub");
@derefs = ("never", "always", "search", "find");



# The main body of the script.  We're reading from an openldap server
# on STDIN, and it feeds us first an operation code, then various
# fields, depending on the operation.

sub process_request {

    my $ldap = Net::LDAP->new($LDAPhost, port => $LDAPport) or die;

    $ldap->bind or die;

    # The first line of input should be an operation code.

    my $operation = <>;
    chop($operation);

    print TRACEFILE "$operation\n" if defined $tracefile;

    if ($operation eq "ADD") {

	# This next code is lifted from Net::LDAP::LDIF
	# We can't use the LDIF routines directly because of the presence
	# of things like "msgid" that violate the LDIF standard.  Basically,
	# we suck in the rest of the input as a single variable, take care
	# of any newline+space continuation sequences, split the input
	# into lines, and interpret each one as an attribute/value pair,
	# taking care to do the Base64 decode if it was binary encoded.

	$/ = "";
	my $input = <>;
	$input =~ s/\n[ \t]//sg;
	chomp $input;

	my @lines;
	chomp(@lines = split(/^/, $input));

	my $entry = Net::LDAP::Entry->new();

	foreach my $line (@lines) {
	    next if ( $line =~ /^$ignores:/o );
	    print TRACEFILE $line, "\n" if defined $tracefile;
	    if ($line =~ s/^([-;\w]+):(:?)\s*//) {
		$line = MIME::Base64::decode($line) if ($2 eq ":");
		if ($1 eq "dn") {
		    $entry->dn($line);
		} else {
		    $entry->add($1 => $line);
		}
	    }
	}

	print TRACEFILE "Adding ", $entry->dn(), "\n" if defined $tracefile;
	my $result = $ldap->add($entry);
	print TRACEFILE "Result: ", $result->code, "\n" if defined $tracefile;

	return $result->code;

    } elsif ($operation eq "MODIFY") {

	# This is similar to the LDIF parsing routines, but not identical.
	# Each set of changes to an attribute is written as change block
	# that begins with a line of "<changetype>: <attributetype>" and
	# ends with a line containing a single "-".

	my $entry = Net::LDAP::Entry->new();
	$entry->changetype('modify');

	$/ = "";
	my $input = <>;
	$input =~ s/\n[ \t]//sg;
	chomp $input;

	my @lines;
	chomp(@lines = split(/^/, $input));

	my $changetype;
	foreach my $line (@lines) {
	    next if ( $line =~ /^$ignores:/o );
	    if ( $line eq "-") {
		undef $changetype;
		next;
	    }
	    # print TRACEFILE $line, "\n" if defined $tracefile;
	    if ($line =~ s/^([-;\w]+):(:?)\s*//) {
		$line = MIME::Base64::decode($line) if ($2 eq ":");
		if ($1 eq "dn") {
		    $entry->dn($line);
		} elsif ($1 =~ $changetypes) {
		    $changetype = $1;
		} elsif ($changetype eq "add") {
		    print TRACEFILE "Add $1 $line\n" if defined $tracefile;
		    $entry->add($1 => $line);
		} elsif ($changetype eq "replace") {
		    print TRACEFILE "Replace $1 $line\n" if defined $tracefile;
		    $entry->replace($1 => $line);
		} elsif ($changetype eq "delete") {
		    print TRACEFILE "Delete $1 $line\n" if defined $tracefile;
		    $entry->delete($1 => $line);
		}
	    }
	}

	my $result = $entry->update($ldap);
	return $result->code;

    } elsif ($operation eq "DELETE") {

	# This deletes an entire object, identified by its DN.  If you only
	# want to delete an attribute within an object, use MODIFY with
	# a changetype of "delete" on the attribute in question.

	my $dn;

	while (<>) {
	    if (/^dn: (.*)$/) {
		$dn = $1;
	    }
	}

	if (defined($dn)) {
	    print TRACEFILE "Deleting $dn\n"
		if defined $tracefile;
	    my $result = $ldap->delete($dn);
	    print TRACEFILE "Result: ", $result->code, "\n"
		if defined $tracefile;
	    return $result->code;
	}

    } elsif ($operation eq "MODRDN") {

	my $dn;
	my $rdn;
	my $deleteoldrdn = 0;

	while (<>) {
	    if (/^dn: (.*)$/) {
		$dn = $1;
	    } elsif (/^newrdn: (.*)$/) {
		$rdn = $1;
	    } elsif (/^deleteoldrdn: (.*)$/) {
		$deleteoldrdn = $1;
	    }
	}

	if (defined($dn) and defined($rdn)) {
	    print TRACEFILE "$dn -> $rdn\n"
		if defined $tracefile;
	    my $result = $ldap->moddn($dn,
				      newrdn => $rdn,
				      deleteoldrdn => $deleteoldrdn);
	    print TRACEFILE "Result: ", $result->code, "\n"
		if defined $tracefile;
	    return $result->code;
	}

    } elsif ($operation eq "SEARCH") {

	my ($base, $scope, $deref, $sizelimit, $timelimit, $filter);
	my ($attrsonly, @attrs);

	while (<>) {

	    print TRACEFILE if defined $tracefile;

	    if (/^base: (.*)$/) {
		$base = $1;
	    } elsif (/^scope: (.*)$/) {
		$scope = $scopes[$1];
	    } elsif (/^deref: (.*)$/) {
		$deref = $derefs[$1];
	    } elsif (/^sizelimit: (.*)$/) {
		$sizelimit = $1;
	    } elsif (/^timelimit: (.*)$/) {
		$timelimit = $1;
	    } elsif (/^filter: (.*)$/) {
		$filter = $1;
	    } elsif (/^attrsonly: (.*)$/) {
		$attrsonly = $1;
	    } elsif (/^attrs: (.*)$/) {
		if ($1 eq "all") {
		    @attrs = ();
		} else {
		    @attrs = split / /, $1;
		}
	    }
	}

	my $result = $ldap->search(base => $base,
				scope => $scope,
				deref => $deref,
				sizelimit => $sizelimit,
				timelimit => $timelimit,
				typesonly => $attrsonly,
				filter => $filter,
				attrs => \@attrs);

	if ($result->code == 0) {

	    foreach my $entry ($result->entries) {

		print "dn: ", $entry->dn, "\n";
		print TRACEFILE "dn: ", $entry->dn, "\n" if defined $tracefile;

		foreach my $attr ($entry->attributes) {
		    print TRACEFILE $attr, "\n" if defined $tracefile;
		    foreach my $value ($entry->get_value($attr)) {
			print $attr, ": ", $value, "\n";
		    }
		}
		print "\n";
	    }
	}

	return $result->code;
    }
}

if (defined $tracefile) {
    open(TRACEFILE, ">>$tracefile");
    print TRACEFILE "$operation\n";
}

$resultCode = eval { &process_request; };
$resultCode = 1 if not defined $resultCode;
$info = $@ if ($@);

print TRACEFILE "RESULT code $resultCode\n\n" if defined $tracefile;
print "RESULT\n";
print "code: $resultCode\n";
print "info: $info\n" if defined $info;