separate queue method called from data.
store the header in a Mail::Header object for easier processing by the plugins git-svn-id: https://svn.perl.org/qpsmtpd/branches/v010@29 958fd67b-6ff1-0310-b445-bb7760255be9
This commit is contained in:
Ask Bjørn Hansen
parent
bcd0d6d534
commit
3e5de3a0b3
6
STATUS
6
STATUS
@ -2,6 +2,12 @@
|
||||
things to do for v0.10
|
||||
----------------------
|
||||
|
||||
transaction should probably be a part of the connection object instead
|
||||
of off the main object
|
||||
|
||||
get timeouts to work in "tcpserver" mode (or generally...)
|
||||
|
||||
|
||||
plugin support;
|
||||
|
||||
load plugins in a funny namespace
|
||||
|
||||
@ -7,9 +7,11 @@ use Qpsmtpd::Transaction;
|
||||
use Qpsmtpd::Constants;
|
||||
|
||||
use Mail::Address ();
|
||||
use Mail::Header ();
|
||||
use Sys::Hostname;
|
||||
use IPC::Open2;
|
||||
use Data::Dumper;
|
||||
use POSIX qw(strftime);
|
||||
BEGIN{$^W=0;}
|
||||
use Net::DNS;
|
||||
BEGIN{$^W=1;}
|
||||
@ -49,8 +51,14 @@ sub config {
|
||||
timeout => 1200,
|
||||
);
|
||||
|
||||
return ($self->get_qmail_config($c) || $defaults{$c} || undef);
|
||||
|
||||
if (wantarray) {
|
||||
my @config = $self->get_qmail_config($c);
|
||||
@config = @{$defaults{$c}} if (!@config and $defaults{$c});
|
||||
return @config;
|
||||
}
|
||||
else {
|
||||
return ($self->get_qmail_config($c) || $defaults{$c});
|
||||
}
|
||||
};
|
||||
|
||||
sub log {
|
||||
@ -200,7 +208,9 @@ sub check_relay {
|
||||
my $host = lc shift;
|
||||
my @rcpt_hosts = $self->config("rcpthosts");
|
||||
return 1 if exists $ENV{RELAYCLIENT};
|
||||
warn "HOSTTOCHECK: $host";
|
||||
for my $allowed (@rcpt_hosts) {
|
||||
warn "ALLOWED: $allowed";
|
||||
$allowed =~ s/^\s*(\S+)/$1/;
|
||||
return 1 if $host eq lc $allowed;
|
||||
return 1 if substr($allowed,0,1) eq "." and $host =~ m/\Q$allowed\E$/i;
|
||||
@ -275,62 +285,74 @@ sub data {
|
||||
my $max_size = ($self->config('databytes'))[0] || 0; # this should work in scalar context
|
||||
my $blocked = "";
|
||||
my %matches;
|
||||
my $header = 1;
|
||||
my $in_header = 1;
|
||||
my $complete = 0;
|
||||
|
||||
$self->log(6, "max_size: $max_size / size: $size");
|
||||
|
||||
my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE");
|
||||
|
||||
while (<STDIN>) {
|
||||
$complete++, last if $_ eq ".\r\n";
|
||||
$i++;
|
||||
$self->respond(451, "See http://develooper.com/code/qpsmtpd/barelf.html"), exit
|
||||
if $_ eq ".\n";
|
||||
unless ($max_size and $size > $max_size) {
|
||||
unless ($self->transaction->blocked and ($max_size and $size > $max_size)) {
|
||||
s/\r\n$/\n/;
|
||||
$header = 0 if $header and m/^\s*$/;
|
||||
if ($in_header and m/^\s*$/) {
|
||||
$in_header = 0;
|
||||
my @header = split /\n/, $buffer;
|
||||
|
||||
if ($header) {
|
||||
# ... need to check that we don't reformat any of the received lines.
|
||||
#
|
||||
# 3.8.2 Received Lines in Gatewaying
|
||||
# When forwarding a message into or out of the Internet environment, a
|
||||
# gateway MUST prepend a Received: line, but it MUST NOT alter in any
|
||||
# way a Received: line that is already in the header.
|
||||
|
||||
$matches{"aol.com"} = 1 if m/aol\.com/;
|
||||
$header->extract(\@header);
|
||||
$buffer = "";
|
||||
|
||||
$blocked = "Your mail looks too much like that SirCam nonsense, please go away"
|
||||
if $self->transaction->sender->format eq "<>"
|
||||
and $_ eq "Content-Disposition: Multipart message\n";
|
||||
|
||||
$blocked = "No List Builder spam for us, thank you."
|
||||
if m/^From: List Builder <notifications\@bcentral.com>/;
|
||||
# FIXME - call plugins to work on just the header here; can
|
||||
# save us buffering the mail content.
|
||||
|
||||
$blocked = q[Don't send W32.Badtrans.B@mm virus to us, please]
|
||||
if $matches{"aol.com"} and m/^From: .* <_/;
|
||||
}
|
||||
|
||||
if ($in_header) {
|
||||
#. ..
|
||||
}
|
||||
|
||||
|
||||
# Might be klez
|
||||
m/^Content-type:.*(?:audio|application)/i
|
||||
and $matches{"klez"}=1;
|
||||
|
||||
# we've seen the Klez signature, we're probably infected
|
||||
$blocked = q[Take your Klez virus and stuff it! HAND.]
|
||||
if $matches{"klez"} and m!^TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQA!;
|
||||
|
||||
$buffer .= $_;
|
||||
$size += length $_;
|
||||
}
|
||||
warn "$$ size is at $size\n" unless ($i % 300);
|
||||
$self->log(5, "size is at $size\n") unless ($i % 300);
|
||||
|
||||
alarm $self->config('timeout');
|
||||
}
|
||||
|
||||
$self->log(6, "max_size: $max_size / size: $size");
|
||||
|
||||
$self->transaction->header($header);
|
||||
$self->transaction->body(\$buffer);
|
||||
|
||||
# if we get here without seeing a terminator, the connection is
|
||||
# probably dead.
|
||||
$self->respond(451, "Incomplete DATA"), return 1 unless $complete;
|
||||
|
||||
$self->respond(550, $blocked),return 1 if $blocked;
|
||||
$self->respond(552, "Message too big!"),return 1 if $max_size and $size > $max_size;
|
||||
|
||||
#
|
||||
# FIXME - Call plugins to work on the body here
|
||||
#
|
||||
|
||||
$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked);
|
||||
|
||||
$self->respond(552, "Message too big!"),return 1 if $max_size and $size > $max_size;
|
||||
|
||||
return $self->queue($self->transaction);
|
||||
|
||||
}
|
||||
|
||||
sub queue {
|
||||
my ($self, $transaction) = @_;
|
||||
|
||||
# these bits inspired by Peter Samuels "qmail-queue wrapper"
|
||||
pipe(MESSAGE_READER, MESSAGE_WRITER) or fault("Could not create message pipe"), exit;
|
||||
@ -348,13 +370,19 @@ sub data {
|
||||
|
||||
close MESSAGE_READER or fault("close msg reader fault"),exit;
|
||||
close ENVELOPE_READER or fault("close envelope reader fault"), exit;
|
||||
print MESSAGE_WRITER "Received: from ".$self->connection->remote_info." (HELO ".$self->connection->hello_host . ") [".$self->connection->remote_ip . "]\n";
|
||||
print MESSAGE_WRITER " by ".$self->config('me')." (qpsmtpd/".$self->version.") with SMTP; ", scalar gmtime, "Z\n";
|
||||
print MESSAGE_WRITER $buffer;
|
||||
|
||||
print MESSAGE_WRITER "Received: from ".$self->connection->remote_info
|
||||
." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip
|
||||
. ")\n by ".$self->config('me')." (qpsmtpd/".$self->version
|
||||
.") with SMTP; ". (strftime('%Y-%m-%d %TZ', gmtime)) . "\n";
|
||||
print MESSAGE_WRITER "X-smtpd: qpsmtpd/",$self->version,", http://develooper.com/code/qpsmtpd/\n";
|
||||
|
||||
$transaction->header->print(\*MESSAGE_WRITER);
|
||||
print MESSAGE_WRITER ${$transaction->body};
|
||||
close MESSAGE_WRITER;
|
||||
|
||||
my @rcpt = map { "T" . $_->address } $self->transaction->recipients;
|
||||
my $from = "F".($self->transaction->sender->address|| "" );
|
||||
my @rcpt = map { "T" . $_->address } $transaction->recipients;
|
||||
my $from = "F".($transaction->sender->address|| "" );
|
||||
print ENVELOPE_WRITER "$from\0", join("\0",@rcpt), "\0\0"
|
||||
or respond(451,"Could not print addresses to queue"),exit;
|
||||
|
||||
@ -376,9 +404,7 @@ sub data {
|
||||
die "should never be here!";
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
@ -11,10 +11,6 @@ sub start {
|
||||
bless ($self, $class);
|
||||
}
|
||||
|
||||
sub add_header {
|
||||
my $self = shift;
|
||||
}
|
||||
|
||||
sub add_recipient {
|
||||
my $self = shift;
|
||||
@_ and push @{$self->{_recipients}}, shift;
|
||||
@ -29,15 +25,31 @@ sub sender {
|
||||
my $self = shift;
|
||||
@_ and $self->{_sender} = shift;
|
||||
$self->{_sender};
|
||||
|
||||
}
|
||||
|
||||
sub add_header_line {
|
||||
|
||||
sub header {
|
||||
my $self = shift;
|
||||
@_ and $self->{_header} = shift;
|
||||
$self->{_header};
|
||||
}
|
||||
|
||||
sub add_body_line {
|
||||
|
||||
sub body {
|
||||
my $self = shift;
|
||||
@_ and $self->{_body} = shift;
|
||||
$self->{_body};
|
||||
}
|
||||
|
||||
sub blocked {
|
||||
my $self = shift;
|
||||
@_ and $self->{_blocked} = shift;
|
||||
$self->{_blocked};
|
||||
}
|
||||
|
||||
|
||||
#sub add_header_line {
|
||||
#}
|
||||
|
||||
#sub add_body_line {
|
||||
#}
|
||||
|
||||
1;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user