#!/usr/bin/perl
#
# $Cambridge: hermes/conf/exim/sbin/bad_aliases,v 1.15 2011/08/10 14:55:24 fanf2 Exp $

use warnings;
use strict;

sub SIGTERM { 15 }

my $domain = $ARGV[0];
die "usage: $0 <domain>\n"
    unless $domain =~ /^[a-z0-9.-]+$/;
my $domainre = sprintf "\@%s\$", quotemeta $domain;

my %vrfy;

sub vrfy {
	my $addr = pop;
	return $vrfy{$addr} if exists $vrfy{$addr};
	my $host = shift;
	# need to exec smtpc so we kill it not the shell
	my $cmd = "exec /opt/exim/bin/smtpc -t30 2>&1 </dev/null "
	    . ($host ? "-vv $host" : "-vvv") # mx
	    . " postmaster\@hermes.cam.ac.uk \"$addr\"";
	my $pid = open my $smtpc, "$cmd |"
	    or die "open `$cmd`: $!";
	my @out;
	eval {
		# kill smtpc if it takes too long
		local $SIG{ALRM} = sub {
			kill SIGTERM, $pid;
		};
		# two minute time-out
		alarm 120;
		@out = <$smtpc>;
		alarm 0;
	};
	# propagate unexpected errors
	die if $@;
	# verified OK
	return $vrfy{$addr} = undef if close $smtpc;
	# other errors are bugs
	die "close `$cmd`: $! ($?)"
	    unless $? == 256 or $? == SIGTERM;
	# discard bogus failures at RSET
	return $vrfy{$addr} = undef if grep /sent RSET/, @out;
	# detect permanent failures
	@out = grep s/^(smtpc: rcvd )?5/5/, @out;
	unshift @out, "\n" if @out > 1;
	return $vrfy{$addr} = join "", @out;
}

my %test;

sub test {
	my $addr = shift;
	return $test{$addr} if exists $test{$addr};
	my $cmd = "/opt/exim/bin/exim -bt \"$addr\"";
	open my $exim, "$cmd |"
	    or die "open `$cmd`: $!";
	my $fail = "";
	my $failing = 0;
	my $check;
	my $tocheck;
	while (<$exim>) {
		if (m{http://www[.]cam[.]ac[.]uk/cs/email/bounce[.]html}) {
			next;
		} elsif (m(^([!#$%&'*+/=?^_`{|}~A-Za-z0-9.-]+[@][A-Za-z0-9.-]+)\s*$)) {
			$tocheck = $1;
			$check = "";
			$failing = 0;
		} elsif (/router = dnslookup, transport = smtp/ and defined $tocheck) {
			if (my $out = vrfy $tocheck) {
				$fail .= "$tocheck is undeliverable:\n$out$check";
			}
			undef $tocheck;
		} elsif (/transport = smtp/ and defined $tocheck) {
			next;
		} elsif (/transport = hermes_lmtp/ and defined $tocheck) {
			undef $tocheck;
		} elsif (/^  host ([A-Za-z0-9.-]+) / and defined $tocheck) {
			if (my $out = vrfy $1, $tocheck) {
				$fail .= "$tocheck is undeliverable:\n$out$check";
			}
			undef $tocheck;
		} elsif (/^ / and defined $tocheck) {
			$check .= $_;
		} elsif (s/ (is undeliverable:) / $1\n/ and not /friendly-bounce/) {
			$fail .= $_;
			$failing = 1;
		} elsif (/^ / and $failing) {
			$fail .= $_;
		} else {
			$failing = 0;
			undef $tocheck;
		}
	}
	close $exim
	    or $? == 512 or $? == 256
		or die "close `$cmd`: $! ($?)";
	return $test{$addr} = $fail;
}

my $aliases;
my $aliases_errors = "";
for my $dir (qw(aliases https)) {
	my $aliases_file = "/opt/dist/domains/$dir/$domain";
	last if open $aliases, "< $aliases_file";
	$aliases_errors .= "open < $aliases_file: $!\n";
}
die $aliases_errors unless defined $aliases;

my $enabled = qx{grep \"^$domain\$\" /opt/dist/domains/domainlist};

my %alias;
while (<$aliases>) {
	next unless /^([^:#]*):(.*)$/;
	my $addr = lc "$1\@$domain";
	if ($enabled) {
	    my $fail = test $addr;
	    printf "=== %s\n%s", $addr, $fail if $fail;
	} else {
	    $alias{$addr} = $2;
	    $alias{$addr} =~ s/\s//g;
	    $alias{$addr} =~ tr/A-Z/a-z/;
	}
}
exit if $enabled;

for my $alias (sort keys %alias) {
	my @alias = split /,/, $alias{$alias};
	my $fail = "";
	for my $dest (@alias) {
		if ($dest !~ $domainre) {
			$fail .= test $dest;
		} elsif (not exists $alias{$dest}) {
			$fail .= "$dest is undeliverable:\n" .
			    "<$dest> is not a known user on this system;\n";
		}
	}
	printf "=== %s\n%s", $alias, $fail if $fail;
}

exit;
