# load some configuration variables
use vars qw(%root $base);

use Net::LDAP;
BEGIN {
	local $^W = 0;
	no strict;
	require Net::SSLeay;
	require Net::LDAPS;
};

if ($ENV{ROOT}) {
	$base = $ENV{ROOT};
} else {
	# try to bootstrap
	sub try_bootstrap_dir {
		my ($x)=(@_);
		return ((-d "$x/env" || -f "$x/env") && (-d "$x/root")) ? 1 : undef;
	}
	my $s = $ENV{SESSION} || 'ldapdns';
	if ($ENV{HOME} && &try_bootstrap_dir($ENV{HOME} . '/.ldapdns')) {
		# home directory is best
		$base = $ENV{HOME} . "/.$s";
	} elsif (&try_bootstrap_dir("/.$s")) {
		# root is good too (ick)
		$base = '/.ldapdns';
	} else {
		my $x = $0;
		if ($x !~ /^\//) {
			# need to relate from here
			my $cwd = `pwd`;
			chomp $cwd;
			$x = "$cwd/$x";
		}

		# remove last element
		$x =~ s/\/+[^\/]+$//;
		if (&try_bootstrap_dir($x)) {
			$base = $x;
		} elsif (&try_bootstrap_dir("$x/.config")) {
			$base = "$x/.config";
		} elsif (&try_bootstrap_dir("$x/config")) {
			$base = "$x/config";
		} else {
			# require the ENVironment variable
			die '$ROOT is unset';
		}
	}
}

if (-d "$base/env" && opendir(DIR, "$base/env")) {
	foreach my $i (readdir(DIR)) {
		next unless (-f "$base/env/$i" && open(FI, "<$base/env/$i"));
		$ENV{$i} = join('', <FI>);
		$ENV{$i} =~ s/[\r\n\t]+$//;
		$ENV{$i} =~ s/[\r\n\t]/ /g;
		close(FI);
	}
	closedir(DIR);
}

if (-d "$base/root" && opendir(DIR, "$base/root")) {
	foreach my $i (readdir(DIR)) {
		next unless (-f "$base/root/$i" && open(FI, "<$base/root/$i"));
		$root{$i} = join('', <FI>);
		$root{$i} =~ s/[\r\n\t]+$//;
		$root{$i} =~ s/[\r\n\t]/ /g;
		close(FI);
	}
	closedir(DIR);
}

sub get_ldap_conn
{
	die '$LDAP_HOST is unset' unless ($ENV{LDAP_HOST} || $ENV{LDAP_HOSTS});
	die '$LDAP_BINDDN is unset' unless ($ENV{LDAP_BINDDN});
	die 'root/password was unreachable/nonpresent' unless ($root{password});

	my $ldap;
	foreach my $i (split /[\ ;,]/, join(",", $ENV{LDAP_HOST}, $ENV{LDAP_HOSTS})) {
		my ($a, $p) = split /:/, $i;
		if (!defined($p) || $p < 1) {
			$ldap = Net::LDAPS->new($a);
		} else {
			$ldap = Net::LDAPS->new($a, port => $p);
		}
		if (!defined($ldap)) {
			if (!defined($p) || $p < 1) {
				$ldap = Net::LDAP->new($a);
			} else {
				$ldap = Net::LDAP->new($a, port => $p);
			}
			next unless (defined($ldap));

			my $ev = $ENV{"TRUSTED_NETWORK"};
			if ($ev) {
				print STDERR "TLS/SSL is not available... connecting anyway\n";
			} else {
				die 'set $TRUSTED_NETWORK to connect to LDAP server without using SSL/TLS';
			}
		}

		if ($ldap->bind(dn => $ENV{LDAP_BINDDN},
				password => $root{password})) {
			return $ldap;
		}

		undef $ldap;
	}
	die "Unable to reach any LDAP servers";
}
sub dc_add_prefix
{
	my ($ldap, $domain)=(@_);
	my @p = split /\./, lc($domain);
	my @dc = ();

	shift @p; # leave off last element...

	foreach my $i (reverse @p) {
		push(@dc, 'dc=' . $i);
		my $cur_dn = join(', ', reverse @dc);
		if ($ENV{LDAP_SUFFIX}) {
			$cur_dn .= ', ' . $ENV{LDAP_SUFFIX};
		}
		my $ldc = substr($dc[$#dc], 3);
		my $m = $ldap->add($cur_dn,
			attr => [
				dc => $ldc,
				objectClass => 'dnsDomain',
				objectClass => 'dcObject',
			]);

		if ($m->code) {
			next if ($m->error =~ /Already exists/);
			die("Failed to add suffix: $cur_dn    ", $m->error);
		}
	}

}
sub dc_domain
{
	my ($domain)=(@_);
	my @p = split /\./, lc($domain);
	return $p[0];
}
sub dn_domain
{
	my ($domain)=(@_);

	my @p = split /\./, lc($domain);

	my $dc = 'dc=' . join(', dc=', @p);
	if ($ENV{LDAP_SUFFIX}) {
		$dc .= ', ' . $ENV{LDAP_SUFFIX};
	}
	return $dc;
}
sub add_record
{
	my ($ldap, $dn, $attr, $add)=(@_);

	&dc_add_prefix($ldap, $dn);

	# search to see if the attribute exists
	if (defined($add)) {
		my $search = '';
		while (my ($k,$v)=each(%$add)) {
			$search .= "($k=$v)";
		}
		my $mesg = $ldap->search(base => &dn_domain($dn),
					scope=>'base',
					filter => '(&' . $search . ')');
		if ($mesg->count != 0) {
			return 1;
		}
	}

	$mesg = $ldap->add(&dn_domain($dn), attr => $attr);
	if ($mesg->code) {
		if ($mesg->error =~ /Already Exists/i && defined($add)) {
			$mesg = $ldap->modify(&dn_domain($dn), add => $add);
			die "Failed to modify entry: $dn    " . $mesg->error
				if ($mesg->code);
		} else {
			die "Failed to add entry: ", &dn_domain($dn),
			"    " . $mesg->error;
		}
	}
	return 1;
}
sub set_record
{
	my ($ldap, $dn, $attr, $modify)=(@_);

	my $mesg = $ldap->modify(&dn_domain($dn), replace => $modify);
	if ($mesg->code) {
		if ($mesg->error =~ /No such object/i) {
			return add_record($ldap, $dn, $attr);
		}
		die "Failed to modify entry: $dn    " . $mesg->error;
	}
	return 1;
}
sub dnsencode
{
	my ($z)=(@_);

	$z =~ s/\.$//;
	my $local = undef;
	if ($z =~ s/^([^@]+)\@//) {
		$local = pack('C', length($1)) . $1;
	}
	$z =~ s/\.([^\.]+)/pack('C', length($1)) . $1/sg;
	$z =~ s/^([^\.]+)/pack('C', length($1)) . $1/sg;
	$z .= pack('C', 0);
	if (defined($local)) {
		$z = $local . $z;
	}
	return $z;
}
sub pack_generic_record
{
	my ($rr, $format, @vars)=(@_);
	# this takes a specification in the form similar to perl's own
	# pack statement. it is very stupid, so go easy on it.

	# n short
	# N long
	# A dns-packed string (compressed)
	# a dns-encoded string

	my $outstr = '';
	while (length($format) > 0) {
		$format =~ s/^\s*//;
		if ($format =~ s/^\s*([nNaA])\s*([0-9]*)//) {
			my ($k, $v)=($1, $2);
			$v ||= 1;

			my @arg = ();
			for (my $i = 0; $i < $v; $i++) {
				my $x = shift @vars;
				push(@arg, $x);
			}

			if ($k eq 'a' || $k eq 'A') {
				if ($k eq 'A') {
					$outstr .= pack('C', 0xFF);
				}
				foreach my $j (@arg) {
					my $qs = dnsencode($j);
					if ($k eq 'a') {
						$qs =~ s/\xFF/\xFF\x00/sg;
					}
					$outstr .= $qs;
				}
			} else {
				my $qs = pack($k . $v, @arg);
				$qs =~ s/\xFF/\xFF\x00/sg;
				$outstr .= $qs;
			}
		}
	}
	if (!defined($rr) || $rr =~ /\D/) {
		die("rr must be numeric");
	}
	return pack('n', $rr) . length($outstr) . $outstr;
}

1;