1
package ProtoWrap::SMTP;
#
# ProtoWrap::SMTP - SMTP extension to ProtoWrap
#
use ProtoWrap;
@ISA = qw(ProtoWrap);
use strict;
use vars qw($crlf);
$crlf = chr(13).chr(10);
sub new {
my ($class,$self,@smtpSpecific,@smtpNotProtoWrap,%tmpHash);
$class = shift;
$self = { @_ };
bless $self, $class;
# Parameters accepted for SMTP that are not part of the base
# ProtoWrap should be stored in a temporal hash until the object is
# created if we do not want ProtoWrap to complain, and then added
# to the existing object.
# The affected attributes are:
# maxMsgSize - the maximum message size allowed
# blockAddrList - A reference to an array with a list of regular
# expressions representing blocked addresses.
# blockBodyList - A reference to an array with a list of regular
# expressions representing lines to be blocked in the message body.
# maxRcpt - The maximum number of recipients specified with
# RCPT TO:
# relayDomainList - List of domains which will be relayed - they are
# required to appear either in the MAIL FROM or in the RCPT TO areas.
# (regex anchored to end of string)
# relayIpList - List of IP addresses or ranges which will be accepted
# for relay. (regex anchored to beginning of string)
@smtpNotProtoWrap = qw(maxMsgSize blockAddrList blockBodyList
relayDomainList relayIpList maxRcpt);
foreach (@smtpNotProtoWrap) {
if (defined $self->{$_}) {
$tmpHash{$_} = $self->{$_};
delete $self->{$_};
}
}
# Check for wrong parameters
@smtpSpecific = ('testLine','testReply');
foreach (@smtpSpecific) {
if (defined $self->{$_}){
$self->log(0,"Parameter $_ incompatible with SMTP");
return undef
}
}
# Set the SMTP defined parameters needed to create a ProtoWrap
if ($self->{destType} eq 'ip') {
$self->{destPort} = 25 unless (defined $self->{destPort});
$self->{destAddr} = '127.0.0.1' unless (defined $self->{destAddr});
} elsif ($self->{destType} eq 'pipe') {
$self->{pipeCmd} = '/usr/lib/sendmail -bs' unless (defined $self->{pipeCmd});
}
$self->{standalone} = 1 unless defined $self->{standalone};
$self->{testLine} = \&defaultTestLine;
$self->{testReply} = 1;
$self->{logName} = 'ProtoWrap-SMTP';
# Create the ProtoWrap. If it is undef, an error occured and we
# should not start.
$self = ProtoWrap->new(%$self);
return undef if (not defined $self);
# Add SMTP-specific attributes not allowed for base ProtoWraps,
# and free %tmpHash's memory
foreach (keys(%tmpHash)) {
$self->{$_} = $tmpHash{$_};
delete $tmpHash{$_};
}
# Set the needed parameters for a SMTP ProtoWrap that could not be
# specified before creating a ProtoWrap
$self->{maxMsgSize} = 10000000 if (not defined $self->{maxMsgSize});
$self->{stage}=-1;
# Make $self a SMTP object
bless $self, $class;
}
sub defaultTestLine {
my ($self,$line,$socket,$who) = @_;
if ($who == 0) {
return &fromClient($self,$line,$socket);
} elsif ($who == 1) {
return &fromServer($self,$line,$socket);
} else {
}
}
sub fromServer {
my($self,$line,$socket,$who,$retValue);
($self,$line,$socket,$who) = @_;
$retValue = 1;
# We strip CR and LF to do the tests, add them back at the
# end.
$$line =~ s/[\r\n]//g;
if ($self->{stage} == -1) {
# Stage -1: Waiting for the server to say hello.
# Instead of letting the real server expose its identity,
# we give ours. We only check if the server's response
# starts with 2, meaning that the incoming connection
# should be accepted. We switch to stage 0, and signal that
# we have still not decided to relay this message.
$$line = '220 localhost.localdomain ESMTP ProtoWrap wrapper '.$self->version() if
(substr($$line,0,1) eq '2');
$self->{relayOk} = 0;
# If the connection comes from an authorized relaying IP,
# allow relaying.
foreach (@{$self->{relayIpList}}) {
$self->{relayOk} = 1 if (defined $self->{srcIpAddr} &&
$self->{srcIpAddr} =~ /^$_/);
}
$self->{stage} = 0;
} elsif ($self->{stage} == 1) {
# If we get a 550 <address> Access denied message from
# the server, and rcpts is 1, this means that the server
# denied a sender address. We restore stage to 0.
# If we are getting a 550 Access denied, we are almost
# surely with 0 recipients... But double-checking does
# not hurt.
if ($$line =~ /^550 .+ Access denied/) {
$self->{stage} = 0 if ($self->{rcpts} == 0)
}
}
$$line .= chr(13).chr(10);
return $retValue;
}
sub fromClient {
# stage indicates the current stage of the connection, thus
# indicating what will be accepted or rejected in the ongoing
# communication.
#
my($self,$line,$socket,$who,$retValue);
($self,$line,$socket,$who) = @_;
$retValue = 1;
# We strip CR and LF to do the tests, add them back at
# the end.
$$line =~ s/[\r\n]//g;
#
# Our first test should be for maxLineLength
#
if (length($$line) > $self->{maxLineLength} && $self->{maxLineLength} > 0) {
$$line = substr($$line,0,$self->{maxLineLength});
$self->log(1,"Line too long\nChopping to:\n$$line");
}
# Stage -1 indicates that the server has not yet talked on
# the connection, and all traffic before this should be
# silently dropped.
if ($self->{stage} < 0) {
$$line = '';
return -1;
}
# If we are in stage 9, we should check against rejectMsg, maxMsgSize and
# any regexes found in blockBodyList
if ($self->{stage} == 9) {
if ($$line eq '.') {
if ($self->{msgLength} > $self->{maxMsgSize} && $self->maxMsgSize != 0) {
# Report that message is too long and end the
# connection. Closing the socket causes the server to
# discard the message. We then exit cleanly.
$socket->print('550 Message length exceeded - maximum allowed: '.
$self->{maxMsgSize}.' bytes'.$crlf);
$socket->close;
$self->log(1,'Terminating connection');
exit 0;
} elsif ($self->{rejectMsg}) {
$socket->print('550 Message rejected - security check failed'.$crlf);
$socket->close;
$self->log(1,'Terminating connection');
exit 0;
} else {
# Set everything up to start processing a new message
$self->{stage} = 0;
$self->{relayOk} = 0;
foreach (@{$self->{relayIpList}}) {
$self->{relayOk} = 1 if (defined $self->{srcIpAddr} &&
$self->{srcIpAddr} =~ /^$_/);
}
}
}
if ($self->{rejectMsg}) {
# Message has been flagged to be rejected. Pretend to continue
# processing it. The server does not need to know about it,
# anyway, as we are going to discard it.
$$line = '';
$retValue = -1;
}
# If we are over maxMsgSize, stop sending data to the
# server
if ($self->{msgLength} >= $self->{maxMsgSize}) {
$$line = '';
$retValue = -1;
}
# Check now against the blockBodyList
foreach (@{$self->{blockBodyList}}) {
if ($$line =~ /$_/i) {
# If it matches, keep recieving the message (we can only
# indicate failure after the message has been completely
# recieved if we want to stay RFC compliant).
$self->{rejectMsg} = 1;
$self->log(1,"Message rejected - Matched blockBodyList rule $_");
}
}
$$line .= chr(13).chr(10);
$self->{msgLength} += length($$line);
return $retValue;
}
# At this point, we are certain that we are in a command-only
# stage. SMTP Commands are all over four characters long.
if (length($$line) < 4) {
$socket->print("500 Command unrecognized: \"$$line\"$crlf");
$$line = '';
$retValue = 0;
# Commands which should be allowed no matter which stage
# are we in.
} elsif (uc(substr($$line,0,4)) eq 'QUIT') {
# If a QUIT is recieved, return only QUIT, chopping the
# rest of the line.
$$line = 'QUIT';
$self->{stage} = 10;
} elsif (uc(substr($$line,0,4)) eq 'RSET') {
# If a RSET is recieved, return only RSET, chopping the
# rest of the line.
$$line = 'RSET';
$self->{stage} = 0;
$self->{relayOk} = 0;
} elsif ($$line =~ /^HELO [\w\d\.\-\_]+/i || $$line =~ /EHLO [\w\d\.\-\_]+/i) {
# Just allow it to reach the server. Warn if resolved name
# is not similar to reported name
my $reported = $$line;
my $srcName = $self->{srcName};
$reported =~ s/^(HE|EH)LO\s+//i;
$self->log(4,"Resolved ($srcName) and reported ($reported) hostnames don't match")
if (defined $srcName && defined $reported && $srcName !~ $reported
&& $reported !~ $srcName);
# Convert EHLO into HELO - ProtoWrap wants the client to
# stay in the base SMTP command set, disallowing
# extensions
$$line = 'HELO '.$reported;
# Commands which should be disallowed or handled at the
# wrapper no matter which stage are we in (should also
# send an error message back to the client if adequate)
} elsif (uc(substr($$line,4)) =~ /^(VRFY|EXPN|SEND|SAML|SOML|TURN|HELP)/) {
$socket->print("502 Sorry, we do not allow this operation$crlf");
$$line = '';
$retValue = 0;
} elsif (uc(substr($$line,0,4)) eq 'NOOP') {
$socket->print("250 OK$crlf");
$$line = '';
$retValue = -1;
# Now, commands specific to a certain stage
} elsif ((not defined $self->{stage}) || $self->{stage} == 0) {
# First stage,
# Allow only MAIL FROM:<address>. While checking, delete
# all unnecessary blank spaces.
if ($$line =~ /^MAIL\s+FROM:/i) {
# Is it a valid address?
# Note that MAIL FROM: <> must also be allowed, since it is
# used for administrative purposes
if ($$line =~
s/^MAIL\s+FROM:\s*(\?)/MAIL FROM:<$1>/i ||
$$line =~
s/^MAIL\s+FROM:\s*<>/MAIL FROM:<>/i ) {
# Check against the blockAddrList and the relayDomainList
my ($reject);
$self->{msgFrom} = $$line;
$reject = 0;
$self->{msgFrom} =~ s/MAIL\s+FROM:\s*//i;
foreach (@{$self->{blockAddrList}}) {
if ($self->{msgFrom} =~ /$_/i) {
$reject = 1;
$socket->print('550 '.$self->{msgFrom}."... Access denied$crlf");
$retValue = -1;
last;
}
}
foreach (@{$self->{relayDomainList}}) {
if ($self->{msgFrom} =~ /$_$/i) {
$self->{relayOk} = 1;
}
}
if ($reject == 0) {
$self->{stage} = 1;
$self->{rcpts} = 0;
}
} else {
$retValue = 0;
$$line =~ s/MAIL\s+FROM:\s*//;
$socket->print("553 $$line... Domain name required$crlf");
}
} else {
# Disallow everything else
$retValue = 0;
chomp $$line;
$socket->print("500 Command unrecognized: \"$$line\"$crlf");
$$line = '';
}
} elsif ($self->{stage} == 1) {
# Second stage.
# Allow only RCPT TO:<address> and check if we have not
# reached maxRcpt
if ($$line =~
s/^RCPT\s+TO:\s*(\<*[\w\d\.\-\_\=]+\@?[\w\d\.\-\_]*\>*)/RCPT TO:$1/i) {
# Sometimes addresses are supplied surrounded by angled
# brackets <>. We can safely strip them out.
$$line =~ s/[\<\>]//g;
# Allow relaying if no destination host is specified
# (local user)
$self->{relayOk} = 1 if (index($$line,'@') == -1);
# relayOk is true if the original sender appears in the
# relayDomainList
if ($self->{relayOk} == 0) {
# If it does not, check if the sender does
$self->{msgTo} = $$line;
$self->{msgTo} =~ s/RCPT\s+TO:\s*//i;
foreach (@{$self->{relayDomainList}}) {
if ($self->{msgTo} =~ /$_$/i) {
$self->{relayOk} = 1;
}
}
}
# If relayOk is still 0, the recipient should not be accepted
if ($self->{relayOk} == 0) {
$socket->print('550 '.$self->{msgTo}.'... Relaying denied'.$crlf);
$$line = '';
$self->log(1,'Relaying denied from '.$self->{msgFrom}.' to '.
$self->{msgTo}.
' from '.$self->{srcName}.'('.$self->{srcIpAddr}.')');
$retValue = -1;
} else {
if ($self->{rcpts} < $self->{maxRcpt} || $self->{maxRcpt} == 0) {
$self->{stage} = 2;
$self->{rcpts}++;
} else {
$socket->print('551 Too many recipients ('.$self->{rcpts}.")$crlf");
$self->log(1,'Too many recipients: '.$self->{rcpts});
$$line = '';
$retValue = -1;
}
}
} else {
# Disallow everything else
$retValue = 0;
chomp $$line;
$socket->print("500 Command unrecognized: \"$$line\"$crlf");
$$line = '';
}
} elsif ($self->{stage} == 2) {
# Third stage
# Allow DATA, switching to stage 9 and resetting the
# message length counter, or allow for additional
# RCPT TO, staying in stage 2.
if (uc(substr($$line,0,4)) eq 'DATA') {
$self->{stage} = 9;
$$line="DATA";
$self->{msgLength} = 0;
$self->{rejectMsg} = 0;
} elsif ($$line =~
s/^RCPT\s+TO:\s*(\<*[\w\d\.\-\_\=]+\@?[\w\d\.\-\_]*\>*)/RCPT TO:$1/i) {
# Sometimes addresses are supplied surrounded by angled
# brackets <>. We can safely strip them out.
$$line =~ s/[\<\>]//g;
if ($self->{rcpts} < $self->{maxRcpt} || $self->{maxRcpt} == 0) {
$self->{stage} = 2;
$self->{rcpts}++;
} else {
$socket->print('551 Too many recipients: '.$self->{rcpts}.")$crlf");
$self->log(1,'Too many recipients ('.$self->{rcpts});
$$line = '';
$retValue = -1;
}
} else {
# Disallow everything else
$retValue = 0;
chomp $$line;
$socket->print("500 Command unrecognized: \"$$line\"$crlf");
$$line = '';
}
} else {
$$line = '';
$retValue=0;
}
$$line .= chr(13).chr(10);
return $retValue;
}
1;