#!/usr/bin/env perl
# check-ldap-sync -- check LDAP replica status by comparing contextCSN
# (c) 2012-2017 Mantas Mikulėnas <grawity@gmail.com>
# Released under the MIT License <https://spdx.org/licenses/MIT>

use Getopt::Long;
use Net::LDAP;

my $err = 0;

my %F = (
	bold	=> "\e[1m",
	red	=> "\e[31m",
	yellow	=> "\e[33m",
	green	=> "\e[32m",
	reset	=> "\e[m",
);

%F = map {$_ => ""} keys %f if !-t 0;

sub uniq (@) { my %seen; grep { !$seen{$_}++ } @_; }

sub _tree_status {
	my ($tree, $status, $note) = @_;

	my %C = (
		ok => "green",
		degraded => "yellow",
		desynced => "red",
		down => "red",
	);
	my $C = $C{$status};
	my $str = "tree '$F{bold}$tree$F{reset}': ".
			"$F{bold}$F{$C}$status$F{reset}$F{$C}, $note$F{reset}";
	if ($status eq "ok") { print "$str\n"; } else { warn "$str\n"; ++$err; }
}

sub _warn {
	my ($msg) = @_;

	warn "$F{bold}$F{yellow}warning:$F{reset} $msg\n";
	++$err;
}

sub _err {
	my ($msg) = @_;

	warn "$F{bold}$F{red}error:$F{reset} $msg\n";
	++$err;
}

sub _die {
	my ($msg) = @_;

	_err($msg);
	exit 1;
}

sub dns_srv_lookup {
	my (@domains) = @_;

	map {[split / /]->[3]}
	grep {chomp || 1}
	map {`dig +short _ldap._tcp.$_. SRV`}
	@domains;
}

sub domain_to_dn {
	my (@domains) = @_;

	map {join ",", map {"dc=$_"} split /\./, $_}
	@domains;
}

sub usage {
	print for (
	"Usage: $0 [options]\n",
	"\n",
	"Check LDAP replica status by comparing contextCSN values.\n",
	"\n",
	#---'---|---'---|---'---|---'---
	"  -d, --domain DOMAIN   use this domain for SRV and baseDN\n",
	"  -h, --host HOST       check this server directly\n",
	"  -b, --base DN         check contextCSN on this LDAP entry\n",
	"  --config              add cn=config to automatic base DNs\n",
	"\n",
	"  --[no-]srv            find servers via DNS SRV records\n",
	"                        (always on unless --host specified)\n",
	"\n",
	"  --[no-]starttls       use StartTLS (on by default)\n",
	"\n",
	"If --base is not specified, by default 'cn=config' and 'dc=...' for every",
	" provided domain will be checked (e.g. 'dc=example,dc=com' for example.com).\n",
	);
}

my @domains;
my @hosts;
my @trees;
my $add_from_srv = 0;
my $add_config = 0;
my $start_tls = 1;

GetOptions(
	"help" => sub { usage(); exit; },
	"d|domain=s" => \@domains,
	"h|host=s" => \@hosts,
	"b|base=s" => \@trees,
	"config!" => \$add_config,
	"srv!" => \$add_from_srv,
	"starttls!" => \$start_tls,
) or exit(2);

# provide default domains and base DNs

if (!@domains) {
	@domains = ("nullroute.lt");
}

if (!@trees) {
	@trees = domain_to_dn(@domains);
	@trees = ("cn=config", @trees) if $add_config;
}

# if no hosts were given, or if any --host parameters start with "+", merge
# with SRV data (otherwise use *only* --host)

if (!@hosts) {
	$add_from_srv = 1;
}
else {
	$add_from_srv ||= grep {s/^\+//} @hosts;
}

if ($add_from_srv) {
	print "looking up '@domains'\n";
	push @hosts, dns_srv_lookup(@domains);
}

if (!@hosts) {
	_die("no servers to check");
}

for (@hosts) {
	# remove trailing period for multi-component names
	# (to properly uniq them later)
	s/\.$// if /\..+\.$/;
}

@hosts = uniq @hosts;

# scan each server

my %csns;
my %rcsns;
my $hosts_ok = 0;
my %trees_ok;
my %hosts_ok;

for my $host (@hosts) {
	my ($conn, $res);
	print "querying '$host'\n";
	$conn = Net::LDAP->new($host, verify => "require");
	if (!$conn) {
		_err("could not connect to '$host': $!");
		next;
	}
	if ($start_tls && $host !~ /^ldaps:/) {
		$res = $conn->start_tls(verify => "require");
		if ($res->is_error) {
			_err("could not start TLS with '$host': ".$res->error_name);
			goto fail;
		}
	}
	$res = $conn->bind();
	if ($res->is_error) {
		_err("could not anonymously bind to '$host': ".$res->error_name);
		goto fail;
	}
	for my $base (@trees) {
		$res = $conn->search(
				base => $base,
				scope => "base",
				filter => "(contextCSN=*)",
				attrs => ["contextCSN"]);
		if ($res->is_error) {
			_err("could not read '$base': ".$res->error_name);
			next;
		}
		if (!$res->count) {
			_err("contextCSN for '$base' is not accessible or missing");
			next;
		}
		my @csn = $res->entry(0)->get_value("contextCSN");
		my $csn = join(" ", sort(@csn));
		$csns{$base}{$host} = $csn;
		push @{$rcsns{$base}{$csn}}, $host;
		++$trees_ok{$host};
		++$hosts_ok{$base};
	}
fail:
	$conn->unbind;
	++$hosts_ok if ($trees_ok{$host} == @trees);
}

# show results

if ($hosts_ok == 0) {
	_err("no reachable replica servers! (out of ".@hosts.")");
	exit $err;
} elsif ($hosts_ok == 1) {
	_warn("only one reachable replica server! (out of ".@hosts.")");
} elsif ($hosts_ok < @hosts) {
	_warn("only ".$hosts_ok." reachable replica servers! (out of ".@hosts.")");
}

for my $base (@trees) {
	my %csn = %{$csns{$base}};
	my %rcsn = %{$rcsns{$base}};
	my @partitions = keys %rcsn;
	if (@partitions == 1) {
		if ($hosts_ok{$base} == @hosts) {
			_tree_status($base, "ok", "all CSNs identical");
		} else {
			_tree_status($base, "degraded", "reachable CSNs identical");
		}
		print "  hosts:\n";
		print "    $_\n" for @{$rcsn{$partitions[0]}};
		print "  context:\n";
		print "    $_\n" for split(" ", $partitions[0]);
	} elsif (@partitions > 0) {
		my $num = @partitions;
		_tree_status($base, "desynced", "$num partitions");
		for my $csn (@partitions) {
			warn "  partition ".(@partitions-$num)."\n";
			warn "    hosts:\n";
			warn "      $_\n" for @{$rcsn{$csn}};
			warn "    context:\n";
			warn "      $_\n" for split(" ", $csn);
			--$num;
		}
	} else {
		_tree_status($base, "down", "all replicas unreachable");
	}
}

exit $err;
