#!/usr/bin/perl -w

use strict;
use Net::DNS;
use Net::IPv4Addr qw( :all );
use POSIX ":sys_wait_h";
use IO::File;
use IO::Socket::INET;
use IO::Select;
use Fcntl;
use IPC::Open3;
use Data::Dumper;
use English;
use POSIX qw(:errno_h);

$| = 1;
my $hostname = "asteria.debian.or.at";
my $VERBOSE = 0;

my $AFTER_SSL_SLEEP = 2;
my $OPENSSL_TIMEOUT = 45;
my $CHECK_LISTENS_TIMEOUT = 15; # 50   # done 3 times
my $CHECK_TLS_TIMEOUT = 15; # 50   # done 3 times
my $GET_MX_TIMEOUT = 5;
my $WAIT_AFTER_QUIT = 2;

$SIG{'CHLD'} = 'IGNORE';

sub parse_reply($) {
	my ($fh) = @_;

	my $code = undef;
	my $text = '';
	while (1) {
		my $line = <$fh>;
		next unless defined $line;
		my ($thiscode, $thistext);
		if (($thiscode, $thistext) = $line =~ /^(\d\d\d)-(.*)$/s) {
			$thistext =~ s/\r\n/\n/;
			$text .= $thistext;
			next;
		} elsif (($thiscode, $thistext) = $line =~ /^(\d\d\d)\s+(.*)$/s) {
			$thistext =~ s/\r\n/\n/;
			$text .= $thistext;
			$code = $thiscode;
			last;
		} else {
			die ("Cannot parse $line\n");
		};
	};
	return ($code, $text);
}

sub quit($) {
	my ($peer) = @_;
	print $peer "QUIT\r\n";
	sleep ($WAIT_AFTER_QUIT);
	close $peer;
};

sub do_ssl($) {
	my ($peer) = @_;

	my $listen = IO::Socket::INET->new(
		Listen => 1,
		Proto => 'tcp',
	);
	my $port = $listen->sockport();

	my $p_pid = fork();
	unless ($p_pid) {
		my $socket = $listen->accept();
		my $pid;
		my @children;
		$pid = fork();
		push @children, $pid;
		unless ($pid) {
			close STDOUT;
			my $d;
			while (read($socket, $d, 1)) {
				print $peer $d;
				$peer->flush();
			}
			exit(0);
		};
		$pid = fork();
		push @children, $pid;
		unless ($pid) {
			close STDOUT;
			my $d;
			while (read($peer, $d, 1)) {
				print $socket $d;
				$socket->flush();
			};
			exit(0);
		};
		#while (@children) {
		#	for (@children) {
		#		my $child = waitpid($_,WNOHANG);
		#		if ($child == $_) {
		#			@children = grep { $_ != $child } @children;
		#		};
		#	};
		#};

		exit(0);
	};

	my($wtr, $rdr, $err);
	my $pid = open3($wtr, $rdr, $err, "timeout $OPENSSL_TIMEOUT openssl s_client -showcerts -connect localhost:$port");
	#waitpid($p_pid,0);

	return ($wtr, $rdr, $err);
};

sub check_listens($$$) {
	my ($peer_host, $port, $do_ssl)  = @_;

	my ($result, $warning, $error) = (undef,undef,undef,undef);
	my $tls_text = "";

	eval {
		while (1) {
			local $SIG{ALRM} = sub { die "alarm\n" };
			alarm($CHECK_LISTENS_TIMEOUT);

			my $peer = IO::Socket::INET->new(
				PeerAddr => $peer_host,
				PeerPort => $port,
				Protocol => 'tcp',
				Timeout => 5,
			) or $result = 0, $error = ("Cannot connect: $!"), last;


			alarm($CHECK_LISTENS_TIMEOUT);
			my ($wtr, $rdr, $err);
			if ($do_ssl) {
				print STDERR "Checking SSL for $peer_host ... do ssl\n" if ($VERBOSE >= 3);
				($wtr, $rdr, $err) = do_ssl($peer);
				print STDERR "Checking SSL for $peer_host ... ssl done\n" if ($VERBOSE >= 3);
				sleep ($AFTER_SSL_SLEEP);
			} else {
				($wtr, $rdr) = ($peer, $peer);
			};

			alarm($CHECK_LISTENS_TIMEOUT);

			my ($code, $comment);
			while (my $line = readline($rdr)) {
				my ($thiscode, $thiscomment);
				if (($thiscode, $thiscomment) = $line =~ /^(\d\d\d)-(.*)$/s) {
					$thiscomment =~ s/\r\n/\n/;
					$comment .= $thiscomment;
					next;
				} elsif (($thiscode, $thiscomment) = $line =~ /^(\d\d\d)\s+(.*)$/s) {
					$thiscomment =~ s/\r\n/\n/;
					$comment .= $thiscomment;
					$code = $thiscode;
					last;
				} else {
					$tls_text .= $line;
					next;
				};
			};

			if (defined $code && defined $comment) {
				$error = "Code is $code and not 220 ($comment)" unless ($code == 220);
				#$error .= "'$comment' does not include SMTP magic string" unless $comment =~ /SMTP/;
				$result = 1 unless defined $error;
				quit($wtr);
			} else {
				close($wtr);
			};
			close($rdr);
			last;
		};
		alarm(0);
	};
	if ($@) {
		die $@ unless $@ eq "alarm\n";
		$error = "alarm - timeout";
	};
	if (defined $error) {
		$error =~ s/Operation now in progress$/Timeout/;
	};
	return ($result, $warning, $error, $tls_text);
};

sub check_tls($) {
	my ($peer_host) = @_;
	my ($result, $warning, $error, $tls_text) = (undef,undef,undef,undef,undef);
	print STDERR "Checking TLS for $peer_host\n" if ($VERBOSE >= 2);

	eval {
		while(1) {
			local $SIG{ALRM} = sub { die "alarm\n" };
			alarm($CHECK_TLS_TIMEOUT);

			print STDERR "Checking TLS for $peer_host ... connet to port 25\n" if ($VERBOSE >= 3);
			my $peer = IO::Socket::INET->new(
				PeerAddr => $peer_host,
				PeerPort => 'smtp',
				Protocol => 'tcp',
				Timeout => 5,
			) or $error = ("Cannot connect: $!"), last;

			alarm($CHECK_TLS_TIMEOUT);

			my ($code, $comment) = parse_reply($peer);
			$error = "Code is $code and not 220 ($comment)", quit($peer), last unless ($code == 220);
			#$error = "'$comment' does not include SMTP magic string", quit($peer), last unless $comment =~ /SMTP/;
			$result = 0, quit($peer), last unless $comment =~ /ESMTP/;

			print STDERR "Checking TLS for $peer_host ... send EHLO\n" if ($VERBOSE >= 3);
			print $peer "EHLO $hostname\r\n";
			($code, $comment) = parse_reply($peer);
			$error = "Code is $code and not 250 ($comment)", quit($peer), last unless ($code == 250);
			my $tls = $comment =~ m/^STARTTLS$/im ? 1 : 0;
			$result = 0, quit($peer), last unless $tls;

			print STDERR "Checking TLS for $peer_host ... send STARTTLS\n" if ($VERBOSE >= 3);
			$result = 1;
			print $peer "STARTTLS\r\n";
			($code, $comment) = parse_reply($peer);
			$warning = "STARTTLS return code is $code and not 220 ($comment)", quit($peer), last unless ($code == 220);

			alarm($CHECK_TLS_TIMEOUT);
			print STDERR "Checking TLS for $peer_host ... do ssl\n" if ($VERBOSE >= 3);
			my ($wtr, $rdr, $err) = do_ssl($peer);
			print STDERR "Checking TLS for $peer_host ... ssl done\n" if ($VERBOSE >= 3);

			sleep $AFTER_SSL_SLEEP;
			print STDERR "Checking TLS for $peer_host ... quit\n" if ($VERBOSE >= 3);
			quit($wtr);
			my $r = join '', <$rdr>;
			close $rdr;
			$tls_text = $r;

			last;
		};
		alarm(0);
	};
	if ($@) {
		die $@ unless $@ eq "alarm\n";
		$error = "alarm - timeout";
	};
	if (defined $error) {
		$error =~ s/Operation now in progress$/Timeout/;
	};
	print STDERR "Checking TLS for $peer_host ... done\n" if ($VERBOSE >= 3);
	return ($result, $warning, $error, $tls_text);
};


sub get_mx($) {
	my ($domain) = @_;
	
	my @result;
	my @mx = mx($domain);
	if (scalar @mx) {
		@result = map { { preference => $_->preference, exchange => $_->exchange } } @mx;
	} else {
		@result = ( { preference => 0, exchange => $domain } );
	};
	return @result;
};

sub check_mx($) {
	my ($host) = @_;
	my $error = undef;
	my $result = undef;
	my $warning = undef;
	my $tls = undef;

	my $query;
	my $address;
	my $res;
	eval {
		local $SIG{ALRM} = sub { die "alarm\n" };
		alarm($GET_MX_TIMEOUT);
		$res   = Net::DNS::Resolver->new;
		$query = $res->search($host);
		alarm(0);
	};
	if ($@) {
		die $@ unless $@ eq "alarm\n";
		$error = "DNS query timed out.";
	};
	
	if ($query) {
		foreach my $rr ($query->answer) {
			next unless $rr->type eq "A";
			if (defined $address) {
				$warning = "$host has round robin A records";
				next;
			};
			$address = $rr->address;
		}
		$error = "does not resolve to an ipv4 address" unless defined $address;
	} else {
		$error = "query failed: ".$res->errorstring
	}
	
	# 0.0.0.0   /8   Reserved
	# 10.0.0.0   /8   RFC 1918 Private
	# 14.0.0.0   /8   Public Data Network1
	# 127.0.0.0   /8   Loopback
	# 169.254.0.0   /16   Link-local
	# 172.16.0.0   /12   RFC 1918 Private
	# 192.0.2.0   /24   Example network
	# 192.168.0.0   /16   RFC 1918 Private
	# 224.0.0.0   /4   Multicast (Class D)
	# 240.0.0.0   /4   Unspecified (Class >D)
	if (defined $address &&
	   (ipv4_in_network("0.0.0.0/8", $address) ||
	    ipv4_in_network("10.0.0.0/8", $address) ||
	    ipv4_in_network("127.0.0.1/8", $address) ||
	    ipv4_in_network("169.254.0.0/16", $address) ||
	    ipv4_in_network("172.16.0.0/12", $address) ||
	    ipv4_in_network("192.0.2.0/24", $address) ||
	    ipv4_in_network("192.168.0.0/16", $address) ||
	    ipv4_in_network("224.0.0.0/4", $address) ||
	    ipv4_in_network("240.0.0.0/4", $address))) {
		$error = "stupid admin sets A record to special address space ($address)"
	};

	my $return;
	$return->{'smtp'} = {
		error => $error,
		warning => $warning,
	};
	unless (defined $error) {
		my ($r, $w, $e, $t);
		print STDERR $host." tls1\n" if ($VERBOSE >= 2);
		($r, $w, $e, $t) = check_tls($host);
		$result .= $r if defined $r;
		$warning .= $w if defined $w;
		$error .= $e if defined $e;
		$tls = $t if defined $t;

		$return->{'smtp'} = {
			error => $error,
			warning => $warning,
			result => $result,
			tls => $t
		};
		print STDERR $host." sub\n" if ($VERBOSE >= 2);
		($r, $w, $e, $t) = check_listens($host, '587', 0);
		$return->{'submission'} = {
			error => $e,
			warning => $w,
			result => $r,
			tls => $t
		};
		print STDERR $host." smtps\n" if ($VERBOSE >= 2);
		($r, $w, $e, $t) = check_listens($host, 'smtps', 1);
		$return->{'smtps'} = {
			error => $e,
			warning => $w,
			result => $r,
			tls => $t
		};
		print STDERR $host." 2525\n" if ($VERBOSE >= 2);
		($r, $w, $e, $t) = check_listens($host, '2525', 0);
		$return->{'2525'} = {
			error => $e,
			warning => $w,
			result => $r,
			tls => $t
		};
		#print STDERR $host." 25000\n" if ($VERBOSE >= 2);
		#($r, $w, $e, $t) = check_listens($host, '25000', 0);
		#$return->{'25000'} = {
		#	error => $e,
		#	warning => $w,
		#	result => $r,
		#	tls => $t
		#};
		#print STDERR $host." 22222\n" if ($VERBOSE >= 2);
		#($r, $w, $e, $t) = check_listens($host, '22222', 0);
		#$return->{'22222'} = {
		#	error => $e,
		#	warning => $w,
		#	result => $r,
		#	tls => $t
		#};
		print STDERR $host." checkmx DONE\n" if ($VERBOSE >= 2);
	};
	
	return $return;
};

sub do_address($) {
	my ($address) = @_;

	my ($localpart, $domain) = split (/@/, $address);

	my @mx = get_mx($domain);
	my @result;
	for my $mx (@mx) {
		my $res = check_mx($mx->{exchange});
		push @result, {
			mx => $mx->{exchange},
			pri => $mx->{preference},
			res => $res,
		};
	};
	return \@result;
};



my @addresses;
my %NICKS;
while (<>) {
	# $remailer{"aarg"} = "<remailer@aarg.net> cpunk
	if (/remailer\{"(\S+)"\}.*<([a-zA-Z0-9._-]+@[a-zA-Z0-9._-]+)>/) {
		push @addresses, $2;
		$NICKS{$2} = $1;
	} elsif (/<([a-zA-Z0-9._-]+@[a-zA-Z0-9._-]+)>/) {
		push @addresses, $1;
	};
};

my %unique;
@addresses = sort { $a cmp $b } @addresses;
@addresses = grep { !$unique{$_}++ } @addresses;

my %FH;
my @PIDs;
for my $address (@addresses) {
	$FH{$address} = new IO::File;
	my $pid = $FH{$address}->open("-|");
	unless (defined $pid) {
		die ("Could not fork: $!");
	};
	unless ($pid) { # child
		my $result = do_address($address);
		my $dump = Data::Dumper->Dump( [$result] );
		print STDERR "printing data for $address\n" if ($VERBOSE >= 2);
		print $dump;
		print STDERR "printed: $dump\n" if ($VERBOSE >= 6);
		print STDERR "exiting child for $address\n" if ($VERBOSE >= 2);
		exit(0);
	};
	push @PIDs, $pid;
	fcntl($FH{$address}, F_SETFL, O_NONBLOCK) or die "can't set non blocking: $!";
};




my $result;
my $END = time + 600;
my $last_notice = 0;
while ($END > time) {
	my $s = IO::Select->new();
	for my $address (@addresses) {
		$s->add($FH{$address}) if exists $FH{$address};
	};
	last if $s->count() == 0;

	if ($VERBOSE && $last_notice < time - 3) {
		print STDERR ("Still waiting for ".join(", ", grep {exists $FH{$_}} @addresses)."\n");
		$last_notice = time;
	};
	my $timeout = 3;
	print STDERR "Calling can_read\n" if ($VERBOSE >= 3);
	my @ready = $s->can_read($timeout);

	my $forced = 0;
	if (scalar @ready == 0) {
		print STDERR "no ready handles, read them all\n" if $VERBOSE;
		@ready = $s->handles();
		$forced = 1;
	};

	for my $fh (@ready) {
		print STDERR "$fh is ready".($forced ? " (not really)" : "")."\n" if ($VERBOSE >= 3);
		my $addr;
		for my $address (@addresses) {
			next unless exists $FH{$address};
			if ($fh->fileno() == $FH{$address}->fileno()) {
				$addr = $address;
				last;
			};
		};
		die ("No address for $fh\n"), next unless defined $addr;

		print STDERR "reading fh for $addr\n" if ($VERBOSE >= 2);

		my $buf;
		
		my $res = sysread($fh, $buf, 100000);
		my $error = $ERRNO;
		print STDERR "$fh read $res bytes\n" if (defined $res && $VERBOSE);
		if (!defined $res) {
			printf STDERR ("got error $ERRNO, again: %d, wouldb: %d\n", EAGAIN, EWOULDBLOCK) if ($VERBOSE > 5);
			printf STDERR ("got error $ERRNO\n") if ($ERRNO != EWOULDBLOCK);
		} elsif ($res > 0) {
			$result->{$addr} .= $buf;
		} else {
			$fh->close;
			delete $FH{$addr};
			print STDERR "$addr reading DONE\n" if $VERBOSE;
		};
	};
};
print STDERR "DONE\n" if $VERBOSE;

for my $address (@addresses) {
	if (exists $FH{$address}) {
		delete $result->{$address};
		warn ("$address failed\n");
	};
};
for my $key (keys %$result) {
	my $VAR1;
	my $fo = eval ($result->{$key});
	$VAR1 = undef;
	$result->{$key}= $fo;
};

=pod
print STDERR "FOOOOO\n";
my $result;
	for my $address (@addresses) {
eval {
	alarm(200);
		print STDERR "waiting for $address.\n" if $VERBOSE;
		my $fh = $FH{$address};
		undef $/;
		my $res = <$fh>;
		$FH{$address}->close;

		my $VAR1;
		my $fo = eval ($res);
		$result->{$address} = $fo;
		$VAR1 = undef;
		print STDERR "$address READ.\n" if $VERBOSE;
};
	};
	alarm(0);
if ($@) {
	die $@ unless $@ eq "alarm\n";
};

=cut


#my $kid;
#do {
#	$kid = waitpid(-1,WNOHANG);
#} until $kid == -1;


my $data;
for my $remailer (keys %$result) {
	my $d;
	$d->{'address'} = $remailer;
	$d->{'nick'} = $NICKS{$remailer} || 'N/A';
	$d->{'mx'} = $result->{$remailer};
	push @{$data}, $d;
};

print Data::Dumper->Dump( [$data] );