#!/usr/bin/perl
#
# Brent Baccala <baccala@freesoft.org>     26 Sep 2000
#
# This script corrects the various protocol violations by the Microsoft
# NetMeeting client.  It 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 various openldap client
# programs.
#
# 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.
#
# TODO
# - timeout of entries
#   Currently, if a client dies without deregistering itself, that DN
#   (basically, that email address) will remain permanently unavailable
#   since any add request on it will return entryAlreadyExists



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 = "/tmp/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");


sub dn2rdns {
    my ($dn) = @_;

    return split / *[,;] */, $dn;
}



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();
	my $timestamp = time();

	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);
		} elsif ($1 eq "timestamp") {
		    $timestamp = $line;
		} else {
		    $entry->add($1 => $line);
		}
	    }
	}

	# NetMeeting doesn't give an objectclass attribute
	$entry->add(objectclass => "RTPerson");

	# We use a non-non-standard way of timing out entries.  We don't
	# use the standard way (RFC 2589) because OpenLDAP doesn't support
	# it yet.  We don't use the non-standard way (Microsoft) because
	# it doesn't allow for permanent entries.  We use our own way -
	# the entry is dynamic unless a "timestamp" attribute is
	# specified with a value of zero.  Otherwise, "timestamp" is
	# the Perl time() the entry was added or last modified, and
	# we limit the results of our search requests to entries
	# updated within the last 30 minutes (1800 seconds).
	$entry->add(timestamp => $timestamp);

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

	# If an entry with the same name already exists, delete it to
	# make room for the new one.  This isn't exactly what the
	# Microsoft server does - it only deletes entries when they've
	# timed out, but the difference seems slight...

	if ($result->code == LDAP_ALREADY_EXISTS) {
	    $ldap->delete($entry->dn());
	    $result = $ldap->add($entry);
	}

	# NetMeeting adds database entries without making sure their parents
	# exist first.  This is a clear violation of the standard, and in fact
	# the server rejects it.  If the add just failed because the parent was
	# missing, the matchedDN in the result is "the name of the lowest
	# entry... in the directory that was matched" (RFC 2251).
	# We break the DNs down into their RDN components, add whatever
	# entries are between the matchedDN and the original DN,
	# then try the original add again.

	if ($result->code == LDAP_NO_SUCH_OBJECT) {
	    my @DN = &dn2rdns($entry->dn());
	    my @existingDN = &dn2rdns($result->dn());
	    my @newDN = ();

	    for (my $i=0; $i <= $#existingDN; $i ++) {
		unshift @newDN, pop @DN;
	    }

	    while ($#DN > 0) {
		unshift @newDN, pop @DN;
		my $newDN = join(",", @newDN);
		print TRACEFILE "Adding $newDN\n"
		    if defined $tracefile;
		$result = $ldap->add($newDN,
				     attrs => [ objectclass => "top" ]);
		print TRACEFILE "Result: ", $result->code, "\n"
		    if defined $tracefile;
		die "Couldn't add parent" if ($result->code != 0);
	    }

	    if ($result->code == 0) {
		print TRACEFILE "Adding (again) ", $entry->dn(), "\n"
		    if defined $tracefile;
		$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;
		    if ($changetype eq "delete") {
			print TRACEFILE "Delete $line\n" if defined $tracefile;
			$entry->delete($line);
		    }
		} 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);
		} else {
		    print TRACEFILE "Unknown $1 $line\n" if defined $tracefile;
		}
	    }
	}

	my $attempts = 3;
	my $result = $entry->update($ldap);
	if ($result->code == LDAP_NO_SUCH_OBJECT) {
	    my $attempts = 3;
	    do {
		sleep 1;
		print TRACEFILE "Trying update again...\n"
		    if defined $tracefile;
		$result = $entry->update($ldap);
	    } while ($result->code == LDAP_NO_SUCH_OBJECT and $attempts-- > 0);
	}
	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;
		}
	    }
	}

	# NetMeeting uses "%" for wildcarding, while the standard specifies "*"
	$filter =~ s/%/*/g;

	# NetMeeting has a bad habit of specifying "base" when it meant "sub"
	$scope = "sub";

	# Note whether all attributes (the '*' wildcard) were requested
	if (grep(/^\*$/, @attrs)) {
	    $allattrs = 1;
	}

	# NetMeeting uses a non-standard means of refreshing dynamic entries.
	# The Microsoft server maintains an "sttl" attribute, which is a
	# time to live for the entry in minutes.  A search request for
	# attribute "sttl" resets the timer.  If the timer goes to zero,
	# the entry is supposed to disappear from the database.  Of course,
	# the sttl attribute doesn't actually exist in the database, and
	# the client doesn't bother to give us the whole DN it wants updated,
	# only supplying the "cn" component.  This code intercepts such
	# requests and hands back to the client a response that'll keep
	# it happy.

	if ($filter =~ /\(cn=(.*)\)\(sttl=(.*)\)/ and ($attrs[0] eq "sttl")) {
	    my $cn = $1;
	    my $result = $ldap->search(base => "objectclass=rtperson",
				       filter => "(cn=$cn)",
				       attrs => []);
	    foreach my $entry ($result->entries) {
		print "dn: ", $entry->dn, "\n";
		print "cn: $1\n";
		print "sttl: 30\n\n";

		$entry->replace(timestamp => time());
		$entry->update($ldap);
	    }
	    return 0;
	}

	my @requestattrs = @attrs;
	push @requestattrs, "timestamp" if ($attrs[0] ne "*");
	my $result = $ldap->search(base => $base,
				scope => $scope,
				deref => $deref,
				sizelimit => $sizelimit,
				timelimit => $timelimit,
				typesonly => $attrsonly,
				filter => $filter,
				attrs => \@requestattrs);

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

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

		my $ttl = $entry->get_value('timestamp');

		next if ($ttl > 0 and ($ttl + 1800) < time());

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

		# NetMeeting requires we return attributes in exactly the
		# order they were requested by the client.  Of course, if
		# a wildcard was used to request all attributes, we just
		# return whatever the server gave us.

		if ($allattrs) {
		    @attrs = $entry->attributes();
		}
		foreach my $attr (@attrs) {
		    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;