#!/usr/local/bin/perl
#
# $Id: rlytest,v 1.22 2001/10/22 22:02:48 chip Exp $
#
# $Log: rlytest,v $
# Revision 1.22  2001/10/22 22:02:48  chip
# updated message
#
# Revision 1.21  2001/10/22 19:57:38  chip
# updated URLs
#
# Revision 1.20  2000/06/21 09:02:09  chip
# Produce useful diagnostic if socket fails.
# Thanks to Paul Ewing Jr. <ewing@ima.umn.edu>
#
# Revision 1.19  2000/06/11 06:21:49  chip
# now uses exit status 2 to indicate successful relay submission
# added $EX_RELAY_ACCEPTED $EX_RELAY_REJECTED $EX_PROGRAM_ERROR
#
# Revision 1.18  2000/04/04 08:25:32  chip
# changed default domain from acme.com to example.com
#
# Revision 1.17  1999/08/20 07:11:54  chip
# moved uid=0 check before calculate_fqdn is called (oof!)
# thanks to Paul David Fardy <pdf@morgan.ucs.mun.ca> for catching that
#
# Revision 1.16  1999/05/25 15:51:57  chip
# added $Root_check to avoid running as root
# remove $! from socket creation failure, people were finding it confusing
#
#
# rlytest - test mail host for third-party relay
# (see POD documentation at end)
#
# Chip Rosenthal
# Unicom Systems Development
# <chip@unicom.com>
#

require 5.002;
use strict;
use Getopt::Std;
use IO::Socket;	# warning - IO::Socket was an optional add-on prior to 5.004
use Time::gmtime;
use vars qw($Usage $Dflt_hostname $Dflt_domain $Root_check %Opts
	$Target_host $Timeout $Hostname $Username $Comment
	$Actual_sender $MailFrom_addr $RcptTo_addr $Mssg_body);

$0 =~ s!.*/!!;
$Usage = "usage: $0 [-f sender_addr] [-u recip_addr] [-c comment] [-t timeout] target_host";

use vars qw($EX_RELAY_ACCEPTED $EX_RELAY_REJECTED $EX_PROGRAM_ERROR);
$EX_RELAY_REJECTED = 0;
$EX_RELAY_ACCEPTED = 2;
$EX_PROGRAM_ERROR = 1;

#
# Host name configuration - Leave these commented out unless the
# calculate_fqdn() routine is unable to calculate your FQDN (fully
# qualified domain name) correctly.  You'll know if it fails, because
# the script will bomb out bitching about the FQDN.  If this happens,
# try setting $Dflt_domain to your domain.  Or, if you like, you
# may hardwire $Dflt_hostname to a particular FQDN.
#
### $Dflt_domain = "example.com";
### $Dflt_hostname = "dopey.example.com";

#
# This utility does not need to be run as root.  In fact, there is
# a potential problem in doing so.  In the "calculate_fqdn" subroutine,
# one of the ways it tries to obtain the host name is with "hostname -f".
# While this works on some systems, on others it will attempt to change
# the local hostname to "-f"!
#
$Root_check = 1;

if ($Root_check && $> == 0) {
	print STDERR q[
You should not be running this as root!
Recommend you abort and run as a nonprivileged user.
Pausing 10 seconds.];
	foreach $_ (1 .. 10) {
		print STDERR ".";
		sleep 1;
	}
	print STDERR "\n";
}

#
# Unbuffered output.
#
autoflush STDOUT 1;

#
# Crack command line.
#
getopts('c:f:t:u:', \%Opts)
	or die "$Usage";
die "$Usage\n"
	unless (@ARGV == 1);
$Target_host = shift;

#
# Initialize parameters.
#
$Timeout = $Opts{'t'} || 60;
$Hostname = calculate_fqdn()
	or die "$0: cannot determine FQDN\n";
$Username = $ENV{'LOGNAME'} || $ENV{'USER'} || die "$0: LOGNAME undefined\n";
$Actual_sender = $Username . "\@" . $Hostname;
$RcptTo_addr = $Opts{'u'} || $Actual_sender;
$Comment = $Opts{'c'} . "\n"
	if ($Opts{'c'});

if ($Opts{'f'} ne "") {
	$MailFrom_addr = $Opts{'f'};
} elsif ($Target_host =~ /^\d+\.\d+\.\d+\.\d+$/) {
	$MailFrom_addr = "nobody\@[${Target_host}]";
} else {
	$MailFrom_addr = "nobody\@${Target_host}";
}

#
# Construct the test message.
#
$Mssg_body =
	"To: $RcptTo_addr\n"
	. "From: $MailFrom_addr\n"
	. "Subject: test for susceptibility to third-party mail relay\n"
	. "Date: " .  arpa_date(time()) . "\n"
	. "Message-Id: <rlytest-" . time() . "-" . $$ . "\@$Hostname>\n"
	. "Sender: $Actual_sender\n"
	. qq[
This message is a test probe, to ensure that your mail server is secured
against third-party mail relay.  This is NOT an attempt to hack or
crack your system, but just to ensure the system are secured against
this common vulnerability.  This test usually is performed by a system
administrator who is trying to determine the source of a spam email.

A well-configured mail server should NOT relay third-party email.
Otherwise, the server is subject to attack and hijack by Internet vandals
and spammers.  For information on how to secure a mail server against
third-party relay, visit <URL: http://mail-abuse.org/tsi/>.

This probe was generated by the "rlytest" utility.  For more information,
visit <URL: http://www.unicom.com/sw/rlytest/>.

    Target host = $Target_host
    Test performed by <$Actual_sender>

If you have any concern about this test, please contact the person listed
in the "test performed by" line above.

${Comment}
.
];

#
# Connect and execute SMTP diaglog.
#
print "Connecting to $Target_host ...\n";
my $sock = IO::Socket::INET->new(
		Proto => "tcp",
		PeerAddr => $Target_host,
		PeerPort => "smtp(25)",
		Timeout => $Timeout)
	or die "$0: socket failed: cannot connect to $Target_host: $@\n";

$SIG{'ALRM'} = sub { die "$0: timeout waiting for socket I/O\n"; };
$sock->autoflush(1);
read_response($sock);
write_command($sock, "HELO $Hostname\n");
write_command($sock, "MAIL FROM:<$MailFrom_addr>\n");
write_command($sock, "RCPT TO:<$RcptTo_addr>\n");
write_command($sock, "DATA\n");
write_command($sock, $Mssg_body, "(message body)\n");
my $code = write_command($sock, "QUIT\n");

#
# Dialog successful (which is bad -- that means the relay was accepted).
#
warn "$0: relay accepted - final response code $code\n";
exit($EX_RELAY_ACCEPTED);


#
# usage: write_command($sock, $data_to_send[, $mssg_to_display])
#
sub write_command
{
	my $sock = shift;
	my $data = shift;
	my $mssg = shift || $data;
	print ">>> $mssg";
	$data =~ s/\n/\r\n/g;
	alarm($Timeout);
	$sock->print($data)
		or die "$0: socket write failed [$!]\n";
	alarm(0);
	return read_response($sock);
}


#
# usage: $response_code = read_response($sock);
#
sub read_response
{
	my $sock = shift;
	my($code, $cont, $mssg);

	do {
		alarm($Timeout);
		chop($_ = $sock->getline());
		alarm(0);
		($code, $cont, $mssg) = /(\d\d\d)(.)(.*)/;
		print "<<< ", $_, "\n";
	} while ($cont eq "-");
	return $code
		if ($code >= 200 && $code < 400);

	alarm($Timeout);
	$sock->print("QUIT\r\n");
	alarm(0);
	warn "$0: relay rejected - final response code $code\n";
	exit($EX_RELAY_REJECTED);
}


#
# usage: $hostname = calculate_fqdn();
#
sub calculate_fqdn
{
	my @trycmds = ("hostname", "hostname -f", "uname -n");
	my $cmd;
	my $hostname;

	return $Dflt_hostname
		if ($Dflt_hostname);

	foreach $cmd (@trycmds) {
		chop($hostname = `$cmd`);
		return $hostname
			if ($hostname =~ /\./);
		return $hostname . "." . $Dflt_domain
			if ($hostname && $Dflt_domain);
	}

	die "$0: cannot determine FQDN - please set \$Dflt_domain or \$Dflt_hostname\n"
}


#
# usage: $date_header = arpa_date($secs_since_epoch)
#
sub arpa_date
{
	my $gm = gmtime(shift);
	my @Day_name = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat");
	my @Month_name = (
		"Jan", "Feb", "Mar", "Apr", "May", "Jun",
		"Jul", "Aug", "Sep", "Oct", "Nov", "Dec");

	sprintf("%-3s, %02d %-3s %4d %02d:%02d:%02d GMT",
		$Day_name[$gm->wday],
		$gm->mday, $Month_name[$gm->mon], 1900+$gm->year,
		$gm->hour, $gm->min, $gm->sec);

}


__END__

=head1 NAME

rlytest - test mail host for third-party relay

=head1 SYNOPSIS

B<rlytest>
[B<-f> sender_addr]
[B<-u> recip_addr]
[B<-c> I<comment>]
[B<-t> I<timeout>]
I<target_host>

=head1 DESCRIPTION

The B<rlytest> utility performs a test on I<target_host> to determine
whether it will relay third-party email.  It will try to relay an
email message to yourself through that host.  A host that allows
third-party relay is subject to attack by Internet vandals, and
frequently is hijacked by spammers to relay massive amounts of junk
email.  A host that allows third-party relay should be B<immediately>
secured, disconnected, or shunned as a menace to the Internet.

The following options are available:

=over 4

=item B<-f> I<sender_addr>

Specifies the (C<MAIL FROM>) email address to use on the probe.
By default, B<rlytest> tries to calculate an email address in the
target domain.  This is to ensure that the host is not using simple
(and easily defeated) envelope checks for anti-relay protection.

=item B<-u> I<recip_addr>

Specifies the (C<RCPT TO>) email address to use on the probe.  By
default, B<rlytest> tries to calculate your email address and use
that.  A host that is susceptible to relay will deliver a probe
message to this address.

=item B<-c> I<comment>

Embed I<comment> in the body of the test message.  This may
be useful, for instance, if you are doing some automatic testing
and want to insert cookies into the messages.

=item B<-t> I<timeout>

Sets the timeout value (default is 60 seconds) for certain
operations.

=back

If the remote host refused to relay the message, the program
will terminate with a zero exit status dislay a message to
I<stderr> similar to:

  rlytest: relay rejected - status code 571

If the message was accepted, the program will terminate with an
exit status of 2 and display a message to I<stderr> similar to:

  rlytest: relay accepted - status code 221

Any other (non-zero) exit status indicates a program error, such as a
bad hostname or host not resopnding.

=head1 EXAMPLE

Here is an example, showing a host that refuses third-party relay:

  $ ./rlytest mail.example.dom
  Connecting to mail.example.dom ...
  <<< 220 mail.example.dom ready
  >>> HELO garcon.unicom.com
  <<< 250 Hello garcon.unicom.com, pleased to meet you
  >>> MAIL FROM:<nobody@mail.example.dom>
  <<< 250 <chip@garcon.unicom.com>... Sender ok
  >>> RCPT TO:<chip@garcon.unicom.com>
  <<< 550 <chip@garcon.unicom.com>... Relaying Denied
  rlytest: relay rejected - status code 550

=head1 BUGS

There is no reliable and portable method to determine the local
host's fully qualified domain name.  If the utility bombs out
complaining about FQDN problems, read the "host name configuration"
information near the top of the script.

=head1 SEE ALSO

mail(1),
sendmail(8),
smtpd(8)

=head1 AUTHOR

  Chip Rosenthal
  Unicom Systems Development
  <chip@unicom.com>

  $Id: rlytest,v 1.22 2001/10/22 22:02:48 chip Exp $
  See http://www.unicom.com/sw/#rlytest for latest version.