byterazor/qpsmtpd
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

find . -name '*.pm' -exec perltidy -b {} \;

Browse Source
This commit is contained in:
Matt Simerson 2013-04-21 00:08:43 -04:00
parent fd2c56fb36
commit 5b06929e95
23 changed files with 2602 additions and 2317 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
lib/Apache/Qpsmtpd.pm
View File

@ -56,7 +56,8 @@ sub config_dir {
$cdir =~ /^(.*)$/; # detaint
my $configdir = $1 if -e "$1/$config";
$cdir_memo{$config} = $configdir;
} else {
}
else {
$cdir_memo{$config} = $self->SUPER::config_dir(@_);
}
return $cdir_memo{$config};
@ -67,11 +68,14 @@ sub start_connection {
my %opts = @_;
$self->{conn} = $opts{conn};
$self->{conn}->client_socket->timeout_set($self->config('timeout') * 1_000_000);
$self->{bb_in} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
$self->{bb_out} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
$self->{conn}
->client_socket->timeout_set($self->config('timeout') * 1_000_000);
$self->{bb_in} =
APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
$self->{bb_out} =
APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
my $remote_host = $opts{host} || ( $opts{ip} ? "[$opts{ip}]" : "[noip!]");
my $remote_host = $opts{host} || ($opts{ip} ? "[$opts{ip}]" : "[noip!]");
my $remote_info = $opts{info} ? "$opts{info}\@$remote_host" : $remote_host;
my $remote_ip = $opts{ip};
@ -119,7 +123,8 @@ sub getline {
my $bb = $self->{bb_in};
while (1) {
my $rc = $c->input_filters->get_brigade($bb, Apache2::Const::MODE_GETLINE);
my $rc =
$c->input_filters->get_brigade($bb, Apache2::Const::MODE_GETLINE);
return if $rc == APR::Const::EOF;
die APR::Error::strerror($rc) unless $rc == APR::Const::SUCCESS;
@ -151,11 +156,12 @@ sub respond {
my $c = $self->{conn};
while (my $msg = shift @messages) {
my $bb = $self->{bb_out};
my $line = $code . (@messages?"-":" ").$msg;
my $line = $code . (@messages ? "-" : " ") . $msg;
$self->log(LOGDEBUG, $line);
my $bucket = APR::Bucket->new(($c->bucket_alloc), "$line\r\n");
$bb->insert_tail($bucket);
$c->output_filters->fflush($bb);
# $bucket->remove;
$bb->cleanup;
}

42
lib/Danga/Client.pm
View File

@ -22,7 +22,7 @@ sub max_connect_time { 1200 }
sub new {
my Danga::Client $self = shift;
$self = fields::new($self) unless ref $self;
$self->SUPER::new( @_ );
$self->SUPER::new(@_);
$self->reset_for_next_message;
return $self;
@ -52,10 +52,12 @@ sub get_bytes {
$self->{line} = '';
if ($self->{read_bytes} <= 0) {
if ($self->{read_bytes} < 0) {
$self->{line} = substr($self->{data_bytes},
$self->{line} = substr(
$self->{data_bytes},
$self->{read_bytes}, # negative offset
0 - $self->{read_bytes}, # to end of str
""); # truncate that substr
""
); # truncate that substr
}
$callback->($self->{data_bytes});
return;
@ -132,6 +134,7 @@ sub event_read {
$self->{data_bytes} .= $$bref;
}
if ($self->{read_bytes} <= 0) {
# print "Erk, read too much!\n" if $self->{read_bytes} < 0;
my $cb = $self->{callback};
$self->{callback} = undef;
@ -155,16 +158,24 @@ sub process_read_buf {
my $line = $1;
$self->{alive_time} = time;
my $resp = $self->process_line($line);
if ($::DEBUG > 1 and $resp) { print "$$:".($self+0)."S: $_\n" for split(/\n/, $resp) }
if ($::DEBUG > 1 and $resp) {
print "$$:" . ($self + 0) . "S: $_\n" for split(/\n/, $resp);
}
$self->write($resp) if $resp;
# $self->watch_read(0) if $self->{pause_count};
return if $self->{pause_count} || $self->{closed};
# read more in a timer, to give other clients a look in
$self->AddTimer(0, sub {
$self->AddTimer(
0,
sub {
if (length($self->{line}) && !$self->paused) {
$self->process_read_buf(\""); # " for bad syntax highlighters
$self->process_read_buf(\"")
; # " for bad syntax highlighters
}
});
}
);
}
}
@ -188,6 +199,7 @@ sub paused {
sub pause_read {
my Danga::Client $self = shift;
$self->{pause_count}++;
# $self->watch_read(0);
}
@ -196,11 +208,15 @@ sub continue_read {
$self->{pause_count}--;
if ($self->{pause_count} <= 0) {
$self->{pause_count} = 0;
$self->AddTimer(0, sub {
$self->AddTimer(
0,
sub {
if (length($self->{line}) && !$self->paused) {
$self->process_read_buf(\""); # " for bad syntax highlighters
$self->process_read_buf(\"")
; # " for bad syntax highlighters
}
});
}
);
}
}
@ -216,6 +232,10 @@ sub close {
}
sub event_err { my Danga::Client $self = shift; $self->close("Error") }
sub event_hup { my Danga::Client $self = shift; $self->close("Disconnect (HUP)") }
sub event_hup {
my Danga::Client $self = shift;
$self->close("Disconnect (HUP)");
}
1;

182
lib/Qpsmtpd.pm
View File

@ -33,6 +33,7 @@ sub _restart {
my $self = shift;
my %args = @_;
if ($args{restart}) {
# reset all global vars to defaults
$self->clear_config_cache;
$hooks = {};
@ -44,19 +45,19 @@ sub _restart {
}
}
sub DESTROY {
#warn $_ for DashProfiler->profile_as_text("qpsmtpd");
}
sub version { $VERSION . ($git ? "/$git" : "") };
sub version { $VERSION . ($git ? "/$git" : "") }
sub TRACE_LEVEL { $TraceLevel }; # leave for plugin compatibility
sub hooks { $hooks; }
sub load_logging {
# need to do this differently than other plugins so as to
# not trigger logging activity
return if $LOGGING_LOADED;
@ -64,14 +65,14 @@ sub load_logging {
return if $hooks->{"logging"};
my $configdir = $self->config_dir("logging");
my $configfile = "$configdir/logging";
my @loggers = $self->_config_from_file($configfile,'logging');
my @loggers = $self->_config_from_file($configfile, 'logging');
$configdir = $self->config_dir('plugin_dirs');
$configfile = "$configdir/plugin_dirs";
my @plugin_dirs = $self->_config_from_file($configfile,'plugin_dirs');
my @plugin_dirs = $self->_config_from_file($configfile, 'plugin_dirs');
unless (@plugin_dirs) {
my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
@plugin_dirs = ( "$name/plugins" );
@plugin_dirs = ("$name/plugins");
}
my @loaded;
@ -85,7 +86,7 @@ sub load_logging {
$configdir = $self->config_dir("loglevel");
$configfile = "$configdir/loglevel";
$TraceLevel = $self->_config_from_file($configfile,'loglevel');
$TraceLevel = $self->_config_from_file($configfile, 'loglevel');
unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) {
$TraceLevel = LOGWARN; # Default if no loglevel file found.
@ -107,16 +108,16 @@ sub init_logger { # needed for compatibility purposes
sub log {
my ($self, $trace, @log) = @_;
$self->varlog($trace,join(" ",@log));
$self->varlog($trace, join(" ", @log));
}
sub varlog {
my ($self, $trace) = (shift,shift);
my ($self, $trace) = (shift, shift);
my ($hook, $plugin, @log);
if ( $#_ == 0 ) { # log itself
if ($#_ == 0) { # log itself
(@log) = @_;
}
elsif ( $#_ == 1 ) { # plus the hook
elsif ($#_ == 1) { # plus the hook
($hook, @log) = @_;
}
else { # called from plugin
@ -125,16 +126,19 @@ sub varlog {
$self->load_logging; # in case we don't have this loaded yet
my ($rc) = $self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log)
my ($rc) =
$self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log)
or return;
return if $rc == DECLINED || $rc == OK; # plugin success
return if $trace > $TraceLevel;
# no logging plugins registered, fall back to STDERR
my $prefix = defined $plugin && defined $hook ? " ($hook) $plugin:" :
defined $plugin ? " $plugin:" :
defined $hook ? " ($hook) running plugin:" : '';
my $prefix =
defined $plugin && defined $hook ? " ($hook) $plugin:"
: defined $plugin ? " $plugin:"
: defined $hook ? " ($hook) running plugin:"
: '';
warn join(' ', $$ . $prefix, @log), "\n";
}
@ -157,7 +161,8 @@ sub config {
# XXX - is this always the right thing to do? what if a config hook
# can return different values on subsequent calls?
if ($_config_cache->{$c}) {
$self->log(LOGDEBUG, "config($c) returning (@{$_config_cache->{$c}}) from cache");
$self->log(LOGDEBUG,
"config($c) returning (@{$_config_cache->{$c}}) from cache");
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
@ -165,7 +170,9 @@ sub config {
my ($rc, @config) = $self->run_hooks_no_respond("config", $c);
$self->log(LOGDEBUG, "config($c): hook returned ($rc, @config) ");
if ($rc == OK) {
$self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from hooks and returning it");
$self->log(LOGDEBUG,
"setting _config_cache for $c to [@config] from hooks and returning it"
);
$_config_cache->{$c} = \@config;
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
@ -173,14 +180,18 @@ sub config {
# and then get_qmail_config
@config = $self->get_qmail_config($c, $type);
if (@config) {
$self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from get_qmail_config and returning it");
$self->log(LOGDEBUG,
"setting _config_cache for $c to [@config] from get_qmail_config and returning it"
);
$_config_cache->{$c} = \@config;
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
# finally we use the default if there is any:
if (exists($defaults{$c})) {
$self->log(LOGDEBUG, "setting _config_cache for $c to @{[$defaults{$c}]} from defaults and returning it");
$self->log(LOGDEBUG,
"setting _config_cache for $c to @{[$defaults{$c}]} from defaults and returning it"
);
$_config_cache->{$c} = [$defaults{$c}];
return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
}
@ -208,7 +219,7 @@ sub plugin_dirs {
unless (@plugin_dirs) {
my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!;
@plugin_dirs = ( "$path/plugins" );
@plugin_dirs = ("$path/plugins");
}
return @plugin_dirs;
}
@ -229,7 +240,9 @@ sub get_qmail_config {
eval { require CDB_File };
if ($@) {
$self->log(LOGERROR, "No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@");
$self->log(LOGERROR,
"No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@"
);
return +{};
}
@ -238,6 +251,7 @@ sub get_qmail_config {
$self->log(LOGERROR, "tie of $configfile.cdb failed: $!");
return +{};
}
# We explicitly don't cache cdb entries. The assumption is that
# the data is in a CDB file in the first place because there's
# lots of data and the cache hit ratio would be low.
@ -257,16 +271,18 @@ sub _config_from_file {
$visited ||= [];
push @{$visited}, $configfile;
open CF, "<$configfile" or warn "$$ could not open configfile $configfile: $!" and return;
open CF, "<$configfile"
or warn "$$ could not open configfile $configfile: $!" and return;
my @config = <CF>;
chomp @config;
@config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/}
map {s/^\s+//; s/\s+$//; $_;} # trim leading/trailing whitespace
@config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/ }
map { s/^\s+//; s/\s+$//; $_; } # trim leading/trailing whitespace
@config;
close CF;
my $pos = 0;
while ($pos < @config) {
# recursively pursue an $include reference, if found. An inclusion which
# begins with a leading slash is interpreted as a path to a file and will
# supercede the usual config path resolution. Otherwise, the normal
@ -283,20 +299,23 @@ sub _config_from_file {
}
if (grep($_ eq $inclusion, @{$visited})) {
$self->log(LOGERROR, "Circular \$include reference in config $config:");
$self->log(LOGERROR,
"Circular \$include reference in config $config:");
$self->log(LOGERROR, "From $visited->[0]:");
$self->log(LOGERROR, " includes $_")
for (@{$visited}[1..$#{$visited}], $inclusion);
for (@{$visited}[1 .. $#{$visited}], $inclusion);
return wantarray ? () : undef;
}
push @{$visited}, $inclusion;
for my $inc ($self->expand_inclusion_($inclusion, $configfile)) {
my @insertion = $self->_config_from_file($inc, $config, $visited);
my @insertion =
$self->_config_from_file($inc, $config, $visited);
splice @config, $pos, 0, @insertion; # insert the inclusion
$pos += @insertion;
}
} else {
}
else {
$pos++;
}
}
@ -319,18 +338,21 @@ sub expand_inclusion_ {
@includes = map { "$inclusion/$_" }
(grep { -f "$inclusion/$_" and !/^\./ } sort readdir INCD);
closedir INCD;
} else {
$self->log(LOGERROR, "Couldn't open directory $inclusion,".
" referenced from $context ($!)");
}
} else {
else {
$self->log(LOGERROR,
"Couldn't open directory $inclusion,"
. " referenced from $context ($!)"
);
}
}
else {
$self->log(LOGDEBUG, "inclusion of file $inclusion from $context");
@includes = ( $inclusion );
@includes = ($inclusion);
}
return @includes;
}
sub load_plugins {
my $self = shift;
@ -338,6 +360,7 @@ sub load_plugins {
my @loaded;
if ($hooks->{queue}) {
#$self->log(LOGWARN, "Plugins already loaded");
return @plugins;
}
@ -359,11 +382,12 @@ sub _load_plugin {
my $package;
if ($plugin =~ m/::/) {
# "full" package plugin (My::Plugin)
$package = $plugin;
$package =~ s/[^_a-z0-9:]+//gi;
my $eval = qq[require $package;\n]
.qq[sub ${plugin}::plugin_name { '$plugin' }];
. qq[sub ${plugin}::plugin_name { '$plugin' }];
$eval =~ m/(.*)/s;
$eval = $1;
eval $eval;
@ -390,18 +414,19 @@ sub _load_plugin {
$package = "Qpsmtpd::Plugin::$plugin_name";
# don't reload plugins if they are already loaded
unless ( defined &{"${package}::plugin_name"} ) {
unless (defined &{"${package}::plugin_name"}) {
PLUGIN_DIR: for my $dir (@plugin_dirs) {
if (-e "$dir/$plugin") {
Qpsmtpd::Plugin->compile($plugin_name, $package,
"$dir/$plugin", $self->{_test_mode}, $plugin);
$self->log(LOGDEBUG, "Loading $plugin_line from $dir/$plugin")
$self->log(LOGDEBUG,
"Loading $plugin_line from $dir/$plugin")
unless $plugin_line =~ /logging/;
last PLUGIN_DIR;
}
}
die "Plugin $plugin_name not found in our plugin dirs (",
join(", ", @plugin_dirs),")"
join(", ", @plugin_dirs), ")"
unless defined &{"${package}::plugin_name"};
}
}
@ -431,7 +456,9 @@ sub run_hooks_no_respond {
my @r;
for my $code (@{$hooks->{$hook}}) {
eval { (@r) = $code->{code}->($self, $self->transaction, @_); };
$@ and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next;
$@
and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@)
and next;
if ($r[0] == YIELD) {
die "YIELD not valid from $hook hook";
}
@ -443,11 +470,12 @@ sub run_hooks_no_respond {
return (0, '');
}
sub continue_read {} # subclassed in -async
sub continue_read { } # subclassed in -async
sub pause_read { die "Continuations only work in qpsmtpd-async" }
sub run_continuation {
my $self = shift;
#my $t1 = $SAMPLER->("run_hooks", undef, 1);
die "No continuation in progress" unless $self->{_continuation};
$self->continue_read();
@ -456,29 +484,38 @@ sub run_continuation {
my $hook = shift @$todo || die "No hook in the continuation";
my $args = shift @$todo || die "No hook args in the continuation";
my @r;
while (@$todo) {
my $code = shift @$todo;
#my $t2 = $SAMPLER->($hook . "_" . $code->{name}, undef, 1);
#warn("Got sampler called: ${hook}_$code->{name}\n");
$self->varlog(LOGDEBUG, $hook, $code->{name});
my $tran = $self->transaction;
eval { (@r) = $code->{code}->($self, $tran, @$args); };
$@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next;
$@
and
$self->log(LOGCRIT, "FATAL PLUGIN ERROR [" . $code->{name} . "]: ",
$@)
and next;
!defined $r[0]
and $self->log(LOGERROR, "plugin ".$code->{name}
." running the $hook hook returned undef!")
and $self->log(LOGERROR,
"plugin "
. $code->{name}
. " running the $hook hook returned undef!"
)
and next;
# note this is wrong as $tran is always true in the
# current code...
if ($tran) {
my $tnotes = $tran->notes( $code->{name} );
my $tnotes = $tran->notes($code->{name});
$tnotes->{"hook_$hook"}->{'return'} = $r[0]
if (!defined $tnotes || ref $tnotes eq "HASH");
}
else {
my $cnotes = $self->connection->notes( $code->{name} );
my $cnotes = $self->connection->notes($code->{name});
$cnotes->{"hook_$hook"}->{'return'} = $r[0]
if (!defined $cnotes || ref $cnotes eq "HASH");
}
@ -488,24 +525,39 @@ sub run_continuation {
$self->{_continuation} = [$hook, $args, @$todo];
return @r;
}
elsif ($r[0] == DENY or $r[0] == DENYSOFT or
$r[0] == DENY_DISCONNECT or $r[0] == DENYSOFT_DISCONNECT)
elsif ( $r[0] == DENY
or $r[0] == DENYSOFT
or $r[0] == DENY_DISCONNECT
or $r[0] == DENYSOFT_DISCONNECT)
{
$r[1] = "" if not defined $r[1];
$self->log(LOGDEBUG, "Plugin ".$code->{name}.
", hook $hook returned ".return_code($r[0]).", $r[1]");
$self->run_hooks_no_respond("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny");
$self->log(LOGDEBUG,
"Plugin "
. $code->{name}
. ", hook $hook returned "
. return_code($r[0])
. ", $r[1]"
);
$self->run_hooks_no_respond("deny", $code->{name}, $r[0], $r[1])
unless ($hook eq "deny");
}
else {
$r[1] = "" if not defined $r[1];
$self->log(LOGDEBUG, "Plugin ".$code->{name}.
", hook $hook returned ".return_code($r[0]).", $r[1]");
$self->run_hooks_no_respond("ok", $code->{name}, $r[0], $r[1]) unless ($hook eq "ok");
$self->log(LOGDEBUG,
"Plugin "
. $code->{name}
. ", hook $hook returned "
. return_code($r[0])
. ", $r[1]"
);
$self->run_hooks_no_respond("ok", $code->{name}, $r[0], $r[1])
unless ($hook eq "ok");
}
last unless $r[0] == DECLINED;
}
$r[0] = DECLINED if not defined $r[0];
# hook_*_parse() may return a CODE ref..
# ... which breaks when splitting as string:
@r = map { split /\n/ } @r unless (ref($r[1]) eq "CODE");
@ -540,7 +592,7 @@ sub _register_hook {
sub spool_dir {
my $self = shift;
unless ( $Spool_dir ) { # first time through
unless ($Spool_dir) { # first time through
$self->log(LOGDEBUG, "Initializing spool_dir");
$Spool_dir = $self->config('spool_dir')
|| Qpsmtpd::Utils::tildeexp('~/tmp/');
@ -551,10 +603,11 @@ sub spool_dir {
$Spool_dir = $1; # cleanse the taint
my $Spool_perms = $self->config('spool_perms') || '0700';
if (! -d $Spool_dir) { # create it if it doesn't exist
mkdir($Spool_dir,oct($Spool_perms))
if (!-d $Spool_dir) { # create it if it doesn't exist
mkdir($Spool_dir, oct($Spool_perms))
or die "Could not create spool_dir $Spool_dir: $!";
};
}
# Make sure the spool dir has appropriate rights
$self->log(LOGWARN,
"Permissions on spool_dir $Spool_dir are not $Spool_perms")
@ -570,8 +623,8 @@ my $transaction_counter = 0;
sub temp_file {
my $self = shift;
my $filename = $self->spool_dir()
. join(":", time, $$, $transaction_counter++);
my $filename =
$self->spool_dir() . join(":", time, $$, $transaction_counter++);
return $filename;
}
@ -579,14 +632,15 @@ sub temp_dir {
my $self = shift;
my $mask = shift || 0700;
my $dirname = $self->temp_file();
-d $dirname or mkdir($dirname, $mask)
-d $dirname
or mkdir($dirname, $mask)
or die "Could not create temporary directory $dirname: $!";
return $dirname;
}
sub size_threshold {
my $self = shift;
unless ( defined $Size_threshold ) {
unless (defined $Size_threshold) {
$Size_threshold = $self->config('size_threshold') || 0;
$self->log(LOGDEBUG, "size_threshold set to $Size_threshold");
}
@ -595,17 +649,17 @@ sub size_threshold {
sub authenticated {
my $self = shift;
return (defined $self->{_auth} ? $self->{_auth} : "" );
return (defined $self->{_auth} ? $self->{_auth} : "");
}
sub auth_user {
my $self = shift;
return (defined $self->{_auth_user} ? $self->{_auth_user} : "" );
return (defined $self->{_auth_user} ? $self->{_auth_user} : "");
}
sub auth_mechanism {
my $self = shift;
return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" );
return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "");
}
1;

38
lib/Qpsmtpd/Address.pm
View File

@ -27,7 +27,7 @@ for easy testing of values.
use overload (
'""' => \&format,
'cmp' => \&_addr_cmp,
);
);
=head2 new()
@ -59,11 +59,11 @@ test for equality (like in badmailfrom).
sub new {
my ($class, $user, $host) = @_;
my $self = {};
if ($user =~ /^<(.*)>$/ ) {
if ($user =~ /^<(.*)>$/) {
($user, $host) = $class->canonify($user);
return undef unless defined $user;
}
elsif ( not defined $host ) {
elsif (not defined $host) {
my $address = $user;
($user, $host) = $address =~ m/(.*)(?:\@(.*))/;
}
@ -196,8 +196,11 @@ sub canonify {
return undef unless ($path =~ /^<(.*)>$/);
$path = $1;
my $domain = $domain_expr ? $domain_expr
my $domain =
$domain_expr
? $domain_expr
: "$subdomain_expr(?:\.$subdomain_expr)*";
# it is possible for $address_literal_expr to be empty, if a site
# doesn't want to allow them
$domain = "(?:$address_literal_expr|$domain)"
@ -216,6 +219,7 @@ sub canonify {
return (undef) unless defined $localpart;
if ($localpart =~ /^$atom_expr(\.$atom_expr)*/) {
# simple case, we are done
return ($localpart, $domainpart);
}
@ -252,14 +256,14 @@ L<format>.
sub address {
my ($self, $val) = @_;
if ( defined($val) ) {
if (defined($val)) {
$val = "<$val>" unless $val =~ /^<.+>$/;
my ($user, $host) = $self->canonify($val);
$self->{_user} = $user;
$self->{_host} = $host;
}
return ( defined $self->{_user} ? $self->{_user} : '' )
. ( defined $self->{_host} ? '@'.$self->{_host} : '' );
return (defined $self->{_user} ? $self->{_user} : '')
. (defined $self->{_host} ? '@' . $self->{_host} : '');
}
=head2 format()
@ -278,11 +282,12 @@ sub format {
my ($self) = @_;
my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]';
return '<>' unless defined $self->{_user};
if ( ( my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) {
return qq(<"$user")
. ( defined $self->{_host} ? '@'.$self->{_host} : '' ). ">";
if ((my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) {
return
qq(<"$user")
. (defined $self->{_host} ? '@' . $self->{_host} : '') . ">";
}
return "<".$self->address().">";
return "<" . $self->address() . ">";
}
=head2 user([$user])
@ -326,7 +331,8 @@ use this to pass data between plugins.
=cut
sub notes {
my ($self,$key) = (shift,shift);
my ($self, $key) = (shift, shift);
# Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;
@ -337,15 +343,15 @@ sub _addr_cmp {
my ($left, $right, $swap) = @_;
my $class = ref($left);
unless ( UNIVERSAL::isa($right, $class) ) {
unless (UNIVERSAL::isa($right, $class)) {
$right = $class->new($right);
}
#invert the address so we can sort by domain then user
($left = join( '=', reverse( split(/@/, $left->format))) ) =~ tr/[<>]//d;
($right = join( '=', reverse( split(/@/,$right->format))) ) =~ tr/[<>]//d;
($left = join('=', reverse(split(/@/, $left->format)))) =~ tr/[<>]//d;
($right = join('=', reverse(split(/@/, $right->format)))) =~ tr/[<>]//d;
if ( $swap ) {
if ($swap) {
($right, $left) = ($left, $right);
}

180
lib/Qpsmtpd/Auth.pm
View File

@ -1,4 +1,5 @@
package Qpsmtpd::Auth;
# See the documentation in 'perldoc docs/authentication.pod'
use strict;
@ -13,55 +14,58 @@ sub e64 {
my ($arg) = @_;
my $res = encode_base64($arg);
chomp($res);
return($res);
return ($res);
}
sub SASL {
# $DB::single = 1;
my ( $session, $mechanism, $prekey ) = @_;
my ( $user, $passClear, $passHash, $ticket, $loginas );
my ($session, $mechanism, $prekey) = @_;
my ($user, $passClear, $passHash, $ticket, $loginas);
if ( $mechanism eq 'plain' ) {
($loginas, $user, $passClear) = get_auth_details_plain($session,$prekey);
return DECLINED if ! $user || ! $passClear;
if ($mechanism eq 'plain') {
($loginas, $user, $passClear) =
get_auth_details_plain($session, $prekey);
return DECLINED if !$user || !$passClear;
}
elsif ( $mechanism eq 'login' ) {
($user, $passClear) = get_auth_details_login($session,$prekey);
return DECLINED if ! $user || ! $passClear;
elsif ($mechanism eq 'login') {
($user, $passClear) = get_auth_details_login($session, $prekey);
return DECLINED if !$user || !$passClear;
}
elsif ( $mechanism eq 'cram-md5' ) {
( $ticket, $user, $passHash ) = get_auth_details_cram_md5($session);
return DECLINED if ! $user || ! $passHash;
elsif ($mechanism eq 'cram-md5') {
($ticket, $user, $passHash) = get_auth_details_cram_md5($session);
return DECLINED if !$user || !$passHash;
}
else {
#this error is now caught in SMTP.pm's sub auth
$session->respond( 500, "Internal server error" );
$session->respond(500, "Internal server error");
return DECLINED;
}
# try running the specific hooks first
my ( $rc, $msg ) =
$session->run_hooks( "auth-$mechanism", $mechanism, $user, $passClear,
$passHash, $ticket );
my ($rc, $msg) =
$session->run_hooks("auth-$mechanism", $mechanism, $user, $passClear,
$passHash, $ticket);
# try running the polymorphous hooks next
if ( !$rc || $rc == DECLINED ) {
( $rc, $msg ) =
$session->run_hooks( "auth", $mechanism, $user, $passClear,
$passHash, $ticket );
if (!$rc || $rc == DECLINED) {
($rc, $msg) =
$session->run_hooks("auth", $mechanism, $user,
$passClear, $passHash, $ticket);
}
if ( $rc == OK ) {
$msg = uc($mechanism) . " authentication successful for $user" .
( $msg ? " - $msg" : '');
$session->respond( 235, $msg );
if ($rc == OK) {
$msg =
uc($mechanism)
. " authentication successful for $user"
. ($msg ? " - $msg" : '');
$session->respond(235, $msg);
$session->connection->relay_client(1);
if ( $session->connection->notes('naughty' ) ) {
$session->log( LOGINFO, "auth success cleared naughty" );
$session->connection->notes('naughty',0);
};
$session->log( LOGDEBUG, $msg ); # already logged by $session->respond
if ($session->connection->notes('naughty')) {
$session->log(LOGINFO, "auth success cleared naughty");
$session->connection->notes('naughty', 0);
}
$session->log(LOGDEBUG, $msg); # already logged by $session->respond
$session->{_auth_user} = $user;
$session->{_auth_mechanism} = $mechanism;
@ -70,104 +74,106 @@ sub SASL {
return OK;
}
else {
$msg = uc($mechanism) . " authentication failed for $user" .
( $msg ? " - $msg" : '');
$session->respond( 535, $msg );
$session->log( LOGDEBUG, $msg ); # already logged by $session->respond
$msg =
uc($mechanism)
. " authentication failed for $user"
. ($msg ? " - $msg" : '');
$session->respond(535, $msg);
$session->log(LOGDEBUG, $msg); # already logged by $session->respond
return DENY;
}
}
sub get_auth_details_plain {
my ( $session, $prekey ) = @_;
my ($session, $prekey) = @_;
if ( ! $prekey) {
$session->respond( 334, ' ' );
$prekey= <STDIN>;
if (!$prekey) {
$session->respond(334, ' ');
$prekey = <STDIN>;
}
my ( $loginas, $user, $passClear ) = split /\x0/, decode_base64($prekey);
my ($loginas, $user, $passClear) = split /\x0/, decode_base64($prekey);
if ( ! $user ) {
if ( $loginas ) {
if (!$user) {
if ($loginas) {
$session->respond(535, "Authentication invalid ($loginas)");
}
else {
$session->respond(535, "Authentication invalid");
}
return;
};
}
# Authorization ID must not be different from Authentication ID
if ( $loginas ne '' && $loginas ne $user ) {
if ($loginas ne '' && $loginas ne $user) {
$session->respond(535, "Authentication invalid for $user");
return;
}
return ($loginas, $user, $passClear);
};
}
sub get_auth_details_login {
my ( $session, $prekey ) = @_;
my ($session, $prekey) = @_;
my $user;
if ( $prekey ) {
if ($prekey) {
$user = decode_base64($prekey);
}
else {
$user = get_base64_response($session,'Username:') or return;
$user = get_base64_response($session, 'Username:') or return;
}
my $passClear = get_base64_response($session,'Password:') or return;
my $passClear = get_base64_response($session, 'Password:') or return;
return ($user, $passClear);
};
}
sub get_auth_details_cram_md5 {
my ( $session, $ticket ) = @_;
my ($session, $ticket) = @_;
if ( ! $ticket ) { # ticket is only passed in during testing
if (!$ticket) { # ticket is only passed in during testing
# rand() is not cryptographic, but we only need to generate a globally
# unique number. The rand() is there in case the user logs in more than
# once in the same second, or if the clock is skewed.
$ticket = sprintf( '<%x.%x@%s>',
rand(1000000), time(), $session->config('me') );
};
$ticket =
sprintf('<%x.%x@%s>', rand(1000000), time(), $session->config('me'));
}
# send the base64 encoded ticket
$session->respond( 334, encode_base64( $ticket, '' ) );
$session->respond(334, encode_base64($ticket, ''));
my $line = <STDIN>;
if ( $line eq '*' ) {
$session->respond( 501, "Authentication canceled" );
if ($line eq '*') {
$session->respond(501, "Authentication canceled");
return;
};
}
my ( $user, $passHash ) = split( / /, decode_base64($line) );
unless ( $user && $passHash ) {
my ($user, $passHash) = split(/ /, decode_base64($line));
unless ($user && $passHash) {
$session->respond(504, "Invalid authentication string");
return;
}
$session->{auth}{ticket} = $ticket;
return ($ticket, $user, $passHash);
};
}
sub get_base64_response {
my ($session, $question) = @_;
$session->respond(334, e64($question));
my $answer = decode_base64( <STDIN> );
my $answer = decode_base64(<STDIN>);
if ($answer eq '*') {
$session->respond(501, "Authentication canceled");
return;
}
return $answer;
};
}
sub validate_password {
my ( $self, %a ) = @_;
my ($self, %a) = @_;
my ($pkg, $file, $line) = caller();
$file = (split /\//, $file)[-1]; # strip off the path
@ -180,43 +186,43 @@ sub validate_password {
my $ticket = $a{ticket} || $self->{auth}{ticket};
my $deny = $a{deny} || DENY;
if ( ! $src_crypt && ! $src_clear ) {
if (!$src_crypt && !$src_clear) {
$self->log(LOGINFO, "fail: missing password");
return ( $deny, "$file - no such user" );
};
return ($deny, "$file - no such user");
}
if ( ! $src_clear && $method =~ /CRAM-MD5/i ) {
if (!$src_clear && $method =~ /CRAM-MD5/i) {
$self->log(LOGINFO, "skip: cram-md5 not supported w/o clear pass");
return ( DECLINED, $file );
return (DECLINED, $file);
}
if ( defined $attempt_clear ) {
if ( $src_clear && $src_clear eq $attempt_clear ) {
if (defined $attempt_clear) {
if ($src_clear && $src_clear eq $attempt_clear) {
$self->log(LOGINFO, "pass: clear match");
return ( OK, $file );
};
if ( $src_crypt && $src_crypt eq crypt( $attempt_clear, $src_crypt ) ) {
$self->log(LOGINFO, "pass: crypt match");
return ( OK, $file );
return (OK, $file);
}
};
if ( defined $attempt_hash && $src_clear ) {
if ( ! $ticket ) {
if ($src_crypt && $src_crypt eq crypt($attempt_clear, $src_crypt)) {
$self->log(LOGINFO, "pass: crypt match");
return (OK, $file);
}
}
if (defined $attempt_hash && $src_clear) {
if (!$ticket) {
$self->log(LOGERROR, "skip: missing ticket");
return ( DECLINED, $file );
};
return (DECLINED, $file);
}
if ( $attempt_hash eq hmac_md5_hex( $ticket, $src_clear ) ) {
if ($attempt_hash eq hmac_md5_hex($ticket, $src_clear)) {
$self->log(LOGINFO, "pass: hash match");
return ( OK, $file );
};
};
return (OK, $file);
}
}
$self->log(LOGINFO, "fail: wrong password");
return ( $deny, "$file - wrong password" );
};
return ($deny, "$file - wrong password");
}
# tag: qpsmtpd plugin that sets RELAYCLIENT when the user authenticates

14
lib/Qpsmtpd/Command.pm
View File

@ -60,7 +60,7 @@ use vars qw(@ISA);
@ISA = qw(Qpsmtpd::SMTP);
sub parse {
my ($me,$cmd,$line,$sub) = @_;
my ($me, $cmd, $line, $sub) = @_;
return (OK) unless defined $line; # trivial case
my $self = {};
bless $self, $me;
@ -80,25 +80,26 @@ sub parse {
}
my $parse = "parse_$cmd";
if ($self->can($parse)) {
# print "CMD=$cmd,line=$line\n";
my @out = eval { $self->$parse($cmd, $line); };
if ($@) {
$self->log(LOGERROR, "$parse($cmd,$line) failed: $@");
return(DENY, "Failed to parse line");
return (DENY, "Failed to parse line");
}
return @out;
}
return(OK, split(/ +/, $line)); # default :)
return (OK, split(/ +/, $line)); # default :)
}
sub parse_rcpt {
my ($self,$cmd,$line) = @_;
my ($self, $cmd, $line) = @_;
return (DENY, "Syntax error in command") unless $line =~ s/^to:\s*//i;
return &_get_mail_params($cmd, $line);
}
sub parse_mail {
my ($self,$cmd,$line) = @_;
my ($self, $cmd, $line) = @_;
return (DENY, "Syntax error in command") unless $line =~ s/^from:\s*//i;
return &_get_mail_params($cmd, $line);
}
@ -121,7 +122,7 @@ sub parse_mail {
## inner-esmtp-cmd ::= ("MAIL FROM:" reverse-path) /
## ("RCPT TO:" forward-path)
sub _get_mail_params {
my ($cmd,$line) = @_;
my ($cmd, $line) = @_;
my @params = ();
$line =~ s/\s*$//;
@ -137,6 +138,7 @@ sub _get_mail_params {
# let's see if $line contains nothing and use the first value as address:
if ($line) {
# parameter syntax error, i.e. not all of the arguments were
# stripped by the while() loop:
return (DENY, "Syntax error in parameters")

84
lib/Qpsmtpd/ConfigServer.pm
View File

@ -14,7 +14,7 @@ use fields qw(
_test_mode
_extras
other_fds
);
);
my $PROMPT = "Enter command: ";
@ -22,7 +22,7 @@ sub new {
my Qpsmtpd::ConfigServer $self = shift;
$self = fields::new($self) unless ref $self;
$self->SUPER::new( @_ );
$self->SUPER::new(@_);
$self->write($PROMPT);
return $self;
}
@ -32,7 +32,7 @@ sub max_idle_time { 3600 } # one hour
sub process_line {
my $self = shift;
my $line = shift || return;
if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; }
if ($::DEBUG > 1) { print "$$:" . ($self + 0) . "C($self->{mode}): $line"; }
local $SIG{ALRM} = sub {
my ($pkg, $file, $line) = caller();
die "ALARM: $pkg, $file, $line";
@ -71,9 +71,7 @@ sub _process_line {
my ($cmd, @params) = split(/ +/, $line);
my $meth = "cmd_" . lc($cmd);
if (my $lookup = $self->can($meth)) {
my $resp = eval {
$lookup->($self, @params);
};
my $resp = eval { $lookup->($self, @params); };
if ($@) {
my $error = $@;
chomp($error);
@ -91,13 +89,15 @@ sub _process_line {
my %helptext = (
help => "HELP [CMD] - Get help on all commands or a specific command",
status => "STATUS - Returns status information about current connections",
list => "LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list",
kill => "KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF",
list =>
"LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list",
kill =>
"KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF",
pause => "PAUSE - Stop accepting new connections",
continue => "CONTINUE - Resume accepting connections",
reload => "RELOAD - Reload all plugins and config",
quit => "QUIT - Exit the config server",
);
);
sub cmd_help {
my $self = shift;
@ -107,10 +107,13 @@ sub cmd_help {
$subcmd = lc($subcmd);
if ($subcmd eq 'help') {
my $txt = join("\n", map { substr($_, 0, index($_, "-")) } sort values(%helptext));
my $txt = join("\n",
map { substr($_, 0, index($_, "-")) }
sort values(%helptext));
return "Available Commands:\n\n$txt\n";
}
my $txt = $helptext{$subcmd} || "Unrecognised help option. Try 'help' for a full list.";
my $txt = $helptext{$subcmd}
|| "Unrecognised help option. Try 'help' for a full list.";
return "$txt\n";
}
@ -128,7 +131,7 @@ sub cmd_pause {
my $other_fds = $self->OtherFds;
$self->{other_fds} = { %$other_fds };
$self->{other_fds} = {%$other_fds};
%$other_fds = ();
return "PAUSED";
}
@ -138,7 +141,7 @@ sub cmd_continue {
my $other_fds = $self->{other_fds};
$self->OtherFds( %$other_fds );
$self->OtherFds(%$other_fds);
%$other_fds = ();
return "UNPAUSED";
}
@ -146,18 +149,19 @@ sub cmd_continue {
sub cmd_status {
my $self = shift;
# Status should show:
# - Total time running
# - Total number of mails received
# - Total number of mails rejected (5xx)
# - Total number of mails tempfailed (5xx)
# - Avg number of mails/minute
# - Number of current connections
# - Number of outstanding DNS queries
# Status should show:
# - Total time running
# - Total number of mails received
# - Total number of mails rejected (5xx)
# - Total number of mails tempfailed (5xx)
# - Avg number of mails/minute
# - Number of current connections
# - Number of outstanding DNS queries
my $output = "Current Status as of " . gmtime() . " GMT\n\n";
if (defined &Qpsmtpd::Plugin::stats::get_stats) {
# Stats plugin is loaded
$output .= Qpsmtpd::Plugin::stats->get_stats;
}
@ -176,8 +180,8 @@ sub cmd_status {
}
}
$output .= "Curr Connections: $current_connections / $::MAXconn\n".
"Curr DNS Queries: $current_dns";
$output .= "Curr Connections: $current_connections / $::MAXconn\n"
. "Curr DNS Queries: $current_dns";
return $output;
}
@ -188,28 +192,35 @@ sub cmd_list {
my $descriptors = Danga::Socket->DescriptorMap;
my $list = "Current" . ($count ? (($count > 0) ? " Oldest $count" : " Newest ".-$count) : "") . " Connections: \n\n";
my $list =
"Current"
. ($count ? (($count > 0) ? " Oldest $count" : " Newest " . -$count) : "")
. " Connections: \n\n";
my @all;
foreach my $fd (keys %$descriptors) {
my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) {
next unless $pob->connection->remote_ip; # haven't even started yet
push @all, [$pob+0, $pob->connection->remote_ip,
$pob->connection->remote_host, $pob->uptime];
push @all,
[
$pob + 0, $pob->connection->remote_ip,
$pob->connection->remote_host, $pob->uptime
];
}
}
@all = sort { $a->[3] <=> $b->[3] } @all;
if ($count) {
if ($count > 0) {
@all = @all[$#all-($count-1) .. $#all];
@all = @all[$#all - ($count - 1) .. $#all];
}
else {
@all = @all[0..(abs($count) - 1)];
@all = @all[0 .. (abs($count) - 1)];
}
}
foreach my $item (@all) {
$list .= sprintf("%x : %s [%s] Connected %0.2fs\n", map { defined()?$_:'' } @$item);
$list .= sprintf("%x : %s [%s] Connected %0.2fs\n",
map { defined() ? $_ : '' } @$item);
}
return $list;
@ -229,17 +240,20 @@ sub cmd_kill {
my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) {
if ($is_ip) {
next unless $pob->connection->remote_ip; # haven't even started yet
next
unless $pob->connection->remote_ip; # haven't even started yet
if ($pob->connection->remote_ip eq $match) {
$pob->write("550 Your connection has been killed by an administrator\r\n");
$pob->write(
"550 Your connection has been killed by an administrator\r\n");
$pob->disconnect;
$killed++;
}
}
else {
# match by ID
if ($pob+0 == hex($match)) {
$pob->write("550 Your connection has been killed by an administrator\r\n");
if ($pob + 0 == hex($match)) {
$pob->write(
"550 Your connection has been killed by an administrator\r\n");
$pob->disconnect;
$killed++;
}
@ -256,13 +270,13 @@ sub cmd_dump {
return "SYNTAX: DUMP \$REF\n" unless $ref;
require Data::Dumper;
$Data::Dumper::Indent=1;
$Data::Dumper::Indent = 1;
my $descriptors = Danga::Socket->DescriptorMap;
foreach my $fd (keys %$descriptors) {
my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) {
if ($pob+0 == hex($ref)) {
if ($pob + 0 == hex($ref)) {
return Data::Dumper::Dumper($pob);
}
}

15
lib/Qpsmtpd/Connection.pm
View File

@ -13,14 +13,13 @@ my @parameters = qw(
local_ip
local_port
relay_client
);
);
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
bless ($self, $class);
bless($self, $class);
}
sub start {
@ -29,7 +28,7 @@ sub start {
my %args = @_;
foreach my $f ( @parameters ) {
foreach my $f (@parameters) {
$self->$f($args{$f}) if $args{$f};
}
@ -40,14 +39,16 @@ sub clone {
my $self = shift;
my %args = @_;
my $new = $self->new();
foreach my $f ( @parameters ) {
foreach my $f (@parameters) {
$new->$f($self->$f()) if $self->$f();
}
$new->{_notes} = $self->{_notes} if defined $self->{_notes};
# reset the old connection object like it's done at the end of a connection
# to prevent leaks (like prefork/tls problem with the old SSL file handle
# still around)
$self->reset unless $args{no_reset};
# should we generate a new id here?
return $new;
}
@ -82,7 +83,6 @@ sub local_port {
$self->{_local_port};
}
sub remote_info {
my $self = shift;
@_ and $self->{_remote_info} = shift;
@ -108,7 +108,8 @@ sub hello_host {
}
sub notes {
my ($self,$key) = (shift,shift);
my ($self, $key) = (shift, shift);
# Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;

20
lib/Qpsmtpd/Constants.pm
View File

@ -13,7 +13,7 @@ my %log_levels = (
LOGALERT => 1,
LOGEMERG => 0,
LOGRADAR => 0,
);
);
# return codes
my %return_codes = (
@ -27,24 +27,24 @@ my %return_codes = (
DONE => 910,
CONTINUATION => 911, # deprecated - use YIELD
YIELD => 911,
);
);
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = (keys(%return_codes), keys(%log_levels), "return_code", "log_level");
foreach (keys %return_codes ) {
eval "use constant $_ => ".$return_codes{$_};
foreach (keys %return_codes) {
eval "use constant $_ => " . $return_codes{$_};
}
foreach (keys %log_levels ) {
eval "use constant $_ => ".$log_levels{$_};
foreach (keys %log_levels) {
eval "use constant $_ => " . $log_levels{$_};
}
sub return_code {
my $test = shift;
if ( $test =~ /^\d+$/ ) { # need to return the textural form
foreach ( keys %return_codes ) {
if ($test =~ /^\d+$/) { # need to return the textural form
foreach (keys %return_codes) {
return $_ if $return_codes{$_} =~ /$test/;
}
}
@ -55,8 +55,8 @@ sub return_code {
sub log_level {
my $test = shift;
if ( $test =~ /^\d+$/ ) { # need to return the textural form
foreach ( keys %log_levels ) {
if ($test =~ /^\d+$/) { # need to return the textural form
foreach (keys %log_levels) {
return $_ if $log_levels{$_} =~ /$test/;
}
}

110
lib/Qpsmtpd/DSN.pm
View File

@ -133,7 +133,7 @@ sub _status {
}
sub _dsn {
my ($self,$return,$reason,$default,$subject,$detail) = @_;
my ($self, $return, $reason, $default, $subject, $detail) = @_;
if (!defined $return) {
$return = $default;
}
@ -157,7 +157,7 @@ sub _dsn {
return ($return, "$msg (#$class.$subject.$detail)");
}
sub unspecified { shift->_dsn(shift,shift,DENYSOFT,0,0); }
sub unspecified { shift->_dsn(shift, shift, DENYSOFT, 0, 0); }
=head1 ADDRESS STATUS
@ -170,7 +170,7 @@ default: DENYSOFT
=cut
sub addr_unspecified { shift->_dsn(shift,shift,DENYSOFT,1,0); }
sub addr_unspecified { shift->_dsn(shift, shift, DENYSOFT, 1, 0); }
=item no_such_user, addr_bad_dest_mbox
@ -179,8 +179,8 @@ default: DENY
=cut
sub no_such_user { shift->_dsn(shift,(shift||"No such user"),DENY,1,1); }
sub addr_bad_dest_mbox { shift->_dsn(shift,shift,DENY,1,1); }
sub no_such_user { shift->_dsn(shift, (shift || "No such user"), DENY, 1, 1); }
sub addr_bad_dest_mbox { shift->_dsn(shift, shift, DENY, 1, 1); }
=item addr_bad_dest_system
@ -189,7 +189,7 @@ default: DENY
=cut
sub addr_bad_dest_system { shift->_dsn(shift,shift,DENY,1,2); }
sub addr_bad_dest_system { shift->_dsn(shift, shift, DENY, 1, 2); }
=item addr_bad_dest_syntax
@ -198,7 +198,7 @@ default: DENY
=cut
sub addr_bad_dest_syntax { shift->_dsn(shift,shift,DENY,1,3); }
sub addr_bad_dest_syntax { shift->_dsn(shift, shift, DENY, 1, 3); }
=item addr_dest_ambigous
@ -207,7 +207,7 @@ default: DENYSOFT
=cut
sub addr_dest_ambigous { shift->_dsn(shift,shift,DENYSOFT,1,4); }
sub addr_dest_ambigous { shift->_dsn(shift, shift, DENYSOFT, 1, 4); }
=item addr_rcpt_ok
@ -217,7 +217,7 @@ default: OK
=cut
# XXX: do we need this? Maybe in all address verifying plugins?
sub addr_rcpt_ok { shift->_dsn(shift,shift,OK,1,5); }
sub addr_rcpt_ok { shift->_dsn(shift, shift, OK, 1, 5); }
=item addr_mbox_moved
@ -226,7 +226,7 @@ default: DENY
=cut
sub addr_mbox_moved { shift->_dsn(shift,shift,DENY,1,6); }
sub addr_mbox_moved { shift->_dsn(shift, shift, DENY, 1, 6); }
=item addr_bad_from_syntax
@ -235,7 +235,7 @@ default: DENY
=cut
sub addr_bad_from_syntax { shift->_dsn(shift,shift,DENY,1,7); }
sub addr_bad_from_syntax { shift->_dsn(shift, shift, DENY, 1, 7); }
=item addr_bad_from_system
@ -246,7 +246,7 @@ default: DENY
=cut
sub addr_bad_from_system { shift->_dsn(shift,shift,DENY,1,8); }
sub addr_bad_from_system { shift->_dsn(shift, shift, DENY, 1, 8); }
=head1 MAILBOX STATUS
@ -259,7 +259,7 @@ default: DENYSOFT
=cut
sub mbox_unspecified { shift->_dsn(shift,shift,DENYSOFT,2,0); }
sub mbox_unspecified { shift->_dsn(shift, shift, DENYSOFT, 2, 0); }
=item mbox_disabled
@ -272,7 +272,7 @@ default: DENY ...but RFC says:
=cut
sub mbox_disabled { shift->_dsn(shift,shift,DENY,2,1); }
sub mbox_disabled { shift->_dsn(shift, shift, DENY, 2, 1); }
=item mbox_full
@ -281,7 +281,7 @@ default: DENYSOFT
=cut
sub mbox_full { shift->_dsn(shift,shift,DENYSOFT,2,2); }
sub mbox_full { shift->_dsn(shift, shift, DENYSOFT, 2, 2); }
=item mbox_msg_too_long
@ -290,7 +290,7 @@ default: DENY
=cut
sub mbox_msg_too_long { shift->_dsn(shift,shift,DENY,2,3); }
sub mbox_msg_too_long { shift->_dsn(shift, shift, DENY, 2, 3); }
=item mbox_list_expansion_problem
@ -301,7 +301,7 @@ default: DENYSOFT
=cut
sub mbox_list_expansion_problem { shift->_dsn(shift,shift,DENYSOFT,2,4); }
sub mbox_list_expansion_problem { shift->_dsn(shift, shift, DENYSOFT, 2, 4); }
=head1 MAIL SYSTEM STATUS
@ -314,7 +314,7 @@ default: DENYSOFT
=cut
sub sys_unspecified { shift->_dsn(shift,shift,DENYSOFT,3,0); }
sub sys_unspecified { shift->_dsn(shift, shift, DENYSOFT, 3, 0); }
=item sys_disk_full
@ -323,7 +323,7 @@ default: DENYSOFT
=cut
sub sys_disk_full { shift->_dsn(shift,shift,DENYSOFT,3,1); }
sub sys_disk_full { shift->_dsn(shift, shift, DENYSOFT, 3, 1); }
=item sys_not_accepting_mail
@ -332,7 +332,7 @@ default: DENYSOFT
=cut
sub sys_not_accepting_mail { shift->_dsn(shift,shift,DENYSOFT,3,2); }
sub sys_not_accepting_mail { shift->_dsn(shift, shift, DENYSOFT, 3, 2); }
=item sys_not_supported
@ -345,7 +345,7 @@ default: DENYSOFT
=cut
sub sys_not_supported { shift->_dsn(shift,shift,DENYSOFT,3,3); }
sub sys_not_supported { shift->_dsn(shift, shift, DENYSOFT, 3, 3); }
=item sys_msg_too_big
@ -356,7 +356,7 @@ default DENY
=cut
sub sys_msg_too_big { shift->_dsn(shift,shift,DENY,3,4); }
sub sys_msg_too_big { shift->_dsn(shift, shift, DENY, 3, 4); }
=head1 NETWORK AND ROUTING STATUS
@ -371,7 +371,7 @@ default: DENYSOFT
=cut
sub net_unspecified { shift->_dsn(shift,shift,DENYSOFT,4,0); }
sub net_unspecified { shift->_dsn(shift, shift, DENYSOFT, 4, 0); }
# not useful # sub net_no_answer { shift->_dsn(shift,shift,4,1); }
# not useful # sub net_bad_connection { shift->_dsn(shift,shift,4,2); }
@ -384,11 +384,10 @@ default: DENYSOFT
=cut
sub temp_resolver_failed {
shift->_dsn(shift,
(shift || "Temporary address resolution failure"),
DENYSOFT,4,3);
shift->_dsn(shift, (shift || "Temporary address resolution failure"),
DENYSOFT, 4, 3);
}
sub net_directory_server_failed { shift->_dsn(shift,shift,DENYSOFT,4,3); }
sub net_directory_server_failed { shift->_dsn(shift, shift, DENYSOFT, 4, 3); }
# not useful # sub net_unable_to_route { shift->_dsn(shift,shift,4,4); }
@ -399,7 +398,7 @@ default: DENYSOFT
=cut
sub net_system_congested { shift->_dsn(shift,shift,DENYSOFT,4,5); }
sub net_system_congested { shift->_dsn(shift, shift, DENYSOFT, 4, 5); }
=item net_routing_loop, too_many_hops
@ -416,8 +415,11 @@ Why do we want to DENYSOFT something like this?
=cut
sub net_routing_loop { shift->_dsn(shift,shift,DENY,4,6); }
sub too_many_hops { shift->_dsn(shift,(shift || "Too many hops"),DENY,4,6,); }
sub net_routing_loop { shift->_dsn(shift, shift, DENY, 4, 6); }
sub too_many_hops {
shift->_dsn(shift, (shift || "Too many hops"), DENY, 4, 6,);
}
# not useful # sub delivery_time_expired { shift->_dsn(shift,shift,4,7); }
=head1 MAIL DELIVERY PROTOCOL STATUS
@ -431,7 +433,7 @@ default: DENYSOFT
=cut
sub proto_unspecified { shift->_dsn(shift,shift,DENYSOFT,5,0); }
sub proto_unspecified { shift->_dsn(shift, shift, DENYSOFT, 5, 0); }
=item proto_invalid_command
@ -440,7 +442,7 @@ default: DENY
=cut
sub proto_invalid_command { shift->_dsn(shift,shift,DENY,5,1); }
sub proto_invalid_command { shift->_dsn(shift, shift, DENY, 5, 1); }
=item proto_syntax_error
@ -449,7 +451,7 @@ default: DENY
=cut
sub proto_syntax_error { shift->_dsn(shift,shift,DENY,5,2); }
sub proto_syntax_error { shift->_dsn(shift, shift, DENY, 5, 2); }
=item proto_rcpt_list_too_long, too_many_rcpts
@ -458,8 +460,8 @@ default: DENYSOFT
=cut
sub proto_rcpt_list_too_long { shift->_dsn(shift,shift,DENYSOFT,5,3); }
sub too_many_rcpts { shift->_dsn(shift,shift,DENYSOFT,5,3); }
sub proto_rcpt_list_too_long { shift->_dsn(shift, shift, DENYSOFT, 5, 3); }
sub too_many_rcpts { shift->_dsn(shift, shift, DENYSOFT, 5, 3); }
=item proto_invalid_cmd_args
@ -468,7 +470,7 @@ default: DENY
=cut
sub proto_invalid_cmd_args { shift->_dsn(shift,shift,DENY,5,4); }
sub proto_invalid_cmd_args { shift->_dsn(shift, shift, DENY, 5, 4); }
=item proto_wrong_version
@ -479,7 +481,7 @@ default: DENYSOFT
=cut
sub proto_wrong_version { shift->_dsn(shift,shift,DENYSOFT,5,5); }
sub proto_wrong_version { shift->_dsn(shift, shift, DENYSOFT, 5, 5); }
=head1 MESSAGE CONTENT OR MESSAGE MEDIA STATUS
@ -492,7 +494,7 @@ default: DENYSOFT
=cut
sub media_unspecified { shift->_dsn(shift,shift,DENYSOFT,6,0); }
sub media_unspecified { shift->_dsn(shift, shift, DENYSOFT, 6, 0); }
=item media_unsupported
@ -501,7 +503,7 @@ default: DENY
=cut
sub media_unsupported { shift->_dsn(shift,shift,DENY,6,1); }
sub media_unsupported { shift->_dsn(shift, shift, DENY, 6, 1); }
=item media_conv_prohibited
@ -510,7 +512,7 @@ default: DENY
=cut
sub media_conv_prohibited { shift->_dsn(shift,shift,DENY,6,2); }
sub media_conv_prohibited { shift->_dsn(shift, shift, DENY, 6, 2); }
=item media_conv_unsupported
@ -519,7 +521,7 @@ default: DENYSOFT
=cut
sub media_conv_unsupported { shift->_dsn(shift,shift,DENYSOFT,6,3); }
sub media_conv_unsupported { shift->_dsn(shift, shift, DENYSOFT, 6, 3); }
=item media_conv_lossy
@ -530,7 +532,7 @@ default: DENYSOFT
=cut
sub media_conv_lossy { shift->_dsn(shift,shift,DENYSOFT,6,4); }
sub media_conv_lossy { shift->_dsn(shift, shift, DENYSOFT, 6, 4); }
=head1 SECURITY OR POLICY STATUS
@ -543,7 +545,7 @@ default: DENYSOFT
=cut
sub sec_unspecified { shift->_dsn(shift,shift,DENYSOFT,7,0); }
sub sec_unspecified { shift->_dsn(shift, shift, DENYSOFT, 7, 0); }
=item sec_sender_unauthorized, bad_sender_ip, relaying_denied
@ -552,12 +554,14 @@ default: DENY
=cut
sub sec_sender_unauthorized { shift->_dsn(shift,shift,DENY,7,1); }
sub sec_sender_unauthorized { shift->_dsn(shift, shift, DENY, 7, 1); }
sub bad_sender_ip {
shift->_dsn(shift,(shift || "Bad sender's IP"),DENY,7,1,);
shift->_dsn(shift, (shift || "Bad sender's IP"), DENY, 7, 1,);
}
sub relaying_denied {
shift->_dsn(shift,(shift || "Relaying denied"),DENY,7,1);
shift->_dsn(shift, (shift || "Relaying denied"), DENY, 7, 1);
}
=item sec_list_dest_prohibited
@ -567,7 +571,7 @@ default: DENY
=cut
sub sec_list_dest_prohibited { shift->_dsn(shift,shift,DENY,7,2); }
sub sec_list_dest_prohibited { shift->_dsn(shift, shift, DENY, 7, 2); }
=item sec_conv_failed
@ -576,7 +580,7 @@ default: DENY
=cut
sub sec_conv_failed { shift->_dsn(shift,shift,DENY,7,3); }
sub sec_conv_failed { shift->_dsn(shift, shift, DENY, 7, 3); }
=item sec_feature_unsupported
@ -585,7 +589,7 @@ default: DENY
=cut
sub sec_feature_unsupported { shift->_dsn(shift,shift,DENY,7,4); }
sub sec_feature_unsupported { shift->_dsn(shift, shift, DENY, 7, 4); }
=item sec_crypto_failure
@ -594,7 +598,7 @@ default: DENY
=cut
sub sec_crypto_failure { shift->_dsn(shift,shift,DENY,7,5); }
sub sec_crypto_failure { shift->_dsn(shift, shift, DENY, 7, 5); }
=item sec_crypto_algorithm_unsupported
@ -603,7 +607,9 @@ default: DENYSOFT
=cut
sub sec_crypto_algorithm_unsupported { shift->_dsn(shift,shift,DENYSOFT,7,6); }
sub sec_crypto_algorithm_unsupported {
shift->_dsn(shift, shift, DENYSOFT, 7, 6);
}
=item sec_msg_integrity_failure
@ -614,7 +620,7 @@ default: DENY
=cut
sub sec_msg_integrity_failure { shift->_dsn(shift,shift,DENY,7,7); }
sub sec_msg_integrity_failure { shift->_dsn(shift, shift, DENY, 7, 7); }
1;

104
lib/Qpsmtpd/Plugin.pm
View File

@ -15,13 +15,13 @@ our @hooks = qw(
data data_headers_end data_post queue_pre queue queue_post vrfy noop
quit reset_transaction disconnect post-connection
unrecognized_command deny ok received_line help
);
);
our %hooks = map { $_ => 1 } @hooks;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
bless ({}, $class);
bless({}, $class);
}
sub hook_name {
@ -38,11 +38,13 @@ sub register_hook {
# I can't quite decide if it's better to parse this code ref or if
# we should pass the plugin object and method name ... hmn.
$plugin->qp->_register_hook
($hook,
{ code => sub { local $plugin->{_qp} = shift;
$plugin->qp->_register_hook(
$hook,
{
code => sub {
local $plugin->{_qp} = shift;
local $plugin->{_hook} = $hook;
$plugin->$method(@_)
$plugin->$method(@_);
},
name => $plugin->plugin_name,
},
@ -66,35 +68,38 @@ sub qp {
sub log {
my $self = shift;
return if defined $self->{_hook} && $self->{_hook} eq 'logging';
my $level = $self->adjust_log_level( shift, $self->plugin_name );
my $level = $self->adjust_log_level(shift, $self->plugin_name);
$self->{_qp}->varlog($level, $self->{_hook}, $self->plugin_name, @_);
}
sub adjust_log_level {
my ( $self, $cur_level, $plugin_name) = @_;
my ($self, $cur_level, $plugin_name) = @_;
my $adj = $self->{_args}{loglevel} or return $cur_level;
return $adj if $adj =~ m/^[01234567]$/; # a raw syslog numeral
if ( $adj !~ /^[\+\-][\d]$/ ) {
$self->log( LOGERROR, $self-"invalid $plugin_name loglevel setting ($adj)" );
if ($adj !~ /^[\+\-][\d]$/) {
$self->log(LOGERROR,
$self - "invalid $plugin_name loglevel setting ($adj)");
undef $self->{_args}{loglevel}; # only complain once per plugin
return $cur_level;
};
}
my $operator = substr($adj, 0, 1);
my $adjust = substr($adj, -1, 1);
my $new_level = $operator eq '+' ? $cur_level + $adjust : $cur_level - $adjust;
my $new_level =
$operator eq '+' ? $cur_level + $adjust : $cur_level - $adjust;
$new_level = 7 if $new_level > 7;
$new_level = 0 if $new_level < 0;
return $new_level;
};
}
sub transaction {
# not sure if this will work in a non-forking or a threaded daemon
shift->qp->transaction;
}
@ -142,7 +147,7 @@ sub isa_plugin {
my $cleanParent = $parent;
$cleanParent =~ s/\W/_/g;
my $newPackage = $currentPackage."::_isa_$cleanParent";
my $newPackage = $currentPackage . "::_isa_$cleanParent";
# don't reload plugins if they are already loaded
return if defined &{"${newPackage}::plugin_name"};
@ -158,8 +163,7 @@ sub isa_plugin {
die "cannot find plugin '$parent'" unless $parent_dir;
$self->compile($self->plugin_name . "_isa_$cleanParent",
$newPackage,
"$parent_dir/$parent");
$newPackage, "$parent_dir/$parent");
warn "---- $newPackage\n";
no strict 'refs';
push @{"${currentPackage}::ISA"}, $newPackage;
@ -219,103 +223,110 @@ sub get_reject {
$log_mess = ", $log_mess" if $log_mess;
my $reject = $self->{_args}{reject};
if ( defined $reject && ! $reject ) {
if (defined $reject && !$reject) {
$self->log(LOGINFO, "fail, reject disabled" . $log_mess);
return DECLINED;
};
}
# the naughty plugin will reject later
if ( $reject eq 'naughty' ) {
if ($reject eq 'naughty') {
$self->log(LOGINFO, "fail, NAUGHTY" . $log_mess);
return $self->store_deferred_reject( $smtp_mess );
};
return $self->store_deferred_reject($smtp_mess);
}
# they asked for reject, we give them reject
$self->log(LOGINFO, "fail" . $log_mess);
return ( $self->get_reject_type(), $smtp_mess);
};
return ($self->get_reject_type(), $smtp_mess);
}
sub get_reject_type {
my $self = shift;
my $default = shift || DENY;
my $deny = shift || $self->{_args}{reject_type} or return $default;
return $deny =~ /^(temp|soft)$/i ? DENYSOFT
return
$deny =~ /^(temp|soft)$/i ? DENYSOFT
: $deny =~ /^(perm|hard)$/i ? DENY
: $deny eq 'disconnect' ? DENY_DISCONNECT
: $deny eq 'temp_disconnect' ? DENYSOFT_DISCONNECT
: $default;
};
}
sub store_deferred_reject {
my ($self, $smtp_mess) = @_;
# store the reject message that the naughty plugin will return later
if ( ! $self->connection->notes('naughty') ) {
if (!$self->connection->notes('naughty')) {
$self->connection->notes('naughty', $smtp_mess);
}
else {
# append this reject message to the message
my $prev = $self->connection->notes('naughty');
$self->connection->notes('naughty', "$prev\015\012$smtp_mess");
};
if ( ! $self->connection->notes('naughty_reject_type') ) {
$self->connection->notes('naughty_reject_type', $self->{_args}{reject_type} );
}
if (!$self->connection->notes('naughty_reject_type')) {
$self->connection->notes('naughty_reject_type',
$self->{_args}{reject_type});
}
return (DECLINED);
};
}
sub init_resolver {
my $self = shift;
return $self->{_resolver} if $self->{_resolver};
$self->log( LOGDEBUG, "initializing Net::DNS::Resolver");
$self->log(LOGDEBUG, "initializing Net::DNS::Resolver");
$self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0);
my $timeout = $self->{_args}{dns_timeout} || 5;
$self->{_resolver}->tcp_timeout($timeout);
$self->{_resolver}->udp_timeout($timeout);
return $self->{_resolver};
};
}
sub is_immune {
my $self = shift;
if ( $self->qp->connection->relay_client() ) {
if ($self->qp->connection->relay_client()) {
# set by plugins/relay, or Qpsmtpd::Auth
$self->log(LOGINFO, "skip, relay client");
return 1;
};
if ( $self->qp->connection->notes('whitelisthost') ) {
}
if ($self->qp->connection->notes('whitelisthost')) {
# set by plugins/dns_whitelist_soft or plugins/whitelist
$self->log(LOGINFO, "skip, whitelisted host");
return 1;
};
if ( $self->qp->transaction->notes('whitelistsender') ) {
}
if ($self->qp->transaction->notes('whitelistsender')) {
# set by plugins/whitelist
$self->log(LOGINFO, "skip, whitelisted sender");
return 1;
};
if ( $self->connection->notes('naughty') ) {
}
if ($self->connection->notes('naughty')) {
# see plugins/naughty
$self->log(LOGINFO, "skip, naughty");
return 1;
};
if ( $self->connection->notes('rejected') ) {
}
if ($self->connection->notes('rejected')) {
# http://www.steve.org.uk/Software/ms-lite/
$self->log(LOGINFO, "skip, already rejected");
return 1;
};
}
return;
};
}
sub adjust_karma {
my ( $self, $value ) = @_;
my ($self, $value) = @_;
my $karma = $self->connection->notes('karma') || 0;
$karma += $value;
$self->log(LOGDEBUG, "karma adjust: $value ($karma)");
$self->connection->notes('karma', $karma);
return $value;
};
}
sub _register_standard_hooks {
my ($plugin, $qp) = @_;
@ -323,10 +334,9 @@ sub _register_standard_hooks {
for my $hook (@hooks) {
my $hooksub = "hook_$hook";
$hooksub =~ s/\W/_/g;
$plugin->register_hook( $hook, $hooksub )
$plugin->register_hook($hook, $hooksub)
if ($plugin->can($hooksub));
}
}
1;

62
lib/Qpsmtpd/PollServer.pm
View File

@ -1,6 +1,7 @@
package Qpsmtpd::PollServer;
use base ('Danga::Client', 'Qpsmtpd::SMTP');
# use fields required to be a subclass of Danga::Client. Have to include
# all fields used by Qpsmtpd.pm here too.
use fields qw(
@ -26,7 +27,7 @@ use fields qw(
_extras
_test_mode
_transaction
);
);
use Qpsmtpd::Constants;
use Qpsmtpd::Address;
use ParaDNS;
@ -49,7 +50,7 @@ sub new {
my Qpsmtpd::PollServer $self = shift;
$self = fields::new($self) unless ref $self;
$self->SUPER::new( @_ );
$self->SUPER::new(@_);
$self->{cmd_timeout} = 5;
$self->{start_time} = time;
$self->{mode} = 'connect';
@ -121,17 +122,18 @@ my %cmd_cache;
sub process_line {
my Qpsmtpd::PollServer $self = shift;
my $line = shift || return;
if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; }
if ($::DEBUG > 1) { print "$$:" . ($self + 0) . "C($self->{mode}): $line"; }
if ($self->{mode} eq 'cmd') {
$line =~ s/\r?\n$//s;
$self->connection->notes('original_string', $line);
my ($cmd, @params) = split(/ +/, $line, 2);
my $meth = lc($cmd);
if (my $lookup = $cmd_cache{$meth} || $self->{_commands}->{$meth} && $self->can($meth)) {
if (my $lookup =
$cmd_cache{$meth}
|| $self->{_commands}->{$meth} && $self->can($meth))
{
$cmd_cache{$meth} = $lookup;
eval {
$lookup->($self, @params);
};
eval { $lookup->($self, @params); };
if ($@) {
my $error = $@;
chomp($error);
@ -141,11 +143,13 @@ sub process_line {
}
else {
# No such method - i.e. unrecognized command
my ($rc, $msg) = $self->run_hooks("unrecognized_command", $meth, @params);
my ($rc, $msg) =
$self->run_hooks("unrecognized_command", $meth, @params);
}
}
elsif ($self->{mode} eq 'connect') {
$self->{mode} = 'cmd';
# I've removed an eval{} from around this. It shouldn't ever die()
# but if it does we're a bit screwed... Ah well :-)
$self->start_conversation;
@ -173,18 +177,20 @@ sub start_conversation {
my Qpsmtpd::PollServer $self = shift;
my $conn = $self->connection;
# set remote_host, remote_ip and remote_port
my ($ip, $port) = split(/:/, $self->peer_addr_string);
return $self->close() unless $ip;
$conn->remote_ip($ip);
$conn->remote_port($port);
$conn->remote_info("[$ip]");
my ($lip,$lport) = split(/:/, $self->local_addr_string);
my ($lip, $lport) = split(/:/, $self->local_addr_string);
$conn->local_ip($lip);
$conn->local_port($lport);
ParaDNS->new(
finished => sub { $self->continue_read(); $self->run_hooks("connect") },
# NB: Setting remote_info to the same as remote_host
callback => sub { $conn->remote_info($conn->remote_host($_[0])) },
host => $ip,
@ -231,14 +237,16 @@ sub data_respond {
return;
}
return $self->respond(503, "MAIL first") unless $self->transaction->sender;
return $self->respond(503, "RCPT first") unless $self->transaction->recipients;
return $self->respond(503, "RCPT first")
unless $self->transaction->recipients;
$self->{header_lines} = '';
$self->{data_size} = 0;
$self->{in_header} = 1;
$self->{max_size} = ($self->config('databytes'))[0] || 0;
$self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}");
$self->log(LOGDEBUG,
"max_size: $self->{max_size} / size: $self->{data_size}");
$self->respond(354, "go ahead");
@ -258,7 +266,7 @@ sub got_data {
$done = 1;
}
# add a transaction->blocked check back here when we have line by line plugin access...
# add a transaction->blocked check back here when we have line by line plugin access...
unless (($self->{max_size} and $self->{data_size} > $self->{max_size})) {
$data =~ s/\r\n/\n/mg;
$data =~ s/^\.\./\./mg;
@ -268,6 +276,7 @@ sub got_data {
if ($self->{header_lines} =~ s/\n(\n.*)\z/\n/ms) {
$data = $1;
# end of headers
$self->{in_header} = 0;
@ -279,13 +288,17 @@ sub got_data {
# way a Received: line that is already in the header.
my @header_lines = split(/^/m, $self->{header_lines});
my $header = Mail::Header->new(\@header_lines,
Modify => 0, MailFrom => "COERCE");
my $header =
Mail::Header->new(
\@header_lines,
Modify => 0,
MailFrom => "COERCE"
);
$self->transaction->header($header);
$self->transaction->body_write($self->{header_lines});
$self->{header_lines} = '';
#$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/");
#$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/");
# FIXME - call plugins to work on just the header here; can
# save us buffering the mail content.
@ -299,7 +312,6 @@ sub got_data {
$self->{data_size} += length $data;
}
if ($done) {
$self->end_of_data;
$self->end_get_chunks($remainder);
@ -312,7 +324,8 @@ sub end_of_data {
#$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300);
$self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}");
$self->log(LOGDEBUG,
"max_size: $self->{max_size} / size: $self->{data_size}");
my $header = $self->transaction->header;
if (!$header) {
@ -321,7 +334,7 @@ sub end_of_data {
}
my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
my $esmtp = substr($smtp,0,1) eq "E";
my $esmtp = substr($smtp, 0, 1) eq "E";
my $authheader;
my $sslheader;
@ -329,17 +342,22 @@ sub end_of_data {
and $self->connection->notes('tls_enabled'))
{
$smtp .= "S" if $esmtp; # RFC3848
$sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) ";
$sslheader = "("
. $self->connection->notes('tls_socket')->get_cipher()
. " encrypted) ";
}
if (defined $self->{_auth} and $self->{_auth} == OK) {
$smtp .= "A" if $esmtp; # RFC3848
$authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
$authheader =
"(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
}
$header->add("Received", $self->received_line($smtp, $authheader, $sslheader), 0);
$header->add("Received",
$self->received_line($smtp, $authheader, $sslheader), 0);
return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size};
return $self->respond(552, "Message too big!")
if $self->{max_size} and $self->{data_size} > $self->{max_size};
my ($rc, $msg) = $self->run_hooks("data_post");
return 1;

29
lib/Qpsmtpd/Postfix.pm
View File

@ -77,7 +77,8 @@ sub print_rec {
sub print_rec_size {
my ($self, $content_size, $data_offset, $rcpt_count) = @_;
my $s = sprintf("%15ld %15ld %15ld", $content_size, $data_offset, $rcpt_count);
my $s =
sprintf("%15ld %15ld %15ld", $content_size, $data_offset, $rcpt_count);
$self->print_rec('REC_TYPE_SIZE', $s);
}
@ -97,21 +98,27 @@ sub open_cleanup {
if ($socket =~ m#^(/.+)#) {
$socket = $1; # un-taint socket path
$self = IO::Socket::UNIX->new(Type => SOCK_STREAM,
Peer => $socket) if $socket;
Peer => $socket)
if $socket;
} elsif ($socket =~ /(.*):(\d+)/) {
my ($host,$port) = ($1,$2); # un-taint address and port
$self = IO::Socket::INET->new(Proto => 'tcp',
PeerAddr => $host,PeerPort => $port)
}
elsif ($socket =~ /(.*):(\d+)/) {
my ($host, $port) = ($1, $2); # un-taint address and port
$self = IO::Socket::INET->new(
Proto => 'tcp',
PeerAddr => $host,
PeerPort => $port
)
if $host and $port;
}
unless (ref $self) {
warn "Couldn't open \"$socket\": $!";
return;
}
# allow buffered writes
$self->autoflush(0);
bless ($self, $class);
bless($self, $class);
$self->init();
return $self;
}
@ -128,7 +135,7 @@ sub get_attr {
my ($self) = @_;
local $/ = "\0";
my %kv;
for(;;) {
for (; ;) {
my $k = $self->getline;
chomp($k);
last unless ($k);
@ -139,7 +146,6 @@ sub get_attr {
return %kv;
}
=head2 print_msg_line($line)
print one line of a message to cleanup.
@ -185,10 +191,11 @@ sub inject_mail {
print STDERR "qid=$qid\n";
$strm->print_attr('flags' => $transaction->notes('postfix-queue-flags'));
$strm->print_rec_time();
$strm->print_rec('REC_TYPE_FROM', $transaction->sender->address|| "");
$strm->print_rec('REC_TYPE_FROM', $transaction->sender->address || "");
for (map { $_->address } $transaction->recipients) {
$strm->print_rec('REC_TYPE_RCPT', $_);
}
# add an empty message length record.
# cleanup is supposed to understand that.
# see src/pickup/pickup.c
@ -204,6 +211,7 @@ sub inject_mail {
}
$transaction->body_resetpos;
while (my $line = $transaction->body_getline) {
# print STDERR "body: $line\n";
$strm->print_msg_line($line);
}
@ -220,4 +228,5 @@ sub inject_mail {
}
1;
# vim:sw=2

53
lib/Qpsmtpd/Postfix/Constants.pm
View File

@ -43,44 +43,51 @@ use strict;
CLEANUP_STAT_DEFER
CLEANUP_STAT_MASK_CANT_BOUNCE
CLEANUP_STAT_MASK_INCOMPLETE
);
);
$postfix_version = "2.4";
use constant CLEANUP_FLAG_NONE => 0; # /* No special features */
use constant CLEANUP_FLAG_BOUNCE => (1<<0); # /* Bounce bad messages */
use constant CLEANUP_FLAG_FILTER => (1<<1); # /* Enable header/body checks */
use constant CLEANUP_FLAG_HOLD => (1<<2); # /* Place message on hold */
use constant CLEANUP_FLAG_DISCARD => (1<<3); # /* Discard message silently */
use constant CLEANUP_FLAG_BCC_OK => (1<<4); # /* Ok to add auto-BCC addresses */
use constant CLEANUP_FLAG_MAP_OK => (1<<5); # /* Ok to map addresses */
use constant CLEANUP_FLAG_MILTER => (1<<6); # /* Enable Milter applications */
use constant CLEANUP_FLAG_FILTER_ALL => (CLEANUP_FLAG_FILTER | CLEANUP_FLAG_MILTER);
use constant CLEANUP_FLAG_MASK_EXTERNAL => (CLEANUP_FLAG_FILTER_ALL | CLEANUP_FLAG_BCC_OK | CLEANUP_FLAG_MAP_OK);
use constant CLEANUP_FLAG_BOUNCE => (1 << 0); # /* Bounce bad messages */
use constant CLEANUP_FLAG_FILTER => (1 << 1); # /* Enable header/body checks */
use constant CLEANUP_FLAG_HOLD => (1 << 2); # /* Place message on hold */
use constant CLEANUP_FLAG_DISCARD => (1 << 3); # /* Discard message silently */
use constant CLEANUP_FLAG_BCC_OK => (1 << 4)
; # /* Ok to add auto-BCC addresses */
use constant CLEANUP_FLAG_MAP_OK => (1 << 5); # /* Ok to map addresses */
use constant CLEANUP_FLAG_MILTER => (1 << 6); # /* Enable Milter applications */
use constant CLEANUP_FLAG_FILTER_ALL =>
(CLEANUP_FLAG_FILTER | CLEANUP_FLAG_MILTER);
use constant CLEANUP_FLAG_MASK_EXTERNAL =>
(CLEANUP_FLAG_FILTER_ALL | CLEANUP_FLAG_BCC_OK | CLEANUP_FLAG_MAP_OK);
use constant CLEANUP_FLAG_MASK_INTERNAL => CLEANUP_FLAG_MAP_OK;
use constant CLEANUP_FLAG_MASK_EXTRA => (CLEANUP_FLAG_HOLD | CLEANUP_FLAG_DISCARD);
use constant CLEANUP_FLAG_MASK_EXTRA =>
(CLEANUP_FLAG_HOLD | CLEANUP_FLAG_DISCARD);
use constant CLEANUP_STAT_OK => 0; # /* Success. */
use constant CLEANUP_STAT_BAD => (1<<0); # /* Internal protocol error */
use constant CLEANUP_STAT_WRITE => (1<<1); # /* Error writing message file */
use constant CLEANUP_STAT_SIZE => (1<<2); # /* Message file too big */
use constant CLEANUP_STAT_CONT => (1<<3); # /* Message content rejected */
use constant CLEANUP_STAT_HOPS => (1<<4); # /* Too many hops */
use constant CLEANUP_STAT_RCPT => (1<<6); # /* No recipients found */
use constant CLEANUP_STAT_PROXY => (1<<7); # /* Proxy reject */
use constant CLEANUP_STAT_DEFER => (1<<8); # /* Temporary reject */
use constant CLEANUP_STAT_MASK_CANT_BOUNCE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_DEFER);
use constant CLEANUP_STAT_MASK_INCOMPLETE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_SIZE | CLEANUP_STAT_DEFER);
use constant CLEANUP_STAT_BAD => (1 << 0); # /* Internal protocol error */
use constant CLEANUP_STAT_WRITE => (1 << 1); # /* Error writing message file */
use constant CLEANUP_STAT_SIZE => (1 << 2); # /* Message file too big */
use constant CLEANUP_STAT_CONT => (1 << 3); # /* Message content rejected */
use constant CLEANUP_STAT_HOPS => (1 << 4); # /* Too many hops */
use constant CLEANUP_STAT_RCPT => (1 << 6); # /* No recipients found */
use constant CLEANUP_STAT_PROXY => (1 << 7); # /* Proxy reject */
use constant CLEANUP_STAT_DEFER => (1 << 8); # /* Temporary reject */
use constant CLEANUP_STAT_MASK_CANT_BOUNCE =>
(CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_DEFER);
use constant CLEANUP_STAT_MASK_INCOMPLETE =>
(CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_SIZE |
CLEANUP_STAT_DEFER);
%cleanup_soft = (
CLEANUP_STAT_DEFER => "service unavailable (#4.7.1)",
CLEANUP_STAT_PROXY => "queue file write error (#4.3.0)",
CLEANUP_STAT_BAD => "internal protocol error (#4.3.0)",
CLEANUP_STAT_WRITE => "queue file write error (#4.3.0)",
);
);
%cleanup_hard = (
CLEANUP_STAT_RCPT => "no recipients specified (#5.1.0)",
CLEANUP_STAT_HOPS => "too many hops (#5.4.0)",
CLEANUP_STAT_SIZE => "message file too big (#5.3.4)",
CLEANUP_STAT_CONT => "message content rejected (#5.7.1)",
);
);
1;

255
lib/Qpsmtpd/SMTP.pm
View File

@ -16,6 +16,7 @@ use Qpsmtpd::Address ();
use Qpsmtpd::Command;
use Mail::Header ();
#use Data::Dumper;
use POSIX qw(strftime);
use Net::DNS;
@ -31,10 +32,12 @@ sub new {
my %args = @_;
my $self = bless ({ args => \%args }, $class);
my $self = bless({args => \%args}, $class);
my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit);
my (%commands); @commands{@commands} = ('') x @commands;
my (%commands);
@commands{@commands} = ('') x @commands;
# this list of valid commands should probably be a method or a set of methods
$self->{_commands} = \%commands;
$self->SUPER::_restart(%args) if $args{restart}; # calls Qpsmtpd::_restart()
@ -49,10 +52,10 @@ sub command_counter {
sub dispatch {
my $self = shift;
my ($cmd) = shift;
if ( ! $cmd ) {
if (!$cmd) {
$self->run_hooks("unrecognized_command", '', @_);
return 1;
};
}
$cmd = lc $cmd;
$self->{_counter}++;
@ -87,13 +90,13 @@ sub fault {
my $self = shift;
my ($msg) = shift || "program fault - command not performed";
my ($name) = split /\s+/, $0, 2;
print STDERR $name,"[$$]: $msg ($!)\n";
print STDERR $name, "[$$]: $msg ($!)\n";
return $self->respond(451, "Internal error - try again later - " . $msg);
}
sub start_conversation {
my $self = shift;
# this should maybe be called something else than "connect", see
# lib/Qpsmtpd/TcpServer.pm for more confusion.
$self->run_hooks("connect");
@ -114,11 +117,12 @@ sub connect_respond {
}
elsif ($rc != DONE) {
my $greets = $self->config('smtpgreeting');
if ( $greets ) {
if ($greets) {
$greets .= " ESMTP" unless $greets =~ /(^|\W)ESMTP(\W|$)/;
}
else {
$greets = $self->config('me')
$greets =
$self->config('me')
. " ESMTP qpsmtpd "
. $self->version
. " ready; send us your mail, but not your spam.";
@ -139,22 +143,24 @@ sub reset_transaction {
return $self->{_transaction} = Qpsmtpd::Transaction->new();
}
sub connection {
my $self = shift;
@_ and $self->{_connection} = shift;
return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new());
return $self->{_connection}
|| ($self->{_connection} = Qpsmtpd::Connection->new());
}
sub helo {
my ($self, $line) = @_;
my ($rc, @msg) = $self->run_hooks('helo_parse');
my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('helo', $line, $msg[0]);
my ($ok, $hello_host, @stuff) =
Qpsmtpd::Command->parse('helo', $line, $msg[0]);
return $self->respond (501,
"helo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host;
return $self->respond(501,
"helo requires domain/address - see RFC-2821 4.1.1.1")
unless $hello_host;
my $conn = $self->connection;
return $self->respond (503, "but you already said HELO ...") if $conn->hello;
return $self->respond(503, "but you already said HELO ...") if $conn->hello;
$self->run_hooks("helo", $hello_host, @stuff);
}
@ -163,35 +169,49 @@ sub helo_respond {
my ($self, $rc, $msg, $args) = @_;
my ($hello_host) = @$args;
if ($rc == DONE) {
# do nothing:
1;
} elsif ($rc == DENY) {
}
elsif ($rc == DENY) {
$self->respond(550, @$msg);
} elsif ($rc == DENYSOFT) {
}
elsif ($rc == DENYSOFT) {
$self->respond(450, @$msg);
} elsif ($rc == DENY_DISCONNECT) {
}
elsif ($rc == DENY_DISCONNECT) {
$self->respond(550, @$msg);
$self->disconnect;
} elsif ($rc == DENYSOFT_DISCONNECT) {
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(450, @$msg);
$self->disconnect;
} else {
}
else {
my $conn = $self->connection;
$conn->hello("helo");
$conn->hello_host($hello_host);
$self->transaction;
$self->respond(250, $self->config('me') ." Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]; I am so happy to meet you.");
$self->respond(
250,
$self->config('me') . " Hi "
. $conn->remote_info . " ["
. $conn->remote_ip
. "]; I am so happy to meet you."
);
}
}
sub ehlo {
my ($self, $line) = @_;
my ($rc, @msg) = $self->run_hooks('ehlo_parse');
my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('ehlo', $line, $msg[0]);
return $self->respond (501,
"ehlo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host;
my ($ok, $hello_host, @stuff) =
Qpsmtpd::Command->parse('ehlo', $line, $msg[0]);
return $self->respond(501,
"ehlo requires domain/address - see RFC-2821 4.1.1.1")
unless $hello_host;
my $conn = $self->connection;
return $self->respond (503, "but you already said HELO ...") if $conn->hello;
return $self->respond(503, "but you already said HELO ...") if $conn->hello;
$self->run_hooks("ehlo", $hello_host, @stuff);
}
@ -200,53 +220,71 @@ sub ehlo_respond {
my ($self, $rc, $msg, $args) = @_;
my ($hello_host) = @$args;
if ($rc == DONE) {
# do nothing:
1;
} elsif ($rc == DENY) {
}
elsif ($rc == DENY) {
$self->respond(550, @$msg);
} elsif ($rc == DENYSOFT) {
}
elsif ($rc == DENYSOFT) {
$self->respond(450, @$msg);
} elsif ($rc == DENY_DISCONNECT) {
}
elsif ($rc == DENY_DISCONNECT) {
$self->respond(550, @$msg);
$self->disconnect;
} elsif ($rc == DENYSOFT_DISCONNECT) {
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(450, @$msg);
$self->disconnect;
} else {
}
else {
my $conn = $self->connection;
$conn->hello("ehlo");
$conn->hello_host($hello_host);
$self->transaction;
my @capabilities = $self->transaction->notes('capabilities')
? @{ $self->transaction->notes('capabilities') }
my @capabilities =
$self->transaction->notes('capabilities')
? @{$self->transaction->notes('capabilities')}
: ();
# Check for possible AUTH mechanisms
HOOK: foreach my $hook ( keys %{$self->hooks} ) {
if ( $hook =~ m/^auth-?(.+)?$/ ) {
if ( defined $1 ) {
HOOK: foreach my $hook (keys %{$self->hooks}) {
if ($hook =~ m/^auth-?(.+)?$/) {
if (defined $1) {
$auth_mechanisms{uc($1)} = 1;
}
else { # at least one polymorphous auth provider
%auth_mechanisms = map {$_,1} qw(PLAIN CRAM-MD5 LOGIN);
%auth_mechanisms = map { $_, 1 } qw(PLAIN CRAM-MD5 LOGIN);
last HOOK;
}
}
}
# Check if we should only offer AUTH after TLS is completed
my $tls_before_auth = ($self->config('tls_before_auth') ? ($self->config('tls_before_auth'))[0] && $self->transaction->notes('tls_enabled') : 0);
if ( %auth_mechanisms && !$tls_before_auth) {
push @capabilities, 'AUTH '.join(" ",keys(%auth_mechanisms));
my $tls_before_auth =
($self->config('tls_before_auth')
? ($self->config('tls_before_auth'))[0]
&& $self->transaction->notes('tls_enabled')
: 0);
if (%auth_mechanisms && !$tls_before_auth) {
push @capabilities, 'AUTH ' . join(" ", keys(%auth_mechanisms));
$self->{_commands}->{'auth'} = "";
}
$self->respond(250,
$self->config("me") . " Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]",
$self->respond(
250,
$self->config("me") . " Hi "
. $conn->remote_info . " ["
. $conn->remote_ip . "]",
"PIPELINING",
"8BITMIME",
($self->config('databytes') ? "SIZE ". ($self->config('databytes'))[0] : ()),
(
$self->config('databytes')
? "SIZE " . ($self->config('databytes'))[0]
: ()
),
@capabilities,
);
}
@ -261,34 +299,36 @@ sub auth_parse_respond {
my ($self, $rc, $msg, $args) = @_;
my ($line) = @$args;
my ($ok, $mechanism, @stuff) = Qpsmtpd::Command->parse('auth', $line, $msg->[0]);
my ($ok, $mechanism, @stuff) =
Qpsmtpd::Command->parse('auth', $line, $msg->[0]);
return $self->respond(501, $mechanism || "Syntax error in command")
unless ($ok == OK);
$mechanism = lc($mechanism);
#they AUTH'd once already
return $self->respond( 503, "but you already said AUTH ..." )
if ( defined $self->{_auth} && $self->{_auth} == OK );
return $self->respond(503, "but you already said AUTH ...")
if (defined $self->{_auth} && $self->{_auth} == OK);
return $self->respond( 503, "AUTH not defined for HELO" )
if ( $self->connection->hello eq "helo" );
return $self->respond(503, "AUTH not defined for HELO")
if ($self->connection->hello eq "helo");
return $self->respond( 503, "SSL/TLS required before AUTH" )
if ( ($self->config('tls_before_auth'))[0]
&& $self->transaction->notes('tls_enabled') );
return $self->respond(503, "SSL/TLS required before AUTH")
if (($self->config('tls_before_auth'))[0]
&& $self->transaction->notes('tls_enabled'));
# we don't have a plugin implementing this auth mechanism, 504
if( exists $auth_mechanisms{uc($mechanism)} ) {
return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $mechanism, @stuff );
};
if (exists $auth_mechanisms{uc($mechanism)}) {
return $self->{_auth} = Qpsmtpd::Auth::SASL($self, $mechanism, @stuff);
}
$self->respond( 504, "Unimplemented authentification mechanism: $mechanism" );
$self->respond(504, "Unimplemented authentification mechanism: $mechanism");
return DENY;
}
sub mail {
my ($self, $line) = @_;
# -> from RFC2821
# The MAIL command (or the obsolete SEND, SOML, or SAML commands)
# begins a mail transaction. Once started, a mail transaction
@ -309,9 +349,9 @@ sub mail {
$self->reset_transaction;
if ( ! $self->connection->hello) {
if (!$self->connection->hello) {
return $self->respond(503, "please say hello first ...");
};
}
$self->log(LOGDEBUG, "full from_parameter: $line");
$self->run_hooks("mail_parse", $line);
@ -320,14 +360,16 @@ sub mail {
sub mail_parse_respond {
my ($self, $rc, $msg, $args) = @_;
my ($line) = @$args;
my ($ok, $from, @params) = Qpsmtpd::Command->parse('mail', $line, $msg->[0]);
my ($ok, $from, @params) =
Qpsmtpd::Command->parse('mail', $line, $msg->[0]);
return $self->respond(501, $from || "Syntax error in command")
unless ($ok == OK);
my %param;
foreach (@params) {
my ($k,$v) = split /=/, $_, 2;
my ($k, $v) = split /=/, $_, 2;
$param{lc $k} = $v;
}
# to support addresses without <> we now require a plugin
# hooking "mail_pre" to
# return (OK, "<$from>");
@ -353,7 +395,8 @@ sub mail_pre_respond {
else {
$from = (Qpsmtpd::Address->parse($from))[0];
}
return $self->respond(501, "could not parse your mail from command") unless $from;
return $self->respond(501, "could not parse your mail from command")
unless $from;
$self->run_hooks("mail", $from, %$param);
}
@ -387,8 +430,12 @@ sub mail_respond {
$self->disconnect;
}
else { # includes OK
$self->log(LOGDEBUG, "getting mail from ".$from->format);
$self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!");
$self->log(LOGDEBUG, "getting mail from " . $from->format);
$self->respond(
250,
$from->format
. ", sender OK - how exciting to get mail from you!"
);
$self->transaction->sender($from);
}
}
@ -404,13 +451,15 @@ sub rcpt_parse_respond {
my ($ok, $rcpt, @param) = Qpsmtpd::Command->parse("rcpt", $line, $msg->[0]);
return $self->respond(501, $rcpt || "Syntax error in command")
unless ($ok == OK);
return $self->respond(503, "Use MAIL before RCPT") unless $self->transaction->sender;
return $self->respond(503, "Use MAIL before RCPT")
unless $self->transaction->sender;
my %param;
foreach (@param) {
my ($k,$v) = split /=/, $_, 2;
my ($k, $v) = split /=/, $_, 2;
$param{lc $k} = $v;
}
# to support addresses without <> we now require a plugin
# hooking "rcpt_pre" to
# return (OK, "<$rcpt>");
@ -493,9 +542,11 @@ sub help_respond {
else {
unless ($msg->[0]) {
@$msg = (
"This is qpsmtpd " . ($self->config('smtpgreeting') ? '' : $self->version),
"This is qpsmtpd "
. ($self->config('smtpgreeting') ? '' : $self->version),
"See http://smtpd.develooper.com/",
'To report bugs or send comments, mail to <ask@develooper.com>.');
'To report bugs or send comments, mail to <ask@develooper.com>.'
);
}
$self->respond(214, @$msg);
}
@ -549,7 +600,8 @@ sub vrfy_respond {
return 1;
}
else { # $rc == DECLINED or anything else
$self->respond(252, "Just try sending a mail and we'll see how it turns out ...");
$self->respond(252,
"Just try sending a mail and we'll see how it turns out ...");
return 1;
}
}
@ -568,7 +620,8 @@ sub quit {
sub quit_respond {
my ($self, $rc, $msg, $args) = @_;
if ($rc != DONE) {
$msg->[0] ||= $self->config('me') . " closing connection. Have a wonderful day.";
$msg->[0] ||=
$self->config('me') . " closing connection. Have a wonderful day.";
$self->respond(221, @$msg);
}
$self->disconnect();
@ -615,14 +668,17 @@ sub data_respond {
$self->disconnect;
return 1;
}
$self->respond(503, "MAIL first"), return 1 unless $self->transaction->sender;
$self->respond(503, "RCPT first"), return 1 unless $self->transaction->recipients;
$self->respond(503, "MAIL first"), return 1
unless $self->transaction->sender;
$self->respond(503, "RCPT first"), return 1
unless $self->transaction->recipients;
$self->respond(354, "go ahead");
my $buffer = '';
my $size = 0;
my $i = 0;
my $max_size = ($self->config('databytes'))[0] || 0; # this should work in scalar context
my $max_size =
($self->config('databytes'))[0] || 0; # this should work in scalar context
my $blocked = "";
my %matches;
my $in_header = 1;
@ -634,10 +690,10 @@ sub data_respond {
my $timeout = $self->config('timeout');
while (defined($_ = $self->getline($timeout))) {
if ( $_ eq ".\r\n" ) {
if ($_ eq ".\r\n") {
$complete++;
$_ = '';
};
}
$i++;
# should probably use \012 and \015 in these checks instead of \r and \n ...
@ -649,7 +705,7 @@ sub data_respond {
and $self->respond(421, "See http://smtpd.develooper.com/barelf.html")
and return $self->disconnect;
# add a transaction->blocked check back here when we have line by line plugin access...
# add a transaction->blocked check back here when we have line by line plugin access...
unless (($max_size and $size > $max_size)) {
s/\r\n$/\n/;
s/^\.\./\./;
@ -665,7 +721,8 @@ sub data_respond {
# way a Received: line that is already in the header.
$header->extract(\@headers);
#$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/");
#$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/");
$buffer = "";
@ -678,7 +735,8 @@ sub data_respond {
$self->respond(554, $msg || "Message denied");
$self->disconnect;
return 1;
} elsif ($rc == DENYSOFT_DISCONNECT) {
}
elsif ($rc == DENYSOFT_DISCONNECT) {
$self->respond(421, $msg || "Message denied temporarily");
$self->disconnect;
return 1;
@ -696,44 +754,51 @@ sub data_respond {
# copy all lines into the spool file, including the headers
# we will create a new header later before sending onwards
$self->transaction->body_write($_) if ! $complete;
$self->transaction->body_write($_) if !$complete;
$size += length $_;
}
last if $complete > 0;
#$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300);
}
$self->log(LOGDEBUG, "max_size: $max_size / size: $size");
my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
my $esmtp = substr($smtp,0,1) eq "E";
my $esmtp = substr($smtp, 0, 1) eq "E";
my $authheader = '';
my $sslheader = '';
if (defined $self->connection->notes('tls_enabled')
and $self->connection->notes('tls_enabled')) {
and $self->connection->notes('tls_enabled'))
{
$smtp .= "S" if $esmtp; # RFC3848
$sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) ";
$sslheader = "("
. $self->connection->notes('tls_socket')->get_cipher()
. " encrypted) ";
}
if (defined $self->{_auth} and $self->{_auth} == OK) {
$smtp .= "A" if $esmtp; # RFC3848
$authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
$authheader =
"(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
}
$header->add("Received", $self->received_line($smtp, $authheader, $sslheader), 0);
$header->add("Received",
$self->received_line($smtp, $authheader, $sslheader), 0);
# if we get here without seeing a terminator, the connection is
# probably dead.
unless ( $complete ) {
unless ($complete) {
$self->respond(451, "Incomplete DATA");
$self->reset_transaction; # clean up after ourselves
return 1;
}
#$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked);
#$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked);
if ($max_size and $size > $max_size) {
$self->log(LOGALERT, "Message too big: size: $size (max size: $max_size)");
$self->log(LOGALERT,
"Message too big: size: $size (max size: $max_size)");
$self->respond(552, "Message too big!");
$self->reset_transaction; # clean up after ourselves
return 1;
@ -744,7 +809,8 @@ sub data_respond {
sub received_line {
my ($self, $smtp, $authheader, $sslheader) = @_;
my ($rc, @received) = $self->run_hooks("received_line", $smtp, $authheader, $sslheader);
my ($rc, @received) =
$self->run_hooks("received_line", $smtp, $authheader, $sslheader);
if ($rc == YIELD) {
die "YIELD not supported for received_line hook";
}
@ -752,10 +818,18 @@ sub received_line {
return join("\n", @received);
}
else { # assume $rc == DECLINED
return "from ".$self->connection->remote_info
." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip
. ")\n $authheader by ".$self->config('me')." (qpsmtpd/".$self->version
.") with $sslheader$smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime))
return
"from "
. $self->connection->remote_info
. " (HELO "
. $self->connection->hello_host . ") ("
. $self->connection->remote_ip
. ")\n $authheader by "
. $self->config('me')
. " (qpsmtpd/"
. $self->version
. ") with $sslheader$smtp; "
. (strftime('%a, %d %b %Y %H:%M:%S %z', localtime));
}
}
@ -767,12 +841,14 @@ sub data_post_respond {
elsif ($rc == DENY) {
$msg->[0] ||= "Message denied";
$self->respond(552, @$msg);
# DATA is always the end of a "transaction"
return $self->reset_transaction;
}
elsif ($rc == DENYSOFT) {
$msg->[0] ||= "Message denied temporarily";
$self->respond(452, @$msg);
# DATA is always the end of a "transaction"
return $self->reset_transaction;
}
@ -814,7 +890,7 @@ sub queue_pre_respond {
if ($rc == DONE) {
return 1;
}
elsif ($rc != OK and $rc != DECLINED and $rc != 0 ) {
elsif ($rc != OK and $rc != DECLINED and $rc != 0) {
return $self->log(LOGERROR, "pre plugin returned illegal value");
return 0;
}
@ -858,5 +934,4 @@ sub queue_post_respond {
$self->log(LOGERROR, @$msg) unless ($rc == OK or $rc == 0);
}
1;

3
lib/Qpsmtpd/SMTP/Prefork.pm
View File

@ -19,7 +19,8 @@ sub dispatch {
my ($result) = eval { $self->$cmd(@_) };
if ($@ =~ /^disconnect_tcpserver/) {
die "disconnect_tcpserver";
} elsif ($@) {
}
elsif ($@) {
$self->log(LOGERROR, "XX: $@") if $@;
}
return $result if defined $result;

77
lib/Qpsmtpd/TcpServer.pm
View File

@ -10,12 +10,15 @@ use POSIX ();
my $has_ipv6 = 0;
if (
eval {require Socket6;} &&
eval { require Socket6; }
&&
# INET6 prior to 2.01 will not work; sorry.
eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00");}
) {
eval { require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00"); }
)
{
Socket6->import(qw(inet_ntop));
$has_ipv6=1;
$has_ipv6 = 1;
}
sub has_ipv6 {
@ -33,21 +36,27 @@ sub start_connection {
);
if ($ENV{TCPREMOTEIP}) {
# started from tcpserver (or some other superserver which
# exports the TCPREMOTE* variables.
$remote_ip = $ENV{TCPREMOTEIP};
$remote_host = $ENV{TCPREMOTEHOST} || "[$remote_ip]";
$remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host;
$remote_info =
$ENV{TCPREMOTEINFO}
? "$ENV{TCPREMOTEINFO}\@$remote_host"
: $remote_host;
$remote_port = $ENV{TCPREMOTEPORT};
$local_ip = $ENV{TCPLOCALIP};
$local_port = $ENV{TCPLOCALPORT};
$local_host = $ENV{TCPLOCALHOST};
} else {
}
else {
# Started from inetd or similar.
# get info on the remote host from the socket.
# ignore ident/tap/...
my $hersockaddr = getpeername(STDIN)
or die "getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin";
or die
"getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin";
my ($port, $iaddr) = sockaddr_in($hersockaddr);
$remote_ip = inet_ntoa($iaddr);
$remote_host = gethostbyaddr($iaddr, AF_INET) || "[$remote_ip]";
@ -64,20 +73,22 @@ sub start_connection {
my $now = POSIX::strftime("%H:%M:%S %Y-%m-%d", localtime);
$0 = "$first_0 [$remote_ip : $remote_host : $now]";
$self->SUPER::connection->start(remote_info => $remote_info,
$self->SUPER::connection->start(
remote_info => $remote_info,
remote_ip => $remote_ip,
remote_host => $remote_host,
remote_port => $remote_port,
local_ip => $local_ip,
local_port => $local_port,
local_host => $local_host,
@_);
@_
);
}
sub run {
my ($self, $client) = @_;
# Set local client_socket to passed client object for testing socket state on writes
# Set local client_socket to passed client object for testing socket state on writes
$self->{__client_socket} = $client;
$self->load_plugins unless $self->{hooks};
@ -85,15 +96,14 @@ sub run {
my $rc = $self->start_conversation;
return if $rc != DONE;
# this should really be the loop and read_input should just get one line; I think
# this should really be the loop and read_input should just get one line; I think
$self->read_input;
}
sub read_input {
my $self = shift;
my $timeout =
$self->config('timeoutsmtpd') # qmail smtpd control file
my $timeout = $self->config('timeoutsmtpd') # qmail smtpd control file
|| $self->config('timeout') # qpsmtpd control file
|| 1200; # default value
@ -118,23 +128,25 @@ sub respond {
my ($self, $code, @messages) = @_;
my $buf = '';
if ( !$self->check_socket() ) {
$self->log(LOGERROR, "Lost connection to client, cannot send response.");
return(0);
if (!$self->check_socket()) {
$self->log(LOGERROR,
"Lost connection to client, cannot send response.");
return (0);
}
while (my $msg = shift @messages) {
my $line = $code . (@messages?"-":" ").$msg;
my $line = $code . (@messages ? "-" : " ") . $msg;
$self->log(LOGINFO, $line);
$buf .= "$line\r\n";
}
print $buf or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0);
print $buf
or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0);
return 1;
}
sub disconnect {
my $self = shift;
$self->log(LOGINFO,"click, disconnecting");
$self->log(LOGINFO, "click, disconnecting");
$self->SUPER::disconnect(@_);
$self->run_hooks("post-connection");
$self->connection->reset;
@ -145,12 +157,24 @@ sub disconnect {
sub lrpip {
my ($server, $client, $hisaddr) = @_;
my ($port, $iaddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($hisaddr)) : (sockaddr_in6($hisaddr));
my ($port, $iaddr) =
($server->sockdomain == AF_INET)
? (sockaddr_in($hisaddr))
: (sockaddr_in6($hisaddr));
my $localsockaddr = getsockname($client);
my ($lport, $laddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($localsockaddr)) : (sockaddr_in6($localsockaddr));
my ($lport, $laddr) =
($server->sockdomain == AF_INET)
? (sockaddr_in($localsockaddr))
: (sockaddr_in6($localsockaddr));
my $nto_iaddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($iaddr)) : (inet_ntop(AF_INET6(), $iaddr));
my $nto_laddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($laddr)) : (inet_ntop(AF_INET6(), $laddr));
my $nto_iaddr =
($server->sockdomain == AF_INET)
? (inet_ntoa($iaddr))
: (inet_ntop(AF_INET6(), $iaddr));
my $nto_laddr =
($server->sockdomain == AF_INET)
? (inet_ntoa($laddr))
: (inet_ntop(AF_INET6(), $laddr));
$nto_iaddr =~ s/::ffff://;
$nto_laddr =~ s/::ffff://;
@ -164,14 +188,15 @@ sub tcpenv {
my $TCPREMOTEIP = $nto_iaddr;
if ($no_rdns) {
return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEIP ? "[$ENV{TCPREMOTEIP}]" : "[noip!]");
return ($TCPLOCALIP, $TCPREMOTEIP,
$TCPREMOTEIP ? "[$ENV{TCPREMOTEIP}]" : "[noip!]");
}
my $res = new Net::DNS::Resolver;
$res->tcp_timeout(3);
$res->udp_timeout(3);
my $query = $res->query($nto_iaddr);
my $TCPREMOTEHOST;
if($query) {
if ($query) {
foreach my $rr ($query->answer) {
next unless $rr->type eq "PTR";
$TCPREMOTEHOST = $rr->ptrdname;
@ -183,7 +208,7 @@ sub tcpenv {
sub check_socket() {
my $self = shift;
return 1 if ( $self->{__client_socket}->connected );
return 1 if ($self->{__client_socket}->connected);
return 0;
}

20
lib/Qpsmtpd/TcpServer/Prefork.pm
View File

@ -19,8 +19,7 @@ sub start_connection {
sub read_input {
my $self = shift;
my $timeout =
$self->config('timeoutsmtpd') # qmail smtpd control file
my $timeout = $self->config('timeoutsmtpd') # qmail smtpd control file
|| $self->config('timeout') # qpsmtpd control file
|| 1200; # default value
@ -43,7 +42,8 @@ sub read_input {
};
if ($@ =~ /^disconnect_tcpserver/) {
die "disconnect_tcpserver";
} else {
}
else {
$self->run_hooks("post-connection");
$self->connection->reset;
die "died while reading from STDIN (probably broken sender) - $@";
@ -54,22 +54,24 @@ sub read_input {
sub respond {
my ($self, $code, @messages) = @_;
if ( !$self->check_socket() ) {
$self->log(LOGERROR, "Lost connection to client, cannot send response.");
return(0);
if (!$self->check_socket()) {
$self->log(LOGERROR,
"Lost connection to client, cannot send response.");
return (0);
}
while (my $msg = shift @messages) {
my $line = $code . (@messages?"-":" ").$msg;
my $line = $code . (@messages ? "-" : " ") . $msg;
$self->log(LOGINFO, $line);
print "$line\r\n" or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0);
print "$line\r\n"
or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0);
}
return 1;
}
sub disconnect {
my $self = shift;
$self->log(LOGINFO,"click, disconnecting");
$self->log(LOGINFO, "click, disconnecting");
$self->SUPER::disconnect(@_);
$self->run_hooks("post-connection");
$self->connection->reset;

80
lib/Qpsmtpd/Transaction.pm
View File

@ -19,8 +19,8 @@ sub start {
my $class = ref($proto) || $proto;
my %args = @_;
my $self = { _rcpt => [], started => time, };
bless ($self, $class);
my $self = {_rcpt => [], started => time,};
bless($self, $class);
return $self;
}
@ -30,9 +30,10 @@ sub add_recipient {
}
sub remove_recipient {
my ($self,$rcpt) = @_;
$self->{_recipients} = [grep {$_->address ne $rcpt->address}
@{$self->{_recipients} || []}] if $rcpt;
my ($self, $rcpt) = @_;
$self->{_recipients} =
[grep { $_->address ne $rcpt->address } @{$self->{_recipients} || []}]
if $rcpt;
}
sub recipients {
@ -63,7 +64,8 @@ sub header {
#}
sub notes {
my ($self,$key) = (shift,shift);
my ($self, $key) = (shift, shift);
# Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;
@ -78,7 +80,7 @@ sub set_body_start {
else {
$self->{_header_size} = 0;
if ($self->{_body_array}) {
foreach my $line (@{ $self->{_body_array} }) {
foreach my $line (@{$self->{_body_array}}) {
$self->{_header_size} += length($line);
}
}
@ -110,11 +112,14 @@ sub body_spool {
my $self = shift;
$self->log(LOGINFO, "spooling message to disk");
$self->{_filename} = $self->temp_file();
$self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600)
or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error;
$self->{_body_file} =
IO::File->new($self->{_filename}, O_RDWR | O_CREAT, 0600)
or die "Could not open file $self->{_filename} - $! "
; # . $self->{_body_file}->error;
if ($self->{_body_array}) {
foreach my $line (@{ $self->{_body_array} }) {
$self->{_body_file}->print($line) or die "Cannot print to temp file: $!";
foreach my $line (@{$self->{_body_array}}) {
$self->{_body_file}->print($line)
or die "Cannot print to temp file: $!";
}
$self->{_body_start} = $self->{_header_size};
}
@ -128,13 +133,15 @@ sub body_write {
my $self = shift;
my $data = shift;
if ($self->{_body_file}) {
#warn("body_write to file\n");
# go to the end of the file
seek($self->{_body_file},0,2)
seek($self->{_body_file}, 0, 2)
unless $self->{_body_file_writing};
$self->{_body_file_writing} = 1;
$self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data)
and $self->{_body_size} += length (ref $data eq "SCALAR" ? $$data : $data);
and $self->{_body_size} +=
length(ref $data eq "SCALAR" ? $$data : $data);
}
else {
#warn("body_write to array\n");
@ -142,22 +149,23 @@ sub body_write {
my $ref = ref($data) eq "SCALAR" ? $data : \$data;
pos($$ref) = 0;
while ($$ref =~ m/\G(.*?\n)/gc) {
push @{ $self->{_body_array} }, $1;
push @{$self->{_body_array}}, $1;
$self->{_body_size} += length($1);
++$self->{_body_current_pos};
}
if ($$ref =~ m/\G(.+)\z/gc) {
push @{ $self->{_body_array} }, $1;
push @{$self->{_body_array}}, $1;
$self->{_body_size} += length($1);
++$self->{_body_current_pos};
}
$self->body_spool if ( $self->{_body_size} >= $self->size_threshold() );
$self->body_spool if ($self->{_body_size} >= $self->size_threshold());
}
}
sub body_size { # depreceated, use data_size() instead
my $self = shift;
$self->log(LOGWARN, "WARNING: body_size() is depreceated, use data_size() instead");
$self->log(LOGWARN,
"WARNING: body_size() is depreceated, use data_size() instead");
$self->{_body_size} || 0;
}
@ -191,7 +199,7 @@ sub body_getline {
my $self = shift;
if ($self->{_body_file}) {
my $start = $self->{_body_start} || 0;
seek($self->{_body_file}, $start,0)
seek($self->{_body_file}, $start, 0)
if $self->{_body_file_writing};
$self->{_body_file_writing} = 0;
my $line = $self->{_body_file}->getline;
@ -229,45 +237,49 @@ sub dup_body_fh {
sub DESTROY {
my $self = shift;
# would we save some disk flushing if we unlinked the file before
# closing it?
$self->log(LOGDEBUG, sprintf( "DESTROY called by %s, %s, %s", (caller) ) );
$self->log(LOGDEBUG, sprintf("DESTROY called by %s, %s, %s", (caller)));
if ( $self->{_body_file} ) {
if ($self->{_body_file}) {
undef $self->{_body_file};
};
}
if ($self->{_filename} and -e $self->{_filename}) {
if ( unlink $self->{_filename} ) {
$self->log(LOGDEBUG, "unlinked ", $self->{_filename} );
if (unlink $self->{_filename}) {
$self->log(LOGDEBUG, "unlinked ", $self->{_filename});
}
else {
$self->log(LOGERROR, "Could not unlink ", $self->{_filename}, ": $!");
$self->log(LOGERROR, "Could not unlink ",
$self->{_filename}, ": $!");
}
}
# These may not exist
if ( $self->{_temp_files} ) {
if ($self->{_temp_files}) {
$self->log(LOGDEBUG, "Cleaning up temporary transaction files");
foreach my $file ( @{$self->{_temp_files}} ) {
foreach my $file (@{$self->{_temp_files}}) {
next unless -e $file;
unlink $file or $self->log(LOGERROR,
"Could not unlink temporary file", $file, ": $!");
unlink $file
or $self->log(LOGERROR, "Could not unlink temporary file",
$file, ": $!");
}
}
# Ditto
if ( $self->{_temp_dirs} ) {
eval {use File::Path};
if ($self->{_temp_dirs}) {
eval { use File::Path };
$self->log(LOGDEBUG, "Cleaning up temporary directories");
foreach my $dir ( @{$self->{_temp_dirs}} ) {
rmtree($dir) or $self->log(LOGERROR,
"Could not unlink temporary dir", $dir, ": $!");
foreach my $dir (@{$self->{_temp_dirs}}) {
rmtree($dir)
or $self->log(LOGERROR, "Could not unlink temporary dir",
$dir, ": $!");
}
}
}
1;
__END__

1
lib/Qpsmtpd/Utils.pm
View File

@ -11,5 +11,4 @@ sub tildeexp {
return $path;
}
1;

23
t/Test/Qpsmtpd.pm
View File

@ -10,8 +10,14 @@ use Test::Qpsmtpd::Plugin;
sub new_conn {
ok(my $smtpd = __PACKAGE__->new(), "new");
ok(my $conn = $smtpd->start_connection(remote_host => 'localhost',
remote_ip => '127.0.0.1'), "start_connection");
ok(
my $conn =
$smtpd->start_connection(
remote_host => 'localhost',
remote_ip => '127.0.0.1'
),
"start_connection"
);
is(($smtpd->response)[0], "220", "greetings");
($smtpd, $conn);
}
@ -24,11 +30,13 @@ sub start_connection {
my $remote_info = "test\@$remote_host";
my $remote_ip = $args{remote_ip} or croak "no remote_ip parameter";
my $conn = $self->SUPER::connection->start(remote_info => $remote_info,
my $conn =
$self->SUPER::connection->start(
remote_info => $remote_info,
remote_ip => $remote_ip,
remote_host => $remote_host,
@_);
@_
);
$self->load_plugins;
@ -45,7 +53,7 @@ sub respond {
sub response {
my $self = shift;
$self->{_response} ? (@{ delete $self->{_response} }) : ();
$self->{_response} ? (@{delete $self->{_response}}) : ();
}
sub command {
@ -95,6 +103,7 @@ sub run_plugin_tests {
my $self = shift;
$self->{_test_mode} = 1;
my @plugins = $self->load_plugins();
# First count test number
my $num_tests = 0;
foreach my $plugin (@plugins) {
@ -105,7 +114,7 @@ sub run_plugin_tests {
require Test::Builder;
my $Test = Test::Builder->new();
$Test->plan( tests => $num_tests );
$Test->plan(tests => $num_tests);
# Now run them

57
t/Test/Qpsmtpd/Plugin.pm
View File

@ -11,14 +11,16 @@ use Qpsmtpd::Constants;
use Test::More;
sub register_tests {
# Virtual base method - implement in plugin
}
sub register_test {
my ($plugin, $test, $num_tests) = @_;
$num_tests = 1 unless defined($num_tests);
# print STDERR "Registering test $test ($num_tests)\n";
push @{$plugin->{_tests}}, { name => $test, num => $num_tests };
push @{$plugin->{_tests}}, {name => $test, num => $num_tests};
}
sub total_tests {
@ -34,14 +36,15 @@ sub run_tests {
my ($plugin, $qp) = @_;
foreach my $t (@{$plugin->{_tests}}) {
my $method = $t->{name};
print "# Running $method tests for plugin " . $plugin->plugin_name . "\n";
print "# Running $method tests for plugin "
. $plugin->plugin_name . "\n";
local $plugin->{_qp} = $qp;
$plugin->$method();
}
}
sub validate_password {
my ( $self, %a ) = @_;
my ($self, %a) = @_;
my ($pkg, $file, $line) = caller();
@ -53,42 +56,42 @@ sub validate_password {
my $ticket = $a{ticket};
my $deny = $a{deny} || DENY;
if ( ! $src_crypt && ! $src_clear ) {
if (!$src_crypt && !$src_clear) {
$self->log(LOGINFO, "fail: missing password");
return ( $deny, "$file - no such user" );
};
return ($deny, "$file - no such user");
}
if ( ! $src_clear && $method =~ /CRAM-MD5/i ) {
if (!$src_clear && $method =~ /CRAM-MD5/i) {
$self->log(LOGINFO, "skip: cram-md5 not supported w/o clear pass");
return ( DECLINED, $file );
return (DECLINED, $file);
}
if ( defined $attempt_clear ) {
if ( $src_clear && $src_clear eq $attempt_clear ) {
if (defined $attempt_clear) {
if ($src_clear && $src_clear eq $attempt_clear) {
$self->log(LOGINFO, "pass: clear match");
return ( OK, $file );
};
if ( $src_crypt && $src_crypt eq crypt( $attempt_clear, $src_crypt ) ) {
$self->log(LOGINFO, "pass: crypt match");
return ( OK, $file );
return (OK, $file);
}
};
if ( defined $attempt_hash && $src_clear ) {
if ( ! $ticket ) {
if ($src_crypt && $src_crypt eq crypt($attempt_clear, $src_crypt)) {
$self->log(LOGINFO, "pass: crypt match");
return (OK, $file);
}
}
if (defined $attempt_hash && $src_clear) {
if (!$ticket) {
$self->log(LOGERROR, "skip: missing ticket");
return ( DECLINED, $file );
};
return (DECLINED, $file);
}
if ( $attempt_hash eq hmac_md5_hex( $ticket, $src_clear ) ) {
if ($attempt_hash eq hmac_md5_hex($ticket, $src_clear)) {
$self->log(LOGINFO, "pass: hash match");
return ( OK, $file );
};
};
return (OK, $file);
}
}
$self->log(LOGINFO, "fail: wrong password");
return ( $deny, "$file - wrong password" );
};
return ($deny, "$file - wrong password");
}
1;