#!/usr/bin/perl -w
# $Id: osecurity.cgi,v 1.34 2003/07/10 03:33:49 candy Exp candy $

require 5.003;
use strict;
use POSIX;
use Socket;
use CGI;

my $user = "relaytest"; # リレー宛先ユーザ名
my $do_data = 0; # 実際にメールを送るか?
my $generic_domain = 1; # FQDN mail.example.com を example.com ドメインとしてテストする。
my $nslookup = "/usr/local/bin/dig"; # コマンド
my $my_hostname; # このホスト名
my $to_domain; # リレー宛先ドメイン名
my $client; # この CGI を実行した REMOTE_ADDR
my $bounce_address; # エラーの宛先
my $logfile = "osecurity.log";

my $debug = 0;

sub nz($) {
	return defined($_[0]) ? $_[0] : "";
}

sub autoflush($$) {
	my($so, $flag) = @_;
	select((select($so), $| = $flag)[0]);
}

sub print_error(@) {
	printf("</pre><h4>ERROR: ");
	printf(@_);
	printf("</h4><pre>\n");

}

sub accepted() {
	printf("</pre><h5><font color=\"#ff0000\">ACCEPTED</font></h5><pre>\n");
	printf(LOG "ACCEPTED\n");
}

sub rejected() {
	printf("</pre><h5>REJECTED</h5><pre>\n");
	printf(LOG "REJECTED\n");
}

sub connection($$$) {
	my($so, $remote, $port) = @_;
	my($err, $proto, $iaddr, $paddr);
	$err = -1;
	$proto = getprotobyname("tcp");
	$port = getservbyname($port, "tcp");
	if ($iaddr = inet_aton($remote)) {
		$paddr = sockaddr_in($port, $iaddr);
		if (socket($so, PF_INET, SOCK_STREAM, $proto)) {
			printf("Trying %s\n", inet_ntoa($iaddr));
			if (connect($so, $paddr)) {
				printf("Connected to %s\n", $remote);
				$err = 0;
			}
			else {
				print_error("$remote: connect failed. $!\n");
			}
		}
		else {
			print_error("socket failed. $!\n");
		}
	}
	else {
		print_error("$remote: cannot resolve name. $!\n");
	}
	return $err;
}

sub lookup_mx($) {
	my($addr, $iaddr, $dot, $rev, $nmx, $exec_failed) = @_;
	my @mx;
	$exec_failed = "cannot_exec_nslookup";
	$nmx = 0;
	@mx = ();
	$debug && printf("# lookup_mx(%s)\n", $addr);
	if (open(P, "-|") == 0) {
		close(STDERR);
		open(STDERR, ">&STDOUT");
		$debug && printf("# $nslookup -t MX $addr.\n");
		if (!exec("$nslookup", "-t", "MX", "$addr.")) {
			printf("IN MX 10 $exec_failed\n");
			exit(0);
		}
	}
	else {
		my($line);
		while ($line = <P>) {
			my(@v);
			($debug & 2) && printf("### %s", $line);
			chomp($line);
			if ($line =~ /IN[ \t]+MX[ \t]+/) {
				@v = split(/[ \t]+/, $line);
				$mx[$nmx++] = sprintf("%d %s", $v[4], $v[$#v]);
			}
		}
		close(P);
		@mx = sort @mx;
	}
	if ($nmx >= 1 && $mx[0] =~ /$exec_failed/) {
		print_error("cannot exec $nslookup.\n");
		@mx = ();
	}
	return @mx;
}

sub lookup_ptr($) {
	my($addr, $iaddr, $dot, $rev, $fqdn, $exec_failed) = @_;
	$debug && printf("# lookup_ptr(%s)\n", $addr);
	$iaddr = inet_aton($addr);
	$fqdn = gethostbyaddr($iaddr, AF_INET);
	$debug && printf("# %s = %s\n", $addr ,$fqdn);
	return $fqdn;
}

sub enc($) {
	my($s, @v) = @_;
	$s =~ s/\&/\&amp;/g;
	$s =~ s/</\&lt;/g;
	$s =~ s/>/\&gt;/g;
	return $s;
}

sub send_line($@) {
	my($so, $form, @arg) = @_;
	my $line = sprintf($form, @arg);
	my $line2;
	printf(">>> %s", enc($line));
	printf($so $form, @arg);
	($line2 = $line) =~ s/\r//g;
	printf(LOG "> %s", $line2);
	return 0;
}

sub get_line($) {
	my($so, $line, $line2) = @_;
	if ($line = <$so>) {
		printf("<<< %s", enc($line));
		($line2 = $line) =~ s/\r//g;
		printf(LOG "< %s", $line2);
	}
	else {
		print_error("$!\n");
	}
	return $line;
}


sub send_and_wait($@) {
	my($so, @arg) = @_;
	my($line);
	send_line($so, @arg);
	$line = get_line($so);
	return $line;
}

sub send_and_wait_250($@) {
	my($so, @arg) = @_;
	my($line, $ok);
	send_line($so, @arg);
	$ok = 0;
	while (!$ok && ($line = get_line($so))) {
		$ok = ($line =~ /^250/);
	}
	return $line;
}

sub send_rset($) {
	my($so, $line) = @_;
	if ($line = send_and_wait($so, "RSET\r\n")) {
		if ($line =~ /^2/) {
		}
		else {
			$line = "";
			print_error("RSET failed\n");
		}
	}
	return $line;
}

sub send_mail($$) {
	my($so, $from, $line) = @_;
	if ($line = send_and_wait($so, "MAIL FROM:<%s>\r\n", $from)) {
		if ($line =~ /^2/) {
		}
		else {
			$line = "";
			rejected();
		}
	}
	return $line;
}

sub send_rcpt($$) {
	my($so, $to, $line) = @_;
	if ($line = send_and_wait($so, "RCPT TO:<%s>\r\n", $to)) {
		if ($line =~ /^2/) {
			if (!$do_data) {
				accepted();
			}
		}
		else {
			$line = "";
			rejected();
		}
	}
	return $line;
}

sub send_data($$$$$$) {
	my($so, $from, $to, $testno, $remote_host, $remote_ip, $line, $acc) = @_;
	$acc = 0;
	if ($line = send_and_wait($so, "DATA\r\n")) {
		if ($line =~ /^3/) {
			send_line($so, "Errors-To: <%s>\r\n", $bounce_address);
			send_line($so, "Message-Id: <%s%02d@%s>\r\n", strftime("%Y%m%d%H%M%S", localtime()), $testno, $my_hostname);
			###### %Z shoud be %z (not implemented by perl yet)
			send_line($so, "Date: %s\r\n", strftime("%d %b %Y %H:%M:%S %Z", localtime()));
			send_line($so, "Subject: RELAY TEST %d for %s\r\n", $testno, $remote_host);
			send_line($so, "From: <%s>\r\n", $from);
			send_line($so, "To: <%s>\r\n", $to);
			send_line($so, "\r\n");
			send_line($so, "RELAY TEST %d for %s (%s)\n", $testno, $remote_host, $remote_ip);
			send_line($so, "  from %s by %s\r\n", $my_hostname, $client);
			send_line($so, "MAIL FROM:<%s>\r\n", $from);
			send_line($so, "RCPT TO:<%s>\r\n", $to);
			$line = send_and_wait($so, ".\r\n");
			if ($line =~ /^2/) {
				accepted();
				$acc = 1;
			}
		}
	}
	if (!$acc) {
		$line = "";
		rejected();
	}
	return $line;
}

sub test_1($$$$$) {
	my($testno, $so, $remote_host, $remote_ip, $remote_domain) = @_;
	my($desc, $from, $to__, $err, $line);
	$err = 0;
	$line = "";
	if ($testno == 1) {
		$desc = "単純なリレー";
		$from = "$user\@$to_domain";
		$to__ = "$user\@$to_domain";
	} elsif ($testno == 2) {
		$desc = "From: ユーザ名のみ";
		$from = "$user";
		$to__ = "$user\@$to_domain";
	} elsif ($testno == 3) {
		$desc = "From: (空アドレス)";
		$from = "";
		$to__ = "$user\@$to_domain";
	} elsif ($testno == 4) {
		$desc = "From: <> による転送";
		$from = "<>";
		$to__ = "$user\@$to_domain";
	} elsif ($testno == 5) {
		$desc = "From: \@ドメイン詐称";
		$from = "$user\@$remote_domain";
		$to__ = "$user\@$to_domain";
	} elsif ($testno == 6) {
		$desc = "From: \@[IP詐称]";
		$from = "$user\@[$remote_ip]";
		$to__ = "$user\@$to_domain";
	} elsif ($testno == 7) {
		$desc = "From: postmaster\@ドメイン詐称 ";
		$from = "postmaster\@$remote_domain";
		$to__ = "$user\@$to_domain";
	} elsif ($testno == 8) {
		$desc = "From: postmaster\@[IP詐称]";
		$from = "postmaster\@[$remote_ip]";
		$to__ = "$user\@$to_domain";
	} elsif ($testno == 9) {
		$desc = "From: postmaster\@localhost";
		$from = "postmaster\@localhost";
		$to__ = "$user\@$to_domain";
	} elsif ($testno == 10) {
		$desc = "To: クォート";
		$from = "$user\@$remote_domain";
		$to__ = "\"$user\@$to_domain\"";
	} elsif ($testno == 11) {
		$desc = "To: : による転送";
		$from = "$user\@$remote_domain";
		$to__ = "\@$remote_domain:$user\@$to_domain";
	} elsif ($testno == 12) {
		$desc = "To: IP詐称 + :";
		$from = "$user\@$remote_domain";
		$to__ = "\@[$remote_ip]:$user\@$to_domain";
	} elsif ($testno == 13) {
		$desc = "To: % + \@ による転送";
		$from = "$user\@$remote_domain";
		$to__ = "$user%$to_domain\@";
	} elsif ($testno == 14) {
		$desc = "To: % による転送 (注1)";
		$from = "$user\@$remote_domain";
		$to__ = "$user%$to_domain\@$remote_domain";
	} elsif ($testno == 15) {
		$desc = "To: % + IP詐称 (注1)";
		$from = "$user\@$remote_domain";
		$to__ = "$user%$to_domain\@[$remote_ip]";
	} elsif ($testno == 16) {
		$desc = "To: クォート + % (注1)";
		$from = "$user\@$remote_domain";
		$to__ = "\"$user%$to_domain\"";
	} elsif ($testno == 17) {
		$desc = "To: 二重\@ (注2)";
		$from = "$user\@$remote_domain";
		$to__ = "$user\@$to_domain\@$remote_domain";
	} elsif ($testno == 18) {
		$desc = "To: クォート + 二重\@ (注2)";
		$from = "$user\@$remote_domain";
		$to__ = "\"$user\@$to_domain\"\@$remote_domain";
	} elsif ($testno == 19) {
		$desc = "To: 二重\@ + IP 詐称 (注2)";
		$from = "$user\@$remote_domain";
		$to__ = "$user\@$to_domain\@[$remote_ip]";
	} elsif ($testno == 20) {
		$desc = "To: ! による転送 (注3)";
		$from = "$user\@$remote_domain";
		$to__ = "$to_domain!$user";
	} elsif ($testno == 21) {
		$desc = "To: ! + ドメイン詐称 (注3)";
		$from = "$user\@$remote_domain";
		$to__ = "$to_domain!$user\@$remote_domain";
	} elsif ($testno == 22) {
		$desc = "To: ! + IP詐称 (注3)";
		$from = "$user\@$remote_domain";
		$to__ = "$to_domain!$user\@[$remote_ip]";
	}
	else {
		$err = -1;
	}
	if ($err == 0) {
		printf("</pre><li><h4>TEST %d - %s</h4><pre>\n", $testno, enc($desc));
		if ($line = send_rset($so)) {
			if ($line = send_mail($so, $from)) {
				if ($line = send_rcpt($so, $to__)) {
					if ($do_data) {
						$line = send_data($so, $from, $to__, $testno, $remote_host, $remote_ip);
					}
				}
			}
		}
	}
	return $line;
}

sub notice() {
	printf("</pre><ul>");
	printf("<li>注1: qmail は % をローカルアドレスの一部として処理します。(ACCEPT しても転送は行われません)\n");
	printf("<li>注2: qmail は最も右に現れる \@ 以外をローカルアドレスの一部として処理します。(ACCEPT しても転送は行われません)\n");
	printf("<li>注3: qmail は ! をローカルアドレスの一部として処理します。(ACCEPT しても転送は行われません)\n");
	printf("</ul><pre>");
}

sub test_loop($$$$) {
	my($so, $remote_host, $remote_ip, $remote_domain, $testno, $ntest, $nacc) = @_;
	$debug && printf("# test_loop(%d, %s, %s, %s)\n", $so, $remote_host, $remote_ip, $remote_domain);
	printf("<ul>\n");
	$nacc = 0;
	$ntest = 21;
	for ($testno = 1; $testno <= $ntest; $testno++) {
		if (test_1($testno, $so, $remote_host, $remote_ip, $remote_domain)) {
			$nacc++;
		}
	}
	printf("</ul>\n");
	send_and_wait($so, "QUIT\r\n");
	printf("</pre>\n");
	printf(LOG "%s: SUMMARY: %s (%s): %d of %d was accepted%s.\n", strftime("%Y/%m/%d-%H:%M:%S", localtime()), $remote_host, $remote_ip, $nacc, $ntest, ($do_data ? " and DATA was sent" : ""));
	if ($nacc == 0) {
		printf("<h3><font color=\"#0000ff\">全ての不正中継を拒否されました。</font></h3>\n");
	}
	else {
		printf("<h3><font color=\"#ff0000\">%d 種のテストで不正中継の可能性が確認されました。</font></h3>\n", $nacc);
	}
}

sub print_header($) {
	my($s) = @_;
	printf("Content-Type: text/html; charset=EUC-JP\r\n");
	printf("\r\n");
	printf("<html><head><title>おセキュリティチェック%s</title></head>\n", $s);
	printf("<body><h1>おセキュリティチェック V0.8095 %s</h1>\n", $s);
}

sub print_footer() {
	printf("<hr><pre>\n");
	printf("Copyright (C) 2001, 2002 candy\n");
	printf('$Id: osecurity.cgi,v 1.34 2003/07/10 03:33:49 candy Exp candy $');
	printf("</body></html>\n");
}

sub print_form() {
	printf("</pre>\n");
	printf("※全てのセッションは記録されています。\n");
	printf("<form action=\"osecurity.cgi\" method=\"POST\">\n");
	printf("<table><tr>\n");
	printf("<td>IP アドレスまたはホスト名またはドメイン名</td>\n");
	printf("<td><input type=\"text\" name=\"target\" size=30 maxlength=256></td>\n");
	printf("</tr><tr><td></td>");
	printf("<td><input type=\"submit\" value=\"テストしちゃうよ!\">\n");
	printf("<input type=\"reset\" value=\"クリア\"></td>\n");
	printf("</tr><tr><td></td>");
	printf("<td><input type=\"checkbox\" name=\"generic_domain\" value=1 checked>FQDN からホスト名を除く</td>\n");
	printf("</tr><tr><td></td>");
	printf("<td><input type=\"checkbox\" name=\"do_data\" value=1>本当にメールを送る</td>\n");
	printf("</tr></table>\n");
	printf("</form>\n");
	printf("<pre>\n");
}

sub oain($$$) {
	my($remote_host, $remote_ip, $remote_domain, $so) = @_;
	$debug && printf("# oain(%s, %s)\n", $remote_host, $remote_domain);
	$so = \*SOCK;
	printf("<h3><li>%s (%s) for %s</h3>\n", $remote_host, $remote_ip, $remote_domain);
	printf(LOG "%s (%s) for %s\n", $remote_host, $remote_ip, $remote_domain);
	printf("<pre>\n");
	if (connection($so, $remote_ip, "smtp") == 0) {
		my($line);
		autoflush($so, 1);
		if ($line = get_line($so)) {
			if ($line = send_and_wait_250($so, "HELO %s\r\n", $my_hostname)) {
				if ($line =~ /^2/) {
					send_mail($so, "\"relaytest_requested_by_$client\"\@$to_domain");
					test_loop($so, $remote_host, $remote_ip, $remote_domain);
				}
				else {
					print_error("HELO failed.\n");
				}
			}
		}
	}
	printf("</pre><hr>");
	close(SOCK);
	return 0;
}

# 10 mx.example.com. --> mx.example.com
sub mxrec_to_mxhost($) {
	my($mxrec) = @_;
	my @v = split(/[ \t]+/, $mxrec); # 10 mx.example.com
	$v[1] =~ s/\.$//;
	return $v[1];
}

# hostname.example.com -> example.com
sub domain_of($) {
	my($fqdn) = @_;
	$fqdn =~ s/^[^.]*\.//;
	return $fqdn;
}

sub nain($) {
	my($domain_or_hostname, $remote_domain) = @_;
	$domain_or_hostname =~ s/\.$//;
	print_header("結果");
	$debug && printf("# nain(%s)\n", $domain_or_hostname);
	printf("<h2>TESTING %s</h2>\n", $domain_or_hostname);
	printf(LOG "%s: TESTING %s by %s\n", strftime("%Y/%m/%d-%H:%M:%S", localtime()), $domain_or_hostname, $client);
	if ($domain_or_hostname =~ /^[0-9.]+\.[0-9.]+\.[0-9.]+\.[0-9.]+$/) {
		my $remote_ip = $domain_or_hostname;
		my $fqdn = lookup_ptr($remote_ip);
		if ($fqdn eq "" ) {
			print_error("%s: cannot get FQDN\n", $remote_ip);
			$fqdn = $remote_ip;
			$remote_domain = "[$remote_ip]";
		}
		else {
			$remote_domain = $fqdn;
			if ($generic_domain) {
				$remote_domain = domain_of($remote_domain);
			}
		}
		printf("<ul>\n");
		oain($fqdn, $remote_ip, $remote_domain);
		printf("</ul>\n");
	}
	else {
		# ホスト名またはドメイン名
		my @mxrec = lookup_mx($domain_or_hostname);
		if ($#mxrec == -1) {
			# ホスト名・MX 無し
			my $remote_ip = inet_ntoa(inet_aton($domain_or_hostname));
			my $remote_domain = $domain_or_hostname;
			printf("No MX record\n");
			printf(LOG "No MX record\n");
			printf("<ul>\n");
			if ($generic_domain) {
				$remote_domain = domain_of($remote_domain);
			}
			oain($domain_or_hostname, $remote_ip, $remote_domain);
			printf("</ul>\n");
		}
		else {
			# ドメインまたはホスト名
			my($i);
			printf("found %d MX records\n", $#mxrec + 1); 
			printf(LOG "found %d MX records\n", $#mxrec + 1); 
			printf("<ol>\n");
			for ($i = 0; $i <= $#mxrec; $i++) {
				printf("<li>%s\n", $mxrec[$i]);
				printf(LOG "%d: %s\n", $i, $mxrec[$i]);
			}
			printf("</ol>\n");
			printf("<ol>\n");
			for ($i = 0; $i <= $#mxrec; $i++) {
				my $remote_domain = $domain_or_hostname;
				my $mxhost = mxrec_to_mxhost($mxrec[$i]);
				my $remote_ip = inet_ntoa(inet_aton($mxhost));
				#     domain_or_hostname mxhost            remote_domain
				# (1) mail.example.com   mx.example.com -> example.com
				# (2) mail.example.com   mx.other.com   -> mail.example.com
				# (3) example.com        mx.example.com -> example.com
				# (4) example.com        mx.other.com   -> example.com
				if ($generic_domain) {
					if ($domain_or_hostname ne domain_of($mxhost)) { # case (1) (2) (4)
						if (domain_of($domain_or_hostname) eq domain_of($mxhost)) { # case (1)
							$remote_domain = domain_of($remote_domain);
						}
					}
				}
				oain($mxhost, $remote_ip, $remote_domain);
			}
			printf("</ol>\n");
		}
	}
	notice();
	printf("<hr>\n");
	print_form();
	print_footer();
	return 0;
}


sub gethostname() {
	my $s = "";
	if (open(P, "hostname|")) {
		$s = <P>;
		chomp($s);
		close(P);
	}
	return $s;
}

sub main() {
	autoflush(\*STDOUT, 1);
	CGI::ReadParse();
	if (nz($::in{target}) eq "") {
		print_header("");
		printf("<h3>メールの不正第三者中継(オープンリレー)のテストを行います。</h3>\n");
		printf("<ul>\n");
		printf("<li>MAIL FROM: と RCPT TO: でテストします。「本当にメールを送る」をチェックしない限り、実際にはメールを送りません。\n");
		printf("<li>ホスト名を入力した場合、「FQDN からホスト名を除く」のチェックがあると、ホスト名を除いた残りをドメイン名とします。そうでなければ、ホスト名をドメイン名としてテストします。\n");
		printf("<li>特定のホストを調べるには、ホスト名でなく、IP アドレスを入力してください。\n");
		printf("</ul>\n");
		print_form();
		print_footer();
	}
	else {
		$do_data = !!nz($::in{do_data});
		$generic_domain = !!nz($::in{generic_domain});
		$client = nz($ENV{REMOTE_ADDR});
		$client = nz($ENV{REMOTE_ADDR});
		if ($client eq "") {
			$client = "unknown";
		}
		$my_hostname = gethostname();
		$to_domain = domain_of($my_hostname);
		$bounce_address = "relaytest\@" . $to_domain;
		if (open(LOG, ">>$logfile")) {
			autoflush(\*LOG, 1);
			nain($::in{target});
			close(LOG);
		}
		else {
			print_header("");
			printf("<h1>error</h1>\n");
			printf("cannot open log file %s\n", $logfile);
			printf("</body></html>\n");
		}
	}
	return 0;
}
exit(main());