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 8536a99379
commit 73c988ac05
23 changed files with 2602 additions and 2317 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
lib/Apache/Qpsmtpd.pm
View File

@ -7,13 +7,13 @@ use warnings FATAL => 'all';
use Apache2::ServerUtil (); use Apache2::ServerUtil ();
use Apache2::Connection (); use Apache2::Connection ();
use Apache2::Const -compile => qw(OK MODE_GETLINE); use Apache2::Const -compile => qw(OK MODE_GETLINE);
use APR::Const -compile => qw(SO_NONBLOCK EOF SUCCESS); use APR::Const -compile => qw(SO_NONBLOCK EOF SUCCESS);
use APR::Error (); use APR::Error ();
use APR::Brigade (); use APR::Brigade ();
use APR::Bucket (); use APR::Bucket ();
use APR::Socket (); use APR::Socket ();
use Apache2::Filter (); use Apache2::Filter ();
use ModPerl::Util (); use ModPerl::Util ();
our $VERSION = '0.02'; our $VERSION = '0.02';
@ -22,15 +22,15 @@ sub handler {
$c->client_socket->opt_set(APR::Const::SO_NONBLOCK => 0); $c->client_socket->opt_set(APR::Const::SO_NONBLOCK => 0);
die "\$ENV{QPSMTPD_CONFIG} must be given" unless $ENV{QPSMTPD_CONFIG}; die "\$ENV{QPSMTPD_CONFIG} must be given" unless $ENV{QPSMTPD_CONFIG};
my $qpsmtpd = Qpsmtpd::Apache->new(); my $qpsmtpd = Qpsmtpd::Apache->new();
$qpsmtpd->start_connection( $qpsmtpd->start_connection(
ip => $c->remote_ip, ip => $c->remote_ip,
host => $c->remote_host, host => $c->remote_host,
info => undef, info => undef,
conn => $c, conn => $c,
); );
$qpsmtpd->run($c); $qpsmtpd->run($c);
$qpsmtpd->run_hooks("post-connection"); $qpsmtpd->run_hooks("post-connection");
$qpsmtpd->connection->reset; $qpsmtpd->connection->reset;
@ -46,20 +46,21 @@ use base qw(Qpsmtpd::SMTP);
my %cdir_memo; my %cdir_memo;
sub config_dir { sub config_dir {
my ($self, $config) = @_; my ($self, $config) = @_;
if (exists $cdir_memo{$config}) { if (exists $cdir_memo{$config}) {
return $cdir_memo{$config}; return $cdir_memo{$config};
} }
if (uc($ENV{QPSMTPD_CONFIG}) eq 'USE-VIRTUAL-DOMAINS') { if (uc($ENV{QPSMTPD_CONFIG}) eq 'USE-VIRTUAL-DOMAINS') {
my $cdir = $self->{conn}->base_server->dir_config("qpsmtpd.config_dir"); my $cdir = $self->{conn}->base_server->dir_config("qpsmtpd.config_dir");
$cdir =~ /^(.*)$/; # detaint $cdir =~ /^(.*)$/; # detaint
my $configdir = $1 if -e "$1/$config"; my $configdir = $1 if -e "$1/$config";
$cdir_memo{$config} = $configdir; $cdir_memo{$config} = $configdir;
} else { }
$cdir_memo{$config} = $self->SUPER::config_dir(@_); else {
} $cdir_memo{$config} = $self->SUPER::config_dir(@_);
return $cdir_memo{$config}; }
return $cdir_memo{$config};
} }
sub start_connection { sub start_connection {
@ -67,23 +68,26 @@ sub start_connection {
my %opts = @_; my %opts = @_;
$self->{conn} = $opts{conn}; $self->{conn} = $opts{conn};
$self->{conn}->client_socket->timeout_set($self->config('timeout') * 1_000_000); $self->{conn}
$self->{bb_in} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc); ->client_socket->timeout_set($self->config('timeout') * 1_000_000);
$self->{bb_out} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc); $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_info = $opts{info} ? "$opts{info}\@$remote_host" : $remote_host;
my $remote_ip = $opts{ip}; my $remote_ip = $opts{ip};
$self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]"); $self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]");
$self->SUPER::connection->start( $self->SUPER::connection->start(
remote_info => $remote_info, remote_info => $remote_info,
remote_ip => $remote_ip, remote_ip => $remote_ip,
remote_host => $remote_host, remote_host => $remote_host,
local_ip => $opts{conn}->local_ip, local_ip => $opts{conn}->local_ip,
@_ @_
); );
} }
sub config { sub config {
@ -117,31 +121,32 @@ sub getline {
return if $c->aborted; return if $c->aborted;
my $bb = $self->{bb_in}; my $bb = $self->{bb_in};
while (1) { 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; return if $rc == APR::Const::EOF;
die APR::Error::strerror($rc) unless $rc == APR::Const::SUCCESS; die APR::Error::strerror($rc) unless $rc == APR::Const::SUCCESS;
next unless $bb->flatten(my $data); next unless $bb->flatten(my $data);
$bb->cleanup; $bb->cleanup;
return $data; return $data;
} }
return ''; return '';
} }
sub read_input { sub read_input {
my $self = shift; my $self = shift;
my $c = $self->{conn}; my $c = $self->{conn};
while (defined(my $data = $self->getline)) { while (defined(my $data = $self->getline)) {
$data =~ s/\r?\n$//s; # advanced chomp $data =~ s/\r?\n$//s; # advanced chomp
$self->connection->notes('original_string', $data); $self->connection->notes('original_string', $data);
$self->log(LOGDEBUG, "dispatching $data"); $self->log(LOGDEBUG, "dispatching $data");
defined $self->dispatch(split / +/, $data, 2) defined $self->dispatch(split / +/, $data, 2)
or $self->respond(502, "command unrecognized: '$data'"); or $self->respond(502, "command unrecognized: '$data'");
last if $self->{_quitting}; last if $self->{_quitting};
} }
} }
@ -151,11 +156,12 @@ sub respond {
my $c = $self->{conn}; my $c = $self->{conn};
while (my $msg = shift @messages) { while (my $msg = shift @messages) {
my $bb = $self->{bb_out}; my $bb = $self->{bb_out};
my $line = $code . (@messages?"-":" ").$msg; my $line = $code . (@messages ? "-" : " ") . $msg;
$self->log(LOGDEBUG, $line); $self->log(LOGDEBUG, $line);
my $bucket = APR::Bucket->new(($c->bucket_alloc), "$line\r\n"); my $bucket = APR::Bucket->new(($c->bucket_alloc), "$line\r\n");
$bb->insert_tail($bucket); $bb->insert_tail($bucket);
$c->output_filters->fflush($bb); $c->output_filters->fflush($bb);
# $bucket->remove; # $bucket->remove;
$bb->cleanup; $bb->cleanup;
} }

88
lib/Danga/Client.pm
View File

@ -3,26 +3,26 @@
package Danga::Client; package Danga::Client;
use base 'Danga::TimeoutSocket'; use base 'Danga::TimeoutSocket';
use fields qw( use fields qw(
line line
pause_count pause_count
read_bytes read_bytes
data_bytes data_bytes
callback callback
get_chunks get_chunks
reader_object reader_object
); );
use Time::HiRes (); use Time::HiRes ();
use bytes; use bytes;
# 30 seconds max timeout! # 30 seconds max timeout!
sub max_idle_time { 30 } sub max_idle_time { 30 }
sub max_connect_time { 1200 } sub max_connect_time { 1200 }
sub new { sub new {
my Danga::Client $self = shift; my Danga::Client $self = shift;
$self = fields::new($self) unless ref $self; $self = fields::new($self) unless ref $self;
$self->SUPER::new( @_ ); $self->SUPER::new(@_);
$self->reset_for_next_message; $self->reset_for_next_message;
return $self; return $self;
@ -30,13 +30,13 @@ sub new {
sub reset_for_next_message { sub reset_for_next_message {
my Danga::Client $self = shift; my Danga::Client $self = shift;
$self->{line} = ''; $self->{line} = '';
$self->{pause_count} = 0; $self->{pause_count} = 0;
$self->{read_bytes} = 0; $self->{read_bytes} = 0;
$self->{callback} = undef; $self->{callback} = undef;
$self->{reader_object} = undef; $self->{reader_object} = undef;
$self->{data_bytes} = ''; $self->{data_bytes} = '';
$self->{get_chunks} = 0; $self->{get_chunks} = 0;
return $self; return $self;
} }
@ -52,10 +52,12 @@ sub get_bytes {
$self->{line} = ''; $self->{line} = '';
if ($self->{read_bytes} <= 0) { if ($self->{read_bytes} <= 0) {
if ($self->{read_bytes} < 0) { if ($self->{read_bytes} < 0) {
$self->{line} = substr($self->{data_bytes}, $self->{line} = substr(
$self->{read_bytes}, # negative offset $self->{data_bytes},
0 - $self->{read_bytes}, # to end of str $self->{read_bytes}, # negative offset
""); # truncate that substr 0 - $self->{read_bytes}, # to end of str
""
); # truncate that substr
} }
$callback->($self->{data_bytes}); $callback->($self->{data_bytes});
return; return;
@ -91,14 +93,14 @@ sub get_chunks {
} }
$self->{read_bytes} = $bytes; $self->{read_bytes} = $bytes;
$self->process_chunk($callback) if length($self->{line}); $self->process_chunk($callback) if length($self->{line});
$self->{callback} = $callback; $self->{callback} = $callback;
$self->{get_chunks} = 1; $self->{get_chunks} = 1;
} }
sub end_get_chunks { sub end_get_chunks {
my Danga::Client $self = shift; my Danga::Client $self = shift;
my $remaining = shift; my $remaining = shift;
$self->{callback} = undef; $self->{callback} = undef;
$self->{get_chunks} = 0; $self->{get_chunks} = 0;
if (defined($remaining)) { if (defined($remaining)) {
$self->process_read_buf(\$remaining); $self->process_read_buf(\$remaining);
@ -132,6 +134,7 @@ sub event_read {
$self->{data_bytes} .= $$bref; $self->{data_bytes} .= $$bref;
} }
if ($self->{read_bytes} <= 0) { if ($self->{read_bytes} <= 0) {
# print "Erk, read too much!\n" if $self->{read_bytes} < 0; # print "Erk, read too much!\n" if $self->{read_bytes} < 0;
my $cb = $self->{callback}; my $cb = $self->{callback};
$self->{callback} = undef; $self->{callback} = undef;
@ -150,21 +153,29 @@ sub process_read_buf {
my $bref = shift; my $bref = shift;
$self->{line} .= $$bref; $self->{line} .= $$bref;
return if $self->{pause_count} || $self->{closed}; return if $self->{pause_count} || $self->{closed};
if ($self->{line} =~ s/^(.*?\n)//) { if ($self->{line} =~ s/^(.*?\n)//) {
my $line = $1; my $line = $1;
$self->{alive_time} = time; $self->{alive_time} = time;
my $resp = $self->process_line($line); 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->write($resp) if $resp;
# $self->watch_read(0) if $self->{pause_count}; # $self->watch_read(0) if $self->{pause_count};
return if $self->{pause_count} || $self->{closed}; return if $self->{pause_count} || $self->{closed};
# read more in a timer, to give other clients a look in # read more in a timer, to give other clients a look in
$self->AddTimer(0, sub { $self->AddTimer(
if (length($self->{line}) && !$self->paused) { 0,
$self->process_read_buf(\""); # " for bad syntax highlighters sub {
if (length($self->{line}) && !$self->paused) {
$self->process_read_buf(\"")
; # " for bad syntax highlighters
}
} }
}); );
} }
} }
@ -188,6 +199,7 @@ sub paused {
sub pause_read { sub pause_read {
my Danga::Client $self = shift; my Danga::Client $self = shift;
$self->{pause_count}++; $self->{pause_count}++;
# $self->watch_read(0); # $self->watch_read(0);
} }
@ -196,11 +208,15 @@ sub continue_read {
$self->{pause_count}--; $self->{pause_count}--;
if ($self->{pause_count} <= 0) { if ($self->{pause_count} <= 0) {
$self->{pause_count} = 0; $self->{pause_count} = 0;
$self->AddTimer(0, sub { $self->AddTimer(
if (length($self->{line}) && !$self->paused) { 0,
$self->process_read_buf(\""); # " for bad syntax highlighters sub {
if (length($self->{line}) && !$self->paused) {
$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_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; 1;

16
lib/Danga/TimeoutSocket.pm
View File

@ -22,8 +22,8 @@ sub new {
} }
# overload these in a subclass # overload these in a subclass
sub max_idle_time { 0 } sub max_idle_time { 0 }
sub max_connect_time { 0 } sub max_connect_time { 0 }
sub Reset { sub Reset {
Danga::Socket->Reset; Danga::Socket->Reset;
@ -32,21 +32,21 @@ sub Reset {
sub _do_cleanup { sub _do_cleanup {
my $now = time; my $now = time;
Danga::Socket->AddTimer(15, \&_do_cleanup); Danga::Socket->AddTimer(15, \&_do_cleanup);
my $sf = __PACKAGE__->get_sock_ref; my $sf = __PACKAGE__->get_sock_ref;
my %max_age; # classname -> max age (0 means forever) my %max_age; # classname -> max age (0 means forever)
my %max_connect; # classname -> max connect time my %max_connect; # classname -> max connect time
my @to_close; my @to_close;
while (my $k = each %$sf) { while (my $k = each %$sf) {
my Danga::TimeoutSocket $v = $sf->{$k}; my Danga::TimeoutSocket $v = $sf->{$k};
my $ref = ref $v; my $ref = ref $v;
next unless $v->isa('Danga::TimeoutSocket'); next unless $v->isa('Danga::TimeoutSocket');
unless (defined $max_age{$ref}) { unless (defined $max_age{$ref}) {
$max_age{$ref} = $ref->max_idle_time || 0; $max_age{$ref} = $ref->max_idle_time || 0;
$max_connect{$ref} = $ref->max_connect_time || 0; $max_connect{$ref} = $ref->max_connect_time || 0;
} }
if (my $t = $max_connect{$ref}) { if (my $t = $max_connect{$ref}) {
if ($v->{create_time} < $now - $t) { if ($v->{create_time} < $now - $t) {

850
lib/Qpsmtpd.pm
View File

File diff suppressed because it is too large Load Diff

116
lib/Qpsmtpd/Address.pm
View File

@ -25,9 +25,9 @@ for easy testing of values.
=cut =cut
use overload ( use overload (
'""' => \&format, '""' => \&format,
'cmp' => \&_addr_cmp, 'cmp' => \&_addr_cmp,
); );
=head2 new() =head2 new()
@ -59,13 +59,13 @@ test for equality (like in badmailfrom).
sub new { sub new {
my ($class, $user, $host) = @_; my ($class, $user, $host) = @_;
my $self = {}; my $self = {};
if ($user =~ /^<(.*)>$/ ) { if ($user =~ /^<(.*)>$/) {
($user, $host) = $class->canonify($user); ($user, $host) = $class->canonify($user);
return undef unless defined $user; return undef unless defined $user;
} }
elsif ( not defined $host ) { elsif (not defined $host) {
my $address = $user; my $address = $user;
($user, $host) = $address =~ m/(.*)(?:\@(.*))/; ($user, $host) = $address =~ m/(.*)(?:\@(.*))/;
} }
$self->{_user} = $user; $self->{_user} = $user;
$self->{_host} = $host; $self->{_host} = $host;
@ -84,35 +84,35 @@ sub new {
# At-domain = "@" domain # At-domain = "@" domain
# #
# Mailbox = Local-part "@" Domain # Mailbox = Local-part "@" Domain
# #
# Local-part = Dot-string / Quoted-string # Local-part = Dot-string / Quoted-string
# ; MAY be case-sensitive # ; MAY be case-sensitive
# #
# Dot-string = Atom *("." Atom) # Dot-string = Atom *("." Atom)
# #
# Atom = 1*atext # Atom = 1*atext
# #
# Quoted-string = DQUOTE *qcontent DQUOTE # Quoted-string = DQUOTE *qcontent DQUOTE
# #
# Domain = (sub-domain 1*("." sub-domain)) / address-literal # Domain = (sub-domain 1*("." sub-domain)) / address-literal
# sub-domain = Let-dig [Ldh-str] # sub-domain = Let-dig [Ldh-str]
# #
# address-literal = "[" IPv4-address-literal / # address-literal = "[" IPv4-address-literal /
# IPv6-address-literal / # IPv6-address-literal /
# General-address-literal "]" # General-address-literal "]"
# #
# IPv4-address-literal = Snum 3("." Snum) # IPv4-address-literal = Snum 3("." Snum)
# IPv6-address-literal = "IPv6:" IPv6-addr # IPv6-address-literal = "IPv6:" IPv6-addr
# General-address-literal = Standardized-tag ":" 1*dcontent # General-address-literal = Standardized-tag ":" 1*dcontent
# Standardized-tag = Ldh-str # Standardized-tag = Ldh-str
# ; MUST be specified in a standards-track RFC # ; MUST be specified in a standards-track RFC
# ; and registered with IANA # ; and registered with IANA
# #
# Snum = 1*3DIGIT ; representing a decimal integer # Snum = 1*3DIGIT ; representing a decimal integer
# ; value in the range 0 through 255 # ; value in the range 0 through 255
# Let-dig = ALPHA / DIGIT # Let-dig = ALPHA / DIGIT
# Ldh-str = *( ALPHA / DIGIT / "-" ) Let-dig # Ldh-str = *( ALPHA / DIGIT / "-" ) Let-dig
# #
# IPv6-addr = IPv6-full / IPv6-comp / IPv6v4-full / IPv6v4-comp # IPv6-addr = IPv6-full / IPv6-comp / IPv6v4-full / IPv6v4-comp
# IPv6-hex = 1*4HEXDIG # IPv6-hex = 1*4HEXDIG
# IPv6-full = IPv6-hex 7(":" IPv6-hex) # IPv6-full = IPv6-hex 7(":" IPv6-hex)
@ -127,12 +127,12 @@ sub new {
# ; The "::" represents at least 2 16-bit groups of zeros # ; The "::" represents at least 2 16-bit groups of zeros
# ; No more than 4 groups in addition to the "::" and # ; No more than 4 groups in addition to the "::" and
# ; IPv4-address-literal may be present # ; IPv4-address-literal may be present
# #
# #
# #
# atext and qcontent are not defined in RFC 2821. # atext and qcontent are not defined in RFC 2821.
# From RFC 2822: # From RFC 2822:
# #
# atext = ALPHA / DIGIT / ; Any character except controls, # atext = ALPHA / DIGIT / ; Any character except controls,
# "!" / "#" / ; SP, and specials. # "!" / "#" / ; SP, and specials.
# "$" / "%" / ; Used for atoms # "$" / "%" / ; Used for atoms
@ -145,21 +145,21 @@ sub new {
# "|" / "}" / # "|" / "}" /
# "~" # "~"
# qtext = NO-WS-CTL / ; Non white space controls # qtext = NO-WS-CTL / ; Non white space controls
# #
# %d33 / ; The rest of the US-ASCII # %d33 / ; The rest of the US-ASCII
# %d35-91 / ; characters not including "\" # %d35-91 / ; characters not including "\"
# %d93-126 ; or the quote character # %d93-126 ; or the quote character
# #
# qcontent = qtext / quoted-pair # qcontent = qtext / quoted-pair
# #
# NO-WS-CTL = %d1-8 / ; US-ASCII control characters # NO-WS-CTL = %d1-8 / ; US-ASCII control characters
# %d11 / ; that do not include the # %d11 / ; that do not include the
# %d12 / ; carriage return, line feed, # %d12 / ; carriage return, line feed,
# %d14-31 / ; and white space characters # %d14-31 / ; and white space characters
# %d127 # %d127
# #
# quoted-pair = ("\" text) / obs-qp # quoted-pair = ("\" text) / obs-qp
# #
# text = %d1-9 / ; Characters excluding CR and LF # text = %d1-9 / ; Characters excluding CR and LF
# %d11 / # %d11 /
# %d12 / # %d12 /
@ -196,8 +196,11 @@ sub canonify {
return undef unless ($path =~ /^<(.*)>$/); return undef unless ($path =~ /^<(.*)>$/);
$path = $1; $path = $1;
my $domain = $domain_expr ? $domain_expr my $domain =
: "$subdomain_expr(?:\.$subdomain_expr)*"; $domain_expr
? $domain_expr
: "$subdomain_expr(?:\.$subdomain_expr)*";
# it is possible for $address_literal_expr to be empty, if a site # it is possible for $address_literal_expr to be empty, if a site
# doesn't want to allow them # doesn't want to allow them
$domain = "(?:$address_literal_expr|$domain)" $domain = "(?:$address_literal_expr|$domain)"
@ -216,14 +219,15 @@ sub canonify {
return (undef) unless defined $localpart; return (undef) unless defined $localpart;
if ($localpart =~ /^$atom_expr(\.$atom_expr)*/) { if ($localpart =~ /^$atom_expr(\.$atom_expr)*/) {
# simple case, we are done # simple case, we are done
return ($localpart, $domainpart); return ($localpart, $domainpart);
} }
if ($localpart =~ /^"(($qtext_expr|\\$text_expr)*)"$/) { if ($localpart =~ /^"(($qtext_expr|\\$text_expr)*)"$/) {
$localpart = $1; $localpart = $1;
$localpart =~ s/\\($text_expr)/$1/g; $localpart =~ s/\\($text_expr)/$1/g;
return ($localpart, $domainpart); return ($localpart, $domainpart);
} }
return (undef); return (undef);
} }
@ -234,7 +238,7 @@ to new() called with a single parameter.
=cut =cut
sub parse { # retain for compatibility only sub parse { # retain for compatibility only
return shift->new(shift); return shift->new(shift);
} }
@ -252,14 +256,14 @@ L<format>.
sub address { sub address {
my ($self, $val) = @_; my ($self, $val) = @_;
if ( defined($val) ) { if (defined($val)) {
$val = "<$val>" unless $val =~ /^<.+>$/; $val = "<$val>" unless $val =~ /^<.+>$/;
my ($user, $host) = $self->canonify($val); my ($user, $host) = $self->canonify($val);
$self->{_user} = $user; $self->{_user} = $user;
$self->{_host} = $host; $self->{_host} = $host;
} }
return ( defined $self->{_user} ? $self->{_user} : '' ) return (defined $self->{_user} ? $self->{_user} : '')
. ( defined $self->{_host} ? '@'.$self->{_host} : '' ); . (defined $self->{_host} ? '@' . $self->{_host} : '');
} }
=head2 format() =head2 format()
@ -278,11 +282,12 @@ sub format {
my ($self) = @_; my ($self) = @_;
my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]'; my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]';
return '<>' unless defined $self->{_user}; return '<>' unless defined $self->{_user};
if ( ( my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) { if ((my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) {
return qq(<"$user") return
. ( defined $self->{_host} ? '@'.$self->{_host} : '' ). ">"; qq(<"$user")
} . (defined $self->{_host} ? '@' . $self->{_host} : '') . ">";
return "<".$self->address().">"; }
return "<" . $self->address() . ">";
} }
=head2 user([$user]) =head2 user([$user])
@ -326,10 +331,11 @@ use this to pass data between plugins.
=cut =cut
sub notes { 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 @_; # Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} = shift; return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;
} }
sub _addr_cmp { sub _addr_cmp {
@ -337,16 +343,16 @@ sub _addr_cmp {
my ($left, $right, $swap) = @_; my ($left, $right, $swap) = @_;
my $class = ref($left); my $class = ref($left);
unless ( UNIVERSAL::isa($right, $class) ) { unless (UNIVERSAL::isa($right, $class)) {
$right = $class->new($right); $right = $class->new($right);
} }
#invert the address so we can sort by domain then user #invert the address so we can sort by domain then user
($left = join( '=', reverse( split(/@/, $left->format))) ) =~ tr/[<>]//d; ($left = join('=', reverse(split(/@/, $left->format)))) =~ tr/[<>]//d;
($right = join( '=', reverse( split(/@/,$right->format))) ) =~ tr/[<>]//d; ($right = join('=', reverse(split(/@/, $right->format)))) =~ tr/[<>]//d;
if ( $swap ) { if ($swap) {
($right, $left) = ($left, $right); ($right, $left) = ($left, $right);
} }
return ($left cmp $right); return ($left cmp $right);

204
lib/Qpsmtpd/Auth.pm
View File

@ -1,5 +1,6 @@
package Qpsmtpd::Auth; package Qpsmtpd::Auth;
# See the documentation in 'perldoc docs/authentication.pod'
# See the documentation in 'perldoc docs/authentication.pod'
use strict; use strict;
use warnings; use warnings;
@ -10,167 +11,172 @@ use Digest::HMAC_MD5 qw(hmac_md5_hex);
use MIME::Base64; use MIME::Base64;
sub e64 { sub e64 {
my ($arg) = @_; my ($arg) = @_;
my $res = encode_base64($arg); my $res = encode_base64($arg);
chomp($res); chomp($res);
return($res); return ($res);
} }
sub SASL { sub SASL {
# $DB::single = 1; # $DB::single = 1;
my ( $session, $mechanism, $prekey ) = @_; my ($session, $mechanism, $prekey) = @_;
my ( $user, $passClear, $passHash, $ticket, $loginas ); my ($user, $passClear, $passHash, $ticket, $loginas);
if ( $mechanism eq 'plain' ) { if ($mechanism eq 'plain') {
($loginas, $user, $passClear) = get_auth_details_plain($session,$prekey); ($loginas, $user, $passClear) =
return DECLINED if ! $user || ! $passClear; get_auth_details_plain($session, $prekey);
return DECLINED if !$user || !$passClear;
} }
elsif ( $mechanism eq 'login' ) { elsif ($mechanism eq 'login') {
($user, $passClear) = get_auth_details_login($session,$prekey); ($user, $passClear) = get_auth_details_login($session, $prekey);
return DECLINED if ! $user || ! $passClear; return DECLINED if !$user || !$passClear;
} }
elsif ( $mechanism eq 'cram-md5' ) { elsif ($mechanism eq 'cram-md5') {
( $ticket, $user, $passHash ) = get_auth_details_cram_md5($session); ($ticket, $user, $passHash) = get_auth_details_cram_md5($session);
return DECLINED if ! $user || ! $passHash; return DECLINED if !$user || !$passHash;
} }
else { else {
#this error is now caught in SMTP.pm's sub auth #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; return DECLINED;
} }
# try running the specific hooks first # try running the specific hooks first
my ( $rc, $msg ) = my ($rc, $msg) =
$session->run_hooks( "auth-$mechanism", $mechanism, $user, $passClear, $session->run_hooks("auth-$mechanism", $mechanism, $user, $passClear,
$passHash, $ticket ); $passHash, $ticket);
# try running the polymorphous hooks next # try running the polymorphous hooks next
if ( !$rc || $rc == DECLINED ) { if (!$rc || $rc == DECLINED) {
( $rc, $msg ) = ($rc, $msg) =
$session->run_hooks( "auth", $mechanism, $user, $passClear, $session->run_hooks("auth", $mechanism, $user,
$passHash, $ticket ); $passClear, $passHash, $ticket);
} }
if ( $rc == OK ) { if ($rc == OK) {
$msg = uc($mechanism) . " authentication successful for $user" . $msg =
( $msg ? " - $msg" : ''); uc($mechanism)
$session->respond( 235, $msg ); . " authentication successful for $user"
. ($msg ? " - $msg" : '');
$session->respond(235, $msg);
$session->connection->relay_client(1); $session->connection->relay_client(1);
if ( $session->connection->notes('naughty' ) ) { if ($session->connection->notes('naughty')) {
$session->log( LOGINFO, "auth success cleared naughty" ); $session->log(LOGINFO, "auth success cleared naughty");
$session->connection->notes('naughty',0); $session->connection->notes('naughty', 0);
}; }
$session->log( LOGDEBUG, $msg ); # already logged by $session->respond $session->log(LOGDEBUG, $msg); # already logged by $session->respond
$session->{_auth_user} = $user; $session->{_auth_user} = $user;
$session->{_auth_mechanism} = $mechanism; $session->{_auth_mechanism} = $mechanism;
s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism}); s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism});
return OK; return OK;
} }
else { else {
$msg = uc($mechanism) . " authentication failed for $user" . $msg =
( $msg ? " - $msg" : ''); uc($mechanism)
$session->respond( 535, $msg ); . " authentication failed for $user"
$session->log( LOGDEBUG, $msg ); # already logged by $session->respond . ($msg ? " - $msg" : '');
$session->respond(535, $msg);
$session->log(LOGDEBUG, $msg); # already logged by $session->respond
return DENY; return DENY;
} }
} }
sub get_auth_details_plain { sub get_auth_details_plain {
my ( $session, $prekey ) = @_; my ($session, $prekey) = @_;
if ( ! $prekey) { if (!$prekey) {
$session->respond( 334, ' ' ); $session->respond(334, ' ');
$prekey= <STDIN>; $prekey = <STDIN>;
} }
my ( $loginas, $user, $passClear ) = split /\x0/, decode_base64($prekey); my ($loginas, $user, $passClear) = split /\x0/, decode_base64($prekey);
if ( ! $user ) { if (!$user) {
if ( $loginas ) { if ($loginas) {
$session->respond(535, "Authentication invalid ($loginas)"); $session->respond(535, "Authentication invalid ($loginas)");
} }
else { else {
$session->respond(535, "Authentication invalid"); $session->respond(535, "Authentication invalid");
} }
return; return;
}; }
# Authorization ID must not be different from Authentication ID # 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"); $session->respond(535, "Authentication invalid for $user");
return; return;
} }
return ($loginas, $user, $passClear); return ($loginas, $user, $passClear);
}; }
sub get_auth_details_login { sub get_auth_details_login {
my ( $session, $prekey ) = @_; my ($session, $prekey) = @_;
my $user; my $user;
if ( $prekey ) { if ($prekey) {
$user = decode_base64($prekey); $user = decode_base64($prekey);
} }
else { 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); return ($user, $passClear);
}; }
sub get_auth_details_cram_md5 { 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 # 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 # 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. # once in the same second, or if the clock is skewed.
$ticket = sprintf( '<%x.%x@%s>', $ticket =
rand(1000000), time(), $session->config('me') ); sprintf('<%x.%x@%s>', rand(1000000), time(), $session->config('me'));
}; }
# send the base64 encoded ticket # send the base64 encoded ticket
$session->respond( 334, encode_base64( $ticket, '' ) ); $session->respond(334, encode_base64($ticket, ''));
my $line = <STDIN>; my $line = <STDIN>;
if ( $line eq '*' ) { if ($line eq '*') {
$session->respond( 501, "Authentication canceled" ); $session->respond(501, "Authentication canceled");
return; return;
}; }
my ( $user, $passHash ) = split( / /, decode_base64($line) ); my ($user, $passHash) = split(/ /, decode_base64($line));
unless ( $user && $passHash ) { unless ($user && $passHash) {
$session->respond(504, "Invalid authentication string"); $session->respond(504, "Invalid authentication string");
return; return;
} }
$session->{auth}{ticket} = $ticket; $session->{auth}{ticket} = $ticket;
return ($ticket, $user, $passHash); return ($ticket, $user, $passHash);
}; }
sub get_base64_response { sub get_base64_response {
my ($session, $question) = @_; my ($session, $question) = @_;
$session->respond(334, e64($question)); $session->respond(334, e64($question));
my $answer = decode_base64( <STDIN> ); my $answer = decode_base64(<STDIN>);
if ($answer eq '*') { if ($answer eq '*') {
$session->respond(501, "Authentication canceled"); $session->respond(501, "Authentication canceled");
return; return;
} }
return $answer; return $answer;
}; }
sub validate_password { sub validate_password {
my ( $self, %a ) = @_; my ($self, %a) = @_;
my ($pkg, $file, $line) = caller(); my ($pkg, $file, $line) = caller();
$file = (split /\//, $file)[-1]; # strip off the path $file = (split /\//, $file)[-1]; # strip off the path
my $src_clear = $a{src_clear}; my $src_clear = $a{src_clear};
my $src_crypt = $a{src_crypt}; my $src_crypt = $a{src_crypt};
@ -180,43 +186,43 @@ sub validate_password {
my $ticket = $a{ticket} || $self->{auth}{ticket}; my $ticket = $a{ticket} || $self->{auth}{ticket};
my $deny = $a{deny} || DENY; my $deny = $a{deny} || DENY;
if ( ! $src_crypt && ! $src_clear ) { if (!$src_crypt && !$src_clear) {
$self->log(LOGINFO, "fail: missing password"); $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 ) {
$self->log(LOGINFO, "skip: cram-md5 not supported w/o clear pass");
return ( DECLINED, $file );
} }
if ( defined $attempt_clear ) { if (!$src_clear && $method =~ /CRAM-MD5/i) {
if ( $src_clear && $src_clear eq $attempt_clear ) { $self->log(LOGINFO, "skip: cram-md5 not supported w/o clear pass");
return (DECLINED, $file);
}
if (defined $attempt_clear) {
if ($src_clear && $src_clear eq $attempt_clear) {
$self->log(LOGINFO, "pass: clear match"); $self->log(LOGINFO, "pass: clear match");
return ( OK, $file ); return (OK, $file);
};
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 ($src_crypt && $src_crypt eq crypt($attempt_clear, $src_crypt)) {
if ( ! $ticket ) { $self->log(LOGINFO, "pass: crypt match");
return (OK, $file);
}
}
if (defined $attempt_hash && $src_clear) {
if (!$ticket) {
$self->log(LOGERROR, "skip: missing 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"); $self->log(LOGINFO, "pass: hash match");
return ( OK, $file ); return (OK, $file);
}; }
}; }
$self->log(LOGINFO, "fail: wrong password"); $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 # tag: qpsmtpd plugin that sets RELAYCLIENT when the user authenticates

40
lib/Qpsmtpd/Command.pm
View File

@ -60,8 +60,8 @@ use vars qw(@ISA);
@ISA = qw(Qpsmtpd::SMTP); @ISA = qw(Qpsmtpd::SMTP);
sub parse { sub parse {
my ($me,$cmd,$line,$sub) = @_; my ($me, $cmd, $line, $sub) = @_;
return (OK) unless defined $line; # trivial case return (OK) unless defined $line; # trivial case
my $self = {}; my $self = {};
bless $self, $me; bless $self, $me;
$cmd = lc $cmd; $cmd = lc $cmd;
@ -77,28 +77,29 @@ sub parse {
## } ## }
## $self->log(LOGDEBUG, "parse($cmd) => [".join("], [", @log)."]"); ## $self->log(LOGDEBUG, "parse($cmd) => [".join("], [", @log)."]");
return @ret; return @ret;
} }
my $parse = "parse_$cmd"; my $parse = "parse_$cmd";
if ($self->can($parse)) { if ($self->can($parse)) {
# print "CMD=$cmd,line=$line\n"; # print "CMD=$cmd,line=$line\n";
my @out = eval { $self->$parse($cmd, $line); }; my @out = eval { $self->$parse($cmd, $line); };
if ($@) { if ($@) {
$self->log(LOGERROR, "$parse($cmd,$line) failed: $@"); $self->log(LOGERROR, "$parse($cmd,$line) failed: $@");
return(DENY, "Failed to parse line"); return (DENY, "Failed to parse line");
} }
return @out; return @out;
} }
return(OK, split(/ +/, $line)); # default :) return (OK, split(/ +/, $line)); # default :)
} }
sub parse_rcpt { sub parse_rcpt {
my ($self,$cmd,$line) = @_; my ($self, $cmd, $line) = @_;
return (DENY, "Syntax error in command") unless $line =~ s/^to:\s*//i; return (DENY, "Syntax error in command") unless $line =~ s/^to:\s*//i;
return &_get_mail_params($cmd, $line); return &_get_mail_params($cmd, $line);
} }
sub parse_mail { sub parse_mail {
my ($self,$cmd,$line) = @_; my ($self, $cmd, $line) = @_;
return (DENY, "Syntax error in command") unless $line =~ s/^from:\s*//i; return (DENY, "Syntax error in command") unless $line =~ s/^from:\s*//i;
return &_get_mail_params($cmd, $line); return &_get_mail_params($cmd, $line);
} }
@ -121,7 +122,7 @@ sub parse_mail {
## inner-esmtp-cmd ::= ("MAIL FROM:" reverse-path) / ## inner-esmtp-cmd ::= ("MAIL FROM:" reverse-path) /
## ("RCPT TO:" forward-path) ## ("RCPT TO:" forward-path)
sub _get_mail_params { sub _get_mail_params {
my ($cmd,$line) = @_; my ($cmd, $line) = @_;
my @params = (); my @params = ();
$line =~ s/\s*$//; $line =~ s/\s*$//;
@ -130,36 +131,37 @@ sub _get_mail_params {
} }
@params = reverse @params; @params = reverse @params;
# the above will "fail" (i.e. all of the line in @params) on # the above will "fail" (i.e. all of the line in @params) on
# some addresses without <> like # some addresses without <> like
# MAIL FROM: user=name@example.net # MAIL FROM: user=name@example.net
# or RCPT TO: postmaster # or RCPT TO: postmaster
# let's see if $line contains nothing and use the first value as address: # let's see if $line contains nothing and use the first value as address:
if ($line) { if ($line) {
# parameter syntax error, i.e. not all of the arguments were
# parameter syntax error, i.e. not all of the arguments were
# stripped by the while() loop: # stripped by the while() loop:
return (DENY, "Syntax error in parameters") return (DENY, "Syntax error in parameters")
if ($line =~ /\@.*\s/); if ($line =~ /\@.*\s/);
return (OK, $line, @params); return (OK, $line, @params);
} }
$line = shift @params; $line = shift @params;
if ($cmd eq "mail") { if ($cmd eq "mail") {
return (OK, "<>") unless $line; # 'MAIL FROM:' --> 'MAIL FROM:<>' return (OK, "<>") unless $line; # 'MAIL FROM:' --> 'MAIL FROM:<>'
return (DENY, "Syntax error in parameters") return (DENY, "Syntax error in parameters")
if ($line =~ /\@.*\s/); # parameter syntax error if ($line =~ /\@.*\s/); # parameter syntax error
} }
else { else {
if ($line =~ /\@/) { if ($line =~ /\@/) {
return (DENY, "Syntax error in parameters") return (DENY, "Syntax error in parameters")
if ($line =~ /\@.*\s/); if ($line =~ /\@.*\s/);
} }
else { else {
# XXX: what about 'abuse' in Qpsmtpd::Address? # XXX: what about 'abuse' in Qpsmtpd::Address?
return (DENY, "Syntax error in parameters") if $line =~ /\s/; return (DENY, "Syntax error in parameters") if $line =~ /\s/;
return (DENY, "Syntax error in address") return (DENY, "Syntax error in address")
unless ($line =~ /^(postmaster|abuse)$/i); unless ($line =~ /^(postmaster|abuse)$/i);
} }
} }
## XXX: No: let this do a plugin, so it's not up to us to decide ## XXX: No: let this do a plugin, so it's not up to us to decide

176
lib/Qpsmtpd/ConfigServer.pm
View File

@ -6,38 +6,38 @@ use Qpsmtpd::Constants;
use strict; use strict;
use fields qw( use fields qw(
_auth _auth
_commands _commands
_config_cache _config_cache
_connection _connection
_transaction _transaction
_test_mode _test_mode
_extras _extras
other_fds other_fds
); );
my $PROMPT = "Enter command: "; my $PROMPT = "Enter command: ";
sub new { sub new {
my Qpsmtpd::ConfigServer $self = shift; my Qpsmtpd::ConfigServer $self = shift;
$self = fields::new($self) unless ref $self; $self = fields::new($self) unless ref $self;
$self->SUPER::new( @_ ); $self->SUPER::new(@_);
$self->write($PROMPT); $self->write($PROMPT);
return $self; return $self;
} }
sub max_idle_time { 3600 } # one hour sub max_idle_time { 3600 } # one hour
sub process_line { sub process_line {
my $self = shift; my $self = shift;
my $line = shift || return; 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 { local $SIG{ALRM} = sub {
my ($pkg, $file, $line) = caller(); my ($pkg, $file, $line) = caller();
die "ALARM: $pkg, $file, $line"; die "ALARM: $pkg, $file, $line";
}; };
my $prev = alarm(2); # must process a command in < 2 seconds my $prev = alarm(2); # must process a command in < 2 seconds
my $resp = eval { $self->_process_line($line) }; my $resp = eval { $self->_process_line($line) };
alarm($prev); alarm($prev);
if ($@) { if ($@) {
@ -56,11 +56,11 @@ sub respond {
} }
sub fault { sub fault {
my $self = shift; my $self = shift;
my ($msg) = shift || "program fault - command not performed"; my ($msg) = shift || "program fault - command not performed";
print STDERR "$0 [$$]: $msg ($!)\n"; print STDERR "$0 [$$]: $msg ($!)\n";
$self->respond("Error - " . $msg); $self->respond("Error - " . $msg);
return $PROMPT; return $PROMPT;
} }
sub _process_line { sub _process_line {
@ -71,9 +71,7 @@ sub _process_line {
my ($cmd, @params) = split(/ +/, $line); my ($cmd, @params) = split(/ +/, $line);
my $meth = "cmd_" . lc($cmd); my $meth = "cmd_" . lc($cmd);
if (my $lookup = $self->can($meth)) { if (my $lookup = $self->can($meth)) {
my $resp = eval { my $resp = eval { $lookup->($self, @params); };
$lookup->($self, @params);
};
if ($@) { if ($@) {
my $error = $@; my $error = $@;
chomp($error); chomp($error);
@ -89,28 +87,33 @@ sub _process_line {
} }
my %helptext = ( my %helptext = (
help => "HELP [CMD] - Get help on all commands or a specific command", help => "HELP [CMD] - Get help on all commands or a specific command",
status => "STATUS - Returns status information about current connections", status => "STATUS - Returns status information about current connections",
list => "LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list", list =>
kill => "KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF", "LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list",
pause => "PAUSE - Stop accepting new connections", kill =>
"KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF",
pause => "PAUSE - Stop accepting new connections",
continue => "CONTINUE - Resume accepting connections", continue => "CONTINUE - Resume accepting connections",
reload => "RELOAD - Reload all plugins and config", reload => "RELOAD - Reload all plugins and config",
quit => "QUIT - Exit the config server", quit => "QUIT - Exit the config server",
); );
sub cmd_help { sub cmd_help {
my $self = shift; my $self = shift;
my ($subcmd) = @_; my ($subcmd) = @_;
$subcmd ||= 'help'; $subcmd ||= 'help';
$subcmd = lc($subcmd); $subcmd = lc($subcmd);
if ($subcmd eq 'help') { 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"; 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"; return "$txt\n";
} }
@ -125,47 +128,48 @@ sub cmd_shutdown {
sub cmd_pause { sub cmd_pause {
my $self = shift; my $self = shift;
my $other_fds = $self->OtherFds; my $other_fds = $self->OtherFds;
$self->{other_fds} = { %$other_fds }; $self->{other_fds} = {%$other_fds};
%$other_fds = (); %$other_fds = ();
return "PAUSED"; return "PAUSED";
} }
sub cmd_continue { sub cmd_continue {
my $self = shift; my $self = shift;
my $other_fds = $self->{other_fds}; my $other_fds = $self->{other_fds};
$self->OtherFds( %$other_fds ); $self->OtherFds(%$other_fds);
%$other_fds = (); %$other_fds = ();
return "UNPAUSED"; return "UNPAUSED";
} }
sub cmd_status { sub cmd_status {
my $self = shift; my $self = shift;
# Status should show: # Status should show:
# - Total time running # - Total time running
# - Total number of mails received # - Total number of mails received
# - Total number of mails rejected (5xx) # - Total number of mails rejected (5xx)
# - Total number of mails tempfailed (5xx) # - Total number of mails tempfailed (5xx)
# - Avg number of mails/minute # - Avg number of mails/minute
# - Number of current connections # - Number of current connections
# - Number of outstanding DNS queries # - Number of outstanding DNS queries
my $output = "Current Status as of " . gmtime() . " GMT\n\n"; my $output = "Current Status as of " . gmtime() . " GMT\n\n";
if (defined &Qpsmtpd::Plugin::stats::get_stats) { if (defined &Qpsmtpd::Plugin::stats::get_stats) {
# Stats plugin is loaded # Stats plugin is loaded
$output .= Qpsmtpd::Plugin::stats->get_stats; $output .= Qpsmtpd::Plugin::stats->get_stats;
} }
my $descriptors = Danga::Socket->DescriptorMap; my $descriptors = Danga::Socket->DescriptorMap;
my $current_connections = 0; my $current_connections = 0;
my $current_dns = 0; my $current_dns = 0;
foreach my $fd (keys %$descriptors) { foreach my $fd (keys %$descriptors) {
my $pob = $descriptors->{$fd}; my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) { if ($pob->isa("Qpsmtpd::PollServer")) {
@ -175,99 +179,109 @@ sub cmd_status {
$current_dns = $pob->pending; $current_dns = $pob->pending;
} }
} }
$output .= "Curr Connections: $current_connections / $::MAXconn\n". $output .= "Curr Connections: $current_connections / $::MAXconn\n"
"Curr DNS Queries: $current_dns"; . "Curr DNS Queries: $current_dns";
return $output; return $output;
} }
sub cmd_list { sub cmd_list {
my $self = shift; my $self = shift;
my ($count) = @_; my ($count) = @_;
my $descriptors = Danga::Socket->DescriptorMap; 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; my @all;
foreach my $fd (keys %$descriptors) { foreach my $fd (keys %$descriptors) {
my $pob = $descriptors->{$fd}; my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) { if ($pob->isa("Qpsmtpd::PollServer")) {
next unless $pob->connection->remote_ip; # haven't even started yet next unless $pob->connection->remote_ip; # haven't even started yet
push @all, [$pob+0, $pob->connection->remote_ip, push @all,
$pob->connection->remote_host, $pob->uptime]; [
$pob + 0, $pob->connection->remote_ip,
$pob->connection->remote_host, $pob->uptime
];
} }
} }
@all = sort { $a->[3] <=> $b->[3] } @all; @all = sort { $a->[3] <=> $b->[3] } @all;
if ($count) { if ($count) {
if ($count > 0) { if ($count > 0) {
@all = @all[$#all-($count-1) .. $#all]; @all = @all[$#all - ($count - 1) .. $#all];
} }
else { else {
@all = @all[0..(abs($count) - 1)]; @all = @all[0 .. (abs($count) - 1)];
} }
} }
foreach my $item (@all) { 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; return $list;
} }
sub cmd_kill { sub cmd_kill {
my $self = shift; my $self = shift;
my ($match) = @_; my ($match) = @_;
return "SYNTAX: KILL (\$IP | \$REF)\n" unless $match; return "SYNTAX: KILL (\$IP | \$REF)\n" unless $match;
my $descriptors = Danga::Socket->DescriptorMap; my $descriptors = Danga::Socket->DescriptorMap;
my $killed = 0; my $killed = 0;
my $is_ip = (index($match, '.') >= 0); my $is_ip = (index($match, '.') >= 0);
foreach my $fd (keys %$descriptors) { foreach my $fd (keys %$descriptors) {
my $pob = $descriptors->{$fd}; my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) { if ($pob->isa("Qpsmtpd::PollServer")) {
if ($is_ip) { 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) { 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; $pob->disconnect;
$killed++; $killed++;
} }
} }
else { else {
# match by ID # match by ID
if ($pob+0 == hex($match)) { if ($pob + 0 == hex($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; $pob->disconnect;
$killed++; $killed++;
} }
} }
} }
} }
return "Killed $killed connection" . ($killed > 1 ? "s" : "") . "\n"; return "Killed $killed connection" . ($killed > 1 ? "s" : "") . "\n";
} }
sub cmd_dump { sub cmd_dump {
my $self = shift; my $self = shift;
my ($ref) = @_; my ($ref) = @_;
return "SYNTAX: DUMP \$REF\n" unless $ref; return "SYNTAX: DUMP \$REF\n" unless $ref;
require Data::Dumper; require Data::Dumper;
$Data::Dumper::Indent=1; $Data::Dumper::Indent = 1;
my $descriptors = Danga::Socket->DescriptorMap; my $descriptors = Danga::Socket->DescriptorMap;
foreach my $fd (keys %$descriptors) { foreach my $fd (keys %$descriptors) {
my $pob = $descriptors->{$fd}; my $pob = $descriptors->{$fd};
if ($pob->isa("Qpsmtpd::PollServer")) { if ($pob->isa("Qpsmtpd::PollServer")) {
if ($pob+0 == hex($ref)) { if ($pob + 0 == hex($ref)) {
return Data::Dumper::Dumper($pob); return Data::Dumper::Dumper($pob);
} }
} }
} }
return "Unable to find the connection: $ref. Try the LIST command\n"; return "Unable to find the connection: $ref. Try the LIST command\n";
} }

139
lib/Qpsmtpd/Connection.pm
View File

@ -1,123 +1,124 @@
package Qpsmtpd::Connection; package Qpsmtpd::Connection;
use strict; use strict;
# All of these parameters depend only on the physical connection, # All of these parameters depend only on the physical connection,
# i.e. not on anything sent from the remote machine. Hence, they # i.e. not on anything sent from the remote machine. Hence, they
# are an appropriate set to use for either start() or clone(). Do # are an appropriate set to use for either start() or clone(). Do
# not add parameters here unless they also meet that criteria. # not add parameters here unless they also meet that criteria.
my @parameters = qw( my @parameters = qw(
remote_host remote_host
remote_ip remote_ip
remote_info remote_info
remote_port remote_port
local_ip local_ip
local_port local_port
relay_client relay_client
); );
sub new { sub new {
my $proto = shift; my $proto = shift;
my $class = ref($proto) || $proto; my $class = ref($proto) || $proto;
my $self = {}; my $self = {};
bless ($self, $class); bless($self, $class);
} }
sub start { sub start {
my $self = shift; my $self = shift;
$self = $self->new(@_) unless ref $self; $self = $self->new(@_) unless ref $self;
my %args = @_; my %args = @_;
foreach my $f ( @parameters ) { foreach my $f (@parameters) {
$self->$f($args{$f}) if $args{$f}; $self->$f($args{$f}) if $args{$f};
} }
return $self; return $self;
} }
sub clone { sub clone {
my $self = shift; my $self = shift;
my %args = @_; my %args = @_;
my $new = $self->new(); my $new = $self->new();
foreach my $f ( @parameters ) { foreach my $f (@parameters) {
$new->$f($self->$f()) if $self->$f(); $new->$f($self->$f()) if $self->$f();
} }
$new->{_notes} = $self->{_notes} if defined $self->{_notes}; $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 # reset the old connection object like it's done at the end of a connection
# still around) # to prevent leaks (like prefork/tls problem with the old SSL file handle
$self->reset unless $args{no_reset}; # still around)
# should we generate a new id here? $self->reset unless $args{no_reset};
return $new;
# should we generate a new id here?
return $new;
} }
sub remote_host { sub remote_host {
my $self = shift; my $self = shift;
@_ and $self->{_remote_host} = shift; @_ and $self->{_remote_host} = shift;
$self->{_remote_host}; $self->{_remote_host};
} }
sub remote_ip { sub remote_ip {
my $self = shift; my $self = shift;
@_ and $self->{_remote_ip} = shift; @_ and $self->{_remote_ip} = shift;
$self->{_remote_ip}; $self->{_remote_ip};
} }
sub remote_port { sub remote_port {
my $self = shift; my $self = shift;
@_ and $self->{_remote_port} = shift; @_ and $self->{_remote_port} = shift;
$self->{_remote_port}; $self->{_remote_port};
} }
sub local_ip { sub local_ip {
my $self = shift; my $self = shift;
@_ and $self->{_local_ip} = shift; @_ and $self->{_local_ip} = shift;
$self->{_local_ip}; $self->{_local_ip};
} }
sub local_port { sub local_port {
my $self = shift; my $self = shift;
@_ and $self->{_local_port} = shift; @_ and $self->{_local_port} = shift;
$self->{_local_port}; $self->{_local_port};
} }
sub remote_info { sub remote_info {
my $self = shift; my $self = shift;
@_ and $self->{_remote_info} = shift; @_ and $self->{_remote_info} = shift;
$self->{_remote_info}; $self->{_remote_info};
} }
sub relay_client { sub relay_client {
my $self = shift; my $self = shift;
@_ and $self->{_relay_client} = shift; @_ and $self->{_relay_client} = shift;
$self->{_relay_client}; $self->{_relay_client};
} }
sub hello { sub hello {
my $self = shift; my $self = shift;
@_ and $self->{_hello} = shift; @_ and $self->{_hello} = shift;
$self->{_hello}; $self->{_hello};
} }
sub hello_host { sub hello_host {
my $self = shift; my $self = shift;
@_ and $self->{_hello_host} = shift; @_ and $self->{_hello_host} = shift;
$self->{_hello_host}; $self->{_hello_host};
} }
sub notes { 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 @_; # Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} = shift; return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;
} }
sub reset { sub reset {
my $self = shift; my $self = shift;
$self->{_notes} = undef; $self->{_notes} = undef;
$self = $self->new; $self = $self->new;
} }
1; 1;

74
lib/Qpsmtpd/Constants.pm
View File

@ -4,64 +4,64 @@ require Exporter;
# log levels # log levels
my %log_levels = ( my %log_levels = (
LOGDEBUG => 7, LOGDEBUG => 7,
LOGINFO => 6, LOGINFO => 6,
LOGNOTICE => 5, LOGNOTICE => 5,
LOGWARN => 4, LOGWARN => 4,
LOGERROR => 3, LOGERROR => 3,
LOGCRIT => 2, LOGCRIT => 2,
LOGALERT => 1, LOGALERT => 1,
LOGEMERG => 0, LOGEMERG => 0,
LOGRADAR => 0, LOGRADAR => 0,
); );
# return codes # return codes
my %return_codes = ( my %return_codes = (
OK => 900, OK => 900,
DENY => 901, # 550 DENY => 901, # 550
DENYSOFT => 902, # 450 DENYSOFT => 902, # 450
DENYHARD => 903, # 550 + disconnect (deprecated in 0.29) DENYHARD => 903, # 550 + disconnect (deprecated in 0.29)
DENY_DISCONNECT => 903, # 550 + disconnect DENY_DISCONNECT => 903, # 550 + disconnect
DENYSOFT_DISCONNECT => 904, # 450 + disconnect DENYSOFT_DISCONNECT => 904, # 450 + disconnect
DECLINED => 909, DECLINED => 909,
DONE => 910, DONE => 910,
CONTINUATION => 911, # deprecated - use YIELD CONTINUATION => 911, # deprecated - use YIELD
YIELD => 911, YIELD => 911,
); );
use vars qw(@ISA @EXPORT); use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter); @ISA = qw(Exporter);
@EXPORT = (keys(%return_codes), keys(%log_levels), "return_code", "log_level"); @EXPORT = (keys(%return_codes), keys(%log_levels), "return_code", "log_level");
foreach (keys %return_codes ) { foreach (keys %return_codes) {
eval "use constant $_ => ".$return_codes{$_}; eval "use constant $_ => " . $return_codes{$_};
} }
foreach (keys %log_levels ) { foreach (keys %log_levels) {
eval "use constant $_ => ".$log_levels{$_}; eval "use constant $_ => " . $log_levels{$_};
} }
sub return_code { sub return_code {
my $test = shift; my $test = shift;
if ( $test =~ /^\d+$/ ) { # need to return the textural form if ($test =~ /^\d+$/) { # need to return the textural form
foreach ( keys %return_codes ) { foreach (keys %return_codes) {
return $_ if $return_codes{$_} =~ /$test/; return $_ if $return_codes{$_} =~ /$test/;
} }
} }
else { # just return the numeric value else { # just return the numeric value
return $return_codes{$test}; return $return_codes{$test};
} }
} }
sub log_level { sub log_level {
my $test = shift; my $test = shift;
if ( $test =~ /^\d+$/ ) { # need to return the textural form if ($test =~ /^\d+$/) { # need to return the textural form
foreach ( keys %log_levels ) { foreach (keys %log_levels) {
return $_ if $log_levels{$_} =~ /$test/; return $_ if $log_levels{$_} =~ /$test/;
} }
} }
else { # just return the numeric value else { # just return the numeric value
return $log_levels{$test}; return $log_levels{$test};
} }
} }

234
lib/Qpsmtpd/DSN.pm
View File

@ -48,95 +48,95 @@ than the RFC message.
=cut =cut
my @rfc1893 = ( my @rfc1893 = (
[ [
"Other or Undefined Status", # x.0.x "Other or Undefined Status", # x.0.x
], ],
[ [
"Other address status.", # x.1.0 "Other address status.", # x.1.0
"Bad destination mailbox address.", # x.1.1 "Bad destination mailbox address.", # x.1.1
"Bad destination system address.", # x.1.2 "Bad destination system address.", # x.1.2
"Bad destination mailbox address syntax.", # x.1.3 "Bad destination mailbox address syntax.", # x.1.3
"Destination mailbox address ambiguous.", # x.1.4 "Destination mailbox address ambiguous.", # x.1.4
"Destination address valid.", # x.1.5 "Destination address valid.", # x.1.5
"Destination mailbox has moved, No forwarding address.", # x.1.6 "Destination mailbox has moved, No forwarding address.", # x.1.6
"Bad sender's mailbox address syntax.", # x.1.7 "Bad sender's mailbox address syntax.", # x.1.7
"Bad sender's system address.", # x.1.8 "Bad sender's system address.", # x.1.8
], ],
[ [
"Other or undefined mailbox status.", # x.2.0 "Other or undefined mailbox status.", # x.2.0
"Mailbox disabled, not accepting messages.", # x.2.1 "Mailbox disabled, not accepting messages.", # x.2.1
"Mailbox full.", # x.2.2 "Mailbox full.", # x.2.2
"Message length exceeds administrative limit.", # x.2.3 "Message length exceeds administrative limit.", # x.2.3
"Mailing list expansion problem.", # x.2.4 "Mailing list expansion problem.", # x.2.4
], ],
[ [
"Other or undefined mail system status.", # x.3.0 "Other or undefined mail system status.", # x.3.0
"Mail system full.", # x.3.1 "Mail system full.", # x.3.1
"System not accepting network messages.", # x.3.2 "System not accepting network messages.", # x.3.2
"System not capable of selected features.", # x.3.3 "System not capable of selected features.", # x.3.3
"Message too big for system.", # x.3.4 "Message too big for system.", # x.3.4
"System incorrectly configured.", # x.3.5 "System incorrectly configured.", # x.3.5
],
[
"Other or undefined network or routing status.", # x.4.0
"No answer from host.", # x.4.1
"Bad connection.", # x.4.2
"Directory server failure.", # x.4.3
"Unable to route.", # x.4.4
"Mail system congestion.", # x.4.5
"Routing loop detected.", # x.4.6
"Delivery time expired.", # x.4.7
], ],
[ [
"Other or undefined protocol status.", # x.5.0 "Other or undefined network or routing status.", # x.4.0
"Invalid command.", # x.5.1 "No answer from host.", # x.4.1
"Syntax error.", # x.5.2 "Bad connection.", # x.4.2
"Too many recipients.", # x.5.3 "Directory server failure.", # x.4.3
"Invalid command arguments.", # x.5.4 "Unable to route.", # x.4.4
"Wrong protocol version.", # x.5.5 "Mail system congestion.", # x.4.5
"Routing loop detected.", # x.4.6
"Delivery time expired.", # x.4.7
], ],
[ [
"Other or undefined media error.", # x.6.0 "Other or undefined protocol status.", # x.5.0
"Media not supported.", # x.6.1 "Invalid command.", # x.5.1
"Conversion required and prohibited.", # x.6.2 "Syntax error.", # x.5.2
"Conversion required but not supported.", # x.6.3 "Too many recipients.", # x.5.3
"Conversion with loss performed.", # x.6.4 "Invalid command arguments.", # x.5.4
"Conversion Failed.", # x.6.5 "Wrong protocol version.", # x.5.5
], ],
[ [
"Other or undefined security status.", # x.7.0 "Other or undefined media error.", # x.6.0
"Delivery not authorized, message refused.", # x.7.1 "Media not supported.", # x.6.1
"Mailing list expansion prohibited.", # x.7.2 "Conversion required and prohibited.", # x.6.2
"Security conversion required but not possible.", # x.7.3 "Conversion required but not supported.", # x.6.3
"Security features not supported.", # x.7.4 "Conversion with loss performed.", # x.6.4
"Cryptographic failure.", # x.7.5 "Conversion Failed.", # x.6.5
"Cryptographic algorithm not supported.", # x.7.6 ],
"Message integrity failure.", # x.7.7 [
"Other or undefined security status.", # x.7.0
"Delivery not authorized, message refused.", # x.7.1
"Mailing list expansion prohibited.", # x.7.2
"Security conversion required but not possible.", # x.7.3
"Security features not supported.", # x.7.4
"Cryptographic failure.", # x.7.5
"Cryptographic algorithm not supported.", # x.7.6
"Message integrity failure.", # x.7.7
], ],
); );
sub _status { sub _status {
my $return = shift; my $return = shift;
my $const = Qpsmtpd::Constants::return_code($return); my $const = Qpsmtpd::Constants::return_code($return);
if ($const =~ /^DENYSOFT/) { if ($const =~ /^DENYSOFT/) {
return 4; return 4;
} }
elsif ($const =~ /^DENY/) { elsif ($const =~ /^DENY/) {
return 5; return 5;
} }
elsif ($const eq 'OK' or $const eq 'DONE') { elsif ($const eq 'OK' or $const eq 'DONE') {
return 2; return 2;
} }
else { # err .... no :) else { # err .... no :)
return 4; # just 2,4,5 are allowed.. temp error by default return 4; # just 2,4,5 are allowed.. temp error by default
} }
} }
sub _dsn { sub _dsn {
my ($self,$return,$reason,$default,$subject,$detail) = @_; my ($self, $return, $reason, $default, $subject, $detail) = @_;
if (!defined $return) { if (!defined $return) {
$return = $default; $return = $default;
} }
elsif ($return !~ /^\d+$/) { elsif ($return !~ /^\d+$/) {
$reason = $return; $reason = $return;
$return = $default; $return = $default;
@ -157,7 +157,7 @@ sub _dsn {
return ($return, "$msg (#$class.$subject.$detail)"); 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 =head1 ADDRESS STATUS
@ -170,7 +170,7 @@ default: DENYSOFT
=cut =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 =item no_such_user, addr_bad_dest_mbox
@ -179,8 +179,8 @@ default: DENY
=cut =cut
sub no_such_user { shift->_dsn(shift,(shift||"No such user"),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); } sub addr_bad_dest_mbox { shift->_dsn(shift, shift, DENY, 1, 1); }
=item addr_bad_dest_system =item addr_bad_dest_system
@ -189,7 +189,7 @@ default: DENY
=cut =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 =item addr_bad_dest_syntax
@ -198,7 +198,7 @@ default: DENY
=cut =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 =item addr_dest_ambigous
@ -207,7 +207,7 @@ default: DENYSOFT
=cut =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 =item addr_rcpt_ok
@ -217,7 +217,7 @@ default: OK
=cut =cut
# XXX: do we need this? Maybe in all address verifying plugins? # 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 =item addr_mbox_moved
@ -226,7 +226,7 @@ default: DENY
=cut =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 =item addr_bad_from_syntax
@ -235,7 +235,7 @@ default: DENY
=cut =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 =item addr_bad_from_system
@ -246,7 +246,7 @@ default: DENY
=cut =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 =head1 MAILBOX STATUS
@ -259,7 +259,7 @@ default: DENYSOFT
=cut =cut
sub mbox_unspecified { shift->_dsn(shift,shift,DENYSOFT,2,0); } sub mbox_unspecified { shift->_dsn(shift, shift, DENYSOFT, 2, 0); }
=item mbox_disabled =item mbox_disabled
@ -272,7 +272,7 @@ default: DENY ...but RFC says:
=cut =cut
sub mbox_disabled { shift->_dsn(shift,shift,DENY,2,1); } sub mbox_disabled { shift->_dsn(shift, shift, DENY, 2, 1); }
=item mbox_full =item mbox_full
@ -281,7 +281,7 @@ default: DENYSOFT
=cut =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 =item mbox_msg_too_long
@ -290,7 +290,7 @@ default: DENY
=cut =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 =item mbox_list_expansion_problem
@ -301,7 +301,7 @@ default: DENYSOFT
=cut =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 =head1 MAIL SYSTEM STATUS
@ -314,7 +314,7 @@ default: DENYSOFT
=cut =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 =item sys_disk_full
@ -323,7 +323,7 @@ default: DENYSOFT
=cut =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 =item sys_not_accepting_mail
@ -332,7 +332,7 @@ default: DENYSOFT
=cut =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 =item sys_not_supported
@ -345,7 +345,7 @@ default: DENYSOFT
=cut =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 =item sys_msg_too_big
@ -356,7 +356,7 @@ default DENY
=cut =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 =head1 NETWORK AND ROUTING STATUS
@ -371,10 +371,10 @@ default: DENYSOFT
=cut =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_no_answer { shift->_dsn(shift,shift,4,1); }
# not useful # sub net_bad_connection { shift->_dsn(shift,shift,4,2); } # not useful # sub net_bad_connection { shift->_dsn(shift,shift,4,2); }
=item net_directory_server_failed, temp_resolver_failed =item net_directory_server_failed, temp_resolver_failed
@ -383,12 +383,11 @@ default: DENYSOFT
=cut =cut
sub temp_resolver_failed { sub temp_resolver_failed {
shift->_dsn(shift, shift->_dsn(shift, (shift || "Temporary address resolution failure"),
(shift || "Temporary address resolution failure"), DENYSOFT, 4, 3);
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); } # not useful # sub net_unable_to_route { shift->_dsn(shift,shift,4,4); }
@ -399,7 +398,7 @@ default: DENYSOFT
=cut =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 =item net_routing_loop, too_many_hops
@ -416,8 +415,11 @@ Why do we want to DENYSOFT something like this?
=cut =cut
sub net_routing_loop { shift->_dsn(shift,shift,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,); } 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); } # not useful # sub delivery_time_expired { shift->_dsn(shift,shift,4,7); }
=head1 MAIL DELIVERY PROTOCOL STATUS =head1 MAIL DELIVERY PROTOCOL STATUS
@ -431,7 +433,7 @@ default: DENYSOFT
=cut =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 =item proto_invalid_command
@ -440,7 +442,7 @@ default: DENY
=cut =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 =item proto_syntax_error
@ -449,7 +451,7 @@ default: DENY
=cut =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 =item proto_rcpt_list_too_long, too_many_rcpts
@ -458,8 +460,8 @@ default: DENYSOFT
=cut =cut
sub proto_rcpt_list_too_long { 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); } sub too_many_rcpts { shift->_dsn(shift, shift, DENYSOFT, 5, 3); }
=item proto_invalid_cmd_args =item proto_invalid_cmd_args
@ -468,7 +470,7 @@ default: DENY
=cut =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 =item proto_wrong_version
@ -479,7 +481,7 @@ default: DENYSOFT
=cut =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 =head1 MESSAGE CONTENT OR MESSAGE MEDIA STATUS
@ -492,7 +494,7 @@ default: DENYSOFT
=cut =cut
sub media_unspecified { shift->_dsn(shift,shift,DENYSOFT,6,0); } sub media_unspecified { shift->_dsn(shift, shift, DENYSOFT, 6, 0); }
=item media_unsupported =item media_unsupported
@ -501,7 +503,7 @@ default: DENY
=cut =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 =item media_conv_prohibited
@ -510,7 +512,7 @@ default: DENY
=cut =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 =item media_conv_unsupported
@ -519,7 +521,7 @@ default: DENYSOFT
=cut =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 =item media_conv_lossy
@ -530,7 +532,7 @@ default: DENYSOFT
=cut =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 =head1 SECURITY OR POLICY STATUS
@ -543,7 +545,7 @@ default: DENYSOFT
=cut =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 =item sec_sender_unauthorized, bad_sender_ip, relaying_denied
@ -552,12 +554,14 @@ default: DENY
=cut =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,); sub bad_sender_ip {
shift->_dsn(shift, (shift || "Bad sender's IP"), DENY, 7, 1,);
} }
sub relaying_denied {
shift->_dsn(shift,(shift || "Relaying denied"),DENY,7,1); sub relaying_denied {
shift->_dsn(shift, (shift || "Relaying denied"), DENY, 7, 1);
} }
=item sec_list_dest_prohibited =item sec_list_dest_prohibited
@ -567,7 +571,7 @@ default: DENY
=cut =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 =item sec_conv_failed
@ -576,7 +580,7 @@ default: DENY
=cut =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 =item sec_feature_unsupported
@ -585,7 +589,7 @@ default: DENY
=cut =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 =item sec_crypto_failure
@ -594,7 +598,7 @@ default: DENY
=cut =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 =item sec_crypto_algorithm_unsupported
@ -603,7 +607,9 @@ default: DENYSOFT
=cut =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 =item sec_msg_integrity_failure
@ -614,7 +620,7 @@ default: DENY
=cut =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; 1;

298
lib/Qpsmtpd/Plugin.pm
View File

@ -9,102 +9,107 @@ use Qpsmtpd::Constants;
# more or less in the order they will fire # more or less in the order they will fire
our @hooks = qw( our @hooks = qw(
logging config post-fork pre-connection connect ehlo_parse ehlo logging config post-fork pre-connection connect ehlo_parse ehlo
helo_parse helo auth_parse auth auth-plain auth-login auth-cram-md5 helo_parse helo auth_parse auth auth-plain auth-login auth-cram-md5
rcpt_parse rcpt_pre rcpt mail_parse mail mail_pre rcpt_parse rcpt_pre rcpt mail_parse mail mail_pre
data data_headers_end data_post queue_pre queue queue_post vrfy noop data data_headers_end data_post queue_pre queue queue_post vrfy noop
quit reset_transaction disconnect post-connection quit reset_transaction disconnect post-connection
unrecognized_command deny ok received_line help unrecognized_command deny ok received_line help
); );
our %hooks = map { $_ => 1 } @hooks; our %hooks = map { $_ => 1 } @hooks;
sub new { sub new {
my $proto = shift; my $proto = shift;
my $class = ref($proto) || $proto; my $class = ref($proto) || $proto;
bless ({}, $class); bless({}, $class);
} }
sub hook_name { sub hook_name {
return shift->{_hook}; return shift->{_hook};
} }
sub register_hook { sub register_hook {
my ($plugin, $hook, $method, $unshift) = @_; my ($plugin, $hook, $method, $unshift) = @_;
die $plugin->plugin_name . " : Invalid hook: $hook" unless $hooks{$hook}; die $plugin->plugin_name . " : Invalid hook: $hook" unless $hooks{$hook};
$plugin->{_qp}->log(LOGDEBUG, $plugin->plugin_name, "hooking", $hook) $plugin->{_qp}->log(LOGDEBUG, $plugin->plugin_name, "hooking", $hook)
unless $hook =~ /logging/; # can't log during load_logging() unless $hook =~ /logging/; # can't log during load_logging()
# I can't quite decide if it's better to parse this code ref or if # 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. # we should pass the plugin object and method name ... hmn.
$plugin->qp->_register_hook $plugin->qp->_register_hook(
($hook, $hook,
{ code => sub { local $plugin->{_qp} = shift; {
local $plugin->{_hook} = $hook; code => sub {
$plugin->$method(@_) local $plugin->{_qp} = shift;
}, local $plugin->{_hook} = $hook;
name => $plugin->plugin_name, $plugin->$method(@_);
}, },
$unshift, name => $plugin->plugin_name,
); },
$unshift,
);
} }
sub _register { sub _register {
my $self = shift; my $self = shift;
my $qp = shift; my $qp = shift;
local $self->{_qp} = $qp; local $self->{_qp} = $qp;
$self->init($qp, @_) if $self->can('init'); $self->init($qp, @_) if $self->can('init');
$self->_register_standard_hooks($qp, @_); $self->_register_standard_hooks($qp, @_);
$self->register($qp, @_) if $self->can('register'); $self->register($qp, @_) if $self->can('register');
} }
sub qp { sub qp {
shift->{_qp}; shift->{_qp};
} }
sub log { sub log {
my $self = shift; my $self = shift;
return if defined $self->{_hook} && $self->{_hook} eq 'logging'; 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, @_); $self->{_qp}->varlog($level, $self->{_hook}, $self->plugin_name, @_);
} }
sub adjust_log_level { 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; my $adj = $self->{_args}{loglevel} or return $cur_level;
return $adj if $adj =~ m/^[01234567]$/; # a raw syslog numeral return $adj if $adj =~ m/^[01234567]$/; # a raw syslog numeral
if ( $adj !~ /^[\+\-][\d]$/ ) { if ($adj !~ /^[\+\-][\d]$/) {
$self->log( LOGERROR, $self-"invalid $plugin_name loglevel setting ($adj)" ); $self->log(LOGERROR,
undef $self->{_args}{loglevel}; # only complain once per plugin $self - "invalid $plugin_name loglevel setting ($adj)");
undef $self->{_args}{loglevel}; # only complain once per plugin
return $cur_level; return $cur_level;
}; }
my $operator = substr($adj, 0, 1); my $operator = substr($adj, 0, 1);
my $adjust = substr($adj, -1, 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 = 7 if $new_level > 7;
$new_level = 0 if $new_level < 0; $new_level = 0 if $new_level < 0;
return $new_level; return $new_level;
}; }
sub transaction { sub transaction {
# not sure if this will work in a non-forking or a threaded daemon
shift->qp->transaction; # not sure if this will work in a non-forking or a threaded daemon
shift->qp->transaction;
} }
sub connection { sub connection {
shift->qp->connection; shift->qp->connection;
} }
sub spool_dir { sub spool_dir {
shift->qp->spool_dir; shift->qp->spool_dir;
} }
sub auth_user { sub auth_user {
@ -116,17 +121,17 @@ sub auth_mechanism {
} }
sub temp_file { sub temp_file {
my $self = shift; my $self = shift;
my $tempfile = $self->qp->temp_file; my $tempfile = $self->qp->temp_file;
push @{$self->qp->transaction->{_temp_files}}, $tempfile; push @{$self->qp->transaction->{_temp_files}}, $tempfile;
return $tempfile; return $tempfile;
} }
sub temp_dir { sub temp_dir {
my $self = shift; my $self = shift;
my $tempdir = $self->qp->temp_dir(); my $tempdir = $self->qp->temp_dir();
push @{$self->qp->transaction->{_temp_dirs}}, $tempdir; push @{$self->qp->transaction->{_temp_dirs}}, $tempdir;
return $tempdir; return $tempdir;
} }
# plugin inheritance: # plugin inheritance:
@ -137,32 +142,31 @@ sub temp_dir {
# $self->SUPER::register(@_); # $self->SUPER::register(@_);
# } # }
sub isa_plugin { sub isa_plugin {
my ($self, $parent) = @_; my ($self, $parent) = @_;
my ($currentPackage) = caller; my ($currentPackage) = caller;
my $cleanParent = $parent; my $cleanParent = $parent;
$cleanParent =~ s/\W/_/g; $cleanParent =~ s/\W/_/g;
my $newPackage = $currentPackage."::_isa_$cleanParent"; my $newPackage = $currentPackage . "::_isa_$cleanParent";
# don't reload plugins if they are already loaded # don't reload plugins if they are already loaded
return if defined &{"${newPackage}::plugin_name"}; return if defined &{"${newPackage}::plugin_name"};
# find $parent in plugin_dirs # find $parent in plugin_dirs
my $parent_dir; my $parent_dir;
for ($self->qp->plugin_dirs) { for ($self->qp->plugin_dirs) {
if (-e "$_/$parent") { if (-e "$_/$parent") {
$parent_dir = $_; $parent_dir = $_;
last; last;
}
} }
} die "cannot find plugin '$parent'" unless $parent_dir;
die "cannot find plugin '$parent'" unless $parent_dir;
$self->compile($self->plugin_name . "_isa_$cleanParent", $self->compile($self->plugin_name . "_isa_$cleanParent",
$newPackage, $newPackage, "$parent_dir/$parent");
"$parent_dir/$parent"); warn "---- $newPackage\n";
warn "---- $newPackage\n"; no strict 'refs';
no strict 'refs'; push @{"${currentPackage}::ISA"}, $newPackage;
push @{"${currentPackage}::ISA"}, $newPackage;
} }
# why isn't compile private? it's only called from Plugin and Qpsmtpd. # why isn't compile private? it's only called from Plugin and Qpsmtpd.
@ -172,8 +176,8 @@ sub compile {
my $sub; my $sub;
open F, $file or die "could not open $file: $!"; open F, $file or die "could not open $file: $!";
{ {
local $/ = undef; local $/ = undef;
$sub = <F>; $sub = <F>;
} }
close F; close F;
@ -189,19 +193,19 @@ sub compile {
} }
my $eval = join( my $eval = join(
"\n", "\n",
"package $package;", "package $package;",
'use Qpsmtpd::Constants;', 'use Qpsmtpd::Constants;',
"require Qpsmtpd::Plugin;", "require Qpsmtpd::Plugin;",
'use vars qw(@ISA);', 'use vars qw(@ISA);',
'use strict;', 'use strict;',
'@ISA = qw(Qpsmtpd::Plugin);', '@ISA = qw(Qpsmtpd::Plugin);',
($test_mode ? 'use Test::More;' : ''), ($test_mode ? 'use Test::More;' : ''),
"sub plugin_name { qq[$plugin] }", "sub plugin_name { qq[$plugin] }",
$line, $line,
$sub, $sub,
"\n", # last line comment without newline? "\n", # last line comment without newline?
); );
#warn "eval: $eval"; #warn "eval: $eval";
@ -213,120 +217,126 @@ sub compile {
} }
sub get_reject { sub get_reject {
my $self = shift; my $self = shift;
my $smtp_mess = shift || "why didn't you pass an error message?"; my $smtp_mess = shift || "why didn't you pass an error message?";
my $log_mess = shift || ''; my $log_mess = shift || '';
$log_mess = ", $log_mess" if $log_mess; $log_mess = ", $log_mess" if $log_mess;
my $reject = $self->{_args}{reject}; my $reject = $self->{_args}{reject};
if ( defined $reject && ! $reject ) { if (defined $reject && !$reject) {
$self->log(LOGINFO, "fail, reject disabled" . $log_mess); $self->log(LOGINFO, "fail, reject disabled" . $log_mess);
return DECLINED; return DECLINED;
}; }
# the naughty plugin will reject later # the naughty plugin will reject later
if ( $reject eq 'naughty' ) { if ($reject eq 'naughty') {
$self->log(LOGINFO, "fail, NAUGHTY" . $log_mess); $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 # they asked for reject, we give them reject
$self->log(LOGINFO, "fail" . $log_mess); $self->log(LOGINFO, "fail" . $log_mess);
return ( $self->get_reject_type(), $smtp_mess); return ($self->get_reject_type(), $smtp_mess);
}; }
sub get_reject_type { sub get_reject_type {
my $self = shift; my $self = shift;
my $default = shift || DENY; my $default = shift || DENY;
my $deny = shift || $self->{_args}{reject_type} or return $default; my $deny = shift || $self->{_args}{reject_type} or return $default;
return $deny =~ /^(temp|soft)$/i ? DENYSOFT return
: $deny =~ /^(perm|hard)$/i ? DENY $deny =~ /^(temp|soft)$/i ? DENYSOFT
: $deny eq 'disconnect' ? DENY_DISCONNECT : $deny =~ /^(perm|hard)$/i ? DENY
: $deny eq 'temp_disconnect' ? DENYSOFT_DISCONNECT : $deny eq 'disconnect' ? DENY_DISCONNECT
: $default; : $deny eq 'temp_disconnect' ? DENYSOFT_DISCONNECT
}; : $default;
}
sub store_deferred_reject { sub store_deferred_reject {
my ($self, $smtp_mess) = @_; my ($self, $smtp_mess) = @_;
# store the reject message that the naughty plugin will return later # 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); $self->connection->notes('naughty', $smtp_mess);
} }
else { else {
# append this reject message to the message # append this reject message to the message
my $prev = $self->connection->notes('naughty'); my $prev = $self->connection->notes('naughty');
$self->connection->notes('naughty', "$prev\015\012$smtp_mess"); $self->connection->notes('naughty', "$prev\015\012$smtp_mess");
}; }
if ( ! $self->connection->notes('naughty_reject_type') ) { if (!$self->connection->notes('naughty_reject_type')) {
$self->connection->notes('naughty_reject_type', $self->{_args}{reject_type} ); $self->connection->notes('naughty_reject_type',
$self->{_args}{reject_type});
} }
return (DECLINED); return (DECLINED);
}; }
sub init_resolver { sub init_resolver {
my $self = shift; my $self = shift;
return $self->{_resolver} if $self->{_resolver}; 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); $self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0);
my $timeout = $self->{_args}{dns_timeout} || 5; my $timeout = $self->{_args}{dns_timeout} || 5;
$self->{_resolver}->tcp_timeout($timeout); $self->{_resolver}->tcp_timeout($timeout);
$self->{_resolver}->udp_timeout($timeout); $self->{_resolver}->udp_timeout($timeout);
return $self->{_resolver}; return $self->{_resolver};
}; }
sub is_immune { sub is_immune {
my $self = shift; my $self = shift;
if ( $self->qp->connection->relay_client() ) { if ($self->qp->connection->relay_client()) {
# set by plugins/relay, or Qpsmtpd::Auth # set by plugins/relay, or Qpsmtpd::Auth
$self->log(LOGINFO, "skip, relay client"); $self->log(LOGINFO, "skip, relay client");
return 1; return 1;
}; }
if ( $self->qp->connection->notes('whitelisthost') ) { if ($self->qp->connection->notes('whitelisthost')) {
# set by plugins/dns_whitelist_soft or plugins/whitelist # set by plugins/dns_whitelist_soft or plugins/whitelist
$self->log(LOGINFO, "skip, whitelisted host"); $self->log(LOGINFO, "skip, whitelisted host");
return 1; return 1;
}; }
if ( $self->qp->transaction->notes('whitelistsender') ) { if ($self->qp->transaction->notes('whitelistsender')) {
# set by plugins/whitelist # set by plugins/whitelist
$self->log(LOGINFO, "skip, whitelisted sender"); $self->log(LOGINFO, "skip, whitelisted sender");
return 1; return 1;
}; }
if ( $self->connection->notes('naughty') ) { if ($self->connection->notes('naughty')) {
# see plugins/naughty # see plugins/naughty
$self->log(LOGINFO, "skip, naughty"); $self->log(LOGINFO, "skip, naughty");
return 1; return 1;
}; }
if ( $self->connection->notes('rejected') ) { if ($self->connection->notes('rejected')) {
# http://www.steve.org.uk/Software/ms-lite/ # http://www.steve.org.uk/Software/ms-lite/
$self->log(LOGINFO, "skip, already rejected"); $self->log(LOGINFO, "skip, already rejected");
return 1; return 1;
}; }
return; return;
}; }
sub adjust_karma { sub adjust_karma {
my ( $self, $value ) = @_; my ($self, $value) = @_;
my $karma = $self->connection->notes('karma') || 0; my $karma = $self->connection->notes('karma') || 0;
$karma += $value; $karma += $value;
$self->log(LOGDEBUG, "karma adjust: $value ($karma)"); $self->log(LOGDEBUG, "karma adjust: $value ($karma)");
$self->connection->notes('karma', $karma); $self->connection->notes('karma', $karma);
return $value; return $value;
};
sub _register_standard_hooks {
my ($plugin, $qp) = @_;
for my $hook (@hooks) {
my $hooksub = "hook_$hook";
$hooksub =~ s/\W/_/g;
$plugin->register_hook( $hook, $hooksub )
if ($plugin->can($hooksub));
}
} }
sub _register_standard_hooks {
my ($plugin, $qp) = @_;
for my $hook (@hooks) {
my $hooksub = "hook_$hook";
$hooksub =~ s/\W/_/g;
$plugin->register_hook($hook, $hooksub)
if ($plugin->can($hooksub));
}
}
1; 1;

224
lib/Qpsmtpd/PollServer.pm
View File

@ -1,32 +1,33 @@
package Qpsmtpd::PollServer; package Qpsmtpd::PollServer;
use base ('Danga::Client', 'Qpsmtpd::SMTP'); use base ('Danga::Client', 'Qpsmtpd::SMTP');
# use fields required to be a subclass of Danga::Client. Have to include # use fields required to be a subclass of Danga::Client. Have to include
# all fields used by Qpsmtpd.pm here too. # all fields used by Qpsmtpd.pm here too.
use fields qw( use fields qw(
input_sock input_sock
mode mode
header_lines header_lines
in_header in_header
data_size data_size
max_size max_size
hooks hooks
start_time start_time
cmd_timeout cmd_timeout
conn conn
_auth _auth
_auth_mechanism _auth_mechanism
_auth_state _auth_state
_auth_ticket _auth_ticket
_auth_user _auth_user
_commands _commands
_config_cache _config_cache
_connection _connection
_continuation _continuation
_extras _extras
_test_mode _test_mode
_transaction _transaction
); );
use Qpsmtpd::Constants; use Qpsmtpd::Constants;
use Qpsmtpd::Address; use Qpsmtpd::Address;
use ParaDNS; use ParaDNS;
@ -36,7 +37,7 @@ use Socket qw(inet_aton AF_INET CRLF);
use Time::HiRes qw(time); use Time::HiRes qw(time);
use strict; use strict;
sub max_idle_time { 60 } sub max_idle_time { 60 }
sub max_connect_time { 1200 } sub max_connect_time { 1200 }
sub input_sock { sub input_sock {
@ -47,12 +48,12 @@ sub input_sock {
sub new { sub new {
my Qpsmtpd::PollServer $self = shift; my Qpsmtpd::PollServer $self = shift;
$self = fields::new($self) unless ref $self; $self = fields::new($self) unless ref $self;
$self->SUPER::new( @_ ); $self->SUPER::new(@_);
$self->{cmd_timeout} = 5; $self->{cmd_timeout} = 5;
$self->{start_time} = time; $self->{start_time} = time;
$self->{mode} = 'connect'; $self->{mode} = 'connect';
$self->load_plugins; $self->load_plugins;
$self->load_logging; $self->load_logging;
@ -75,28 +76,28 @@ sub new {
sub uptime { sub uptime {
my Qpsmtpd::PollServer $self = shift; my Qpsmtpd::PollServer $self = shift;
return (time() - $self->{start_time}); return (time() - $self->{start_time});
} }
sub reset_for_next_message { sub reset_for_next_message {
my Qpsmtpd::PollServer $self = shift; my Qpsmtpd::PollServer $self = shift;
$self->SUPER::reset_for_next_message(@_); $self->SUPER::reset_for_next_message(@_);
$self->{_commands} = { $self->{_commands} = {
ehlo => 1, ehlo => 1,
helo => 1, helo => 1,
rset => 1, rset => 1,
mail => 1, mail => 1,
rcpt => 1, rcpt => 1,
data => 1, data => 1,
help => 1, help => 1,
vrfy => 1, vrfy => 1,
noop => 1, noop => 1,
quit => 1, quit => 1,
auth => 0, # disabled by default auth => 0, # disabled by default
}; };
$self->{mode} = 'cmd'; $self->{mode} = 'cmd';
$self->{_extras} = {}; $self->{_extras} = {};
} }
@ -121,17 +122,18 @@ my %cmd_cache;
sub process_line { sub process_line {
my Qpsmtpd::PollServer $self = shift; my Qpsmtpd::PollServer $self = shift;
my $line = shift || return; 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') { if ($self->{mode} eq 'cmd') {
$line =~ s/\r?\n$//s; $line =~ s/\r?\n$//s;
$self->connection->notes('original_string', $line); $self->connection->notes('original_string', $line);
my ($cmd, @params) = split(/ +/, $line, 2); my ($cmd, @params) = split(/ +/, $line, 2);
my $meth = lc($cmd); 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; $cmd_cache{$meth} = $lookup;
eval { eval { $lookup->($self, @params); };
$lookup->($self, @params);
};
if ($@) { if ($@) {
my $error = $@; my $error = $@;
chomp($error); chomp($error);
@ -141,11 +143,13 @@ sub process_line {
} }
else { else {
# No such method - i.e. unrecognized command # 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') { elsif ($self->{mode} eq 'connect') {
$self->{mode} = 'cmd'; $self->{mode} = 'cmd';
# I've removed an eval{} from around this. It shouldn't ever die() # I've removed an eval{} from around this. It shouldn't ever die()
# but if it does we're a bit screwed... Ah well :-) # but if it does we're a bit screwed... Ah well :-)
$self->start_conversation; $self->start_conversation;
@ -171,31 +175,33 @@ sub close {
sub start_conversation { sub start_conversation {
my Qpsmtpd::PollServer $self = shift; my Qpsmtpd::PollServer $self = shift;
my $conn = $self->connection; my $conn = $self->connection;
# set remote_host, remote_ip and remote_port # set remote_host, remote_ip and remote_port
my ($ip, $port) = split(/:/, $self->peer_addr_string); my ($ip, $port) = split(/:/, $self->peer_addr_string);
return $self->close() unless $ip; return $self->close() unless $ip;
$conn->remote_ip($ip); $conn->remote_ip($ip);
$conn->remote_port($port); $conn->remote_port($port);
$conn->remote_info("[$ip]"); $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_ip($lip);
$conn->local_port($lport); $conn->local_port($lport);
ParaDNS->new( ParaDNS->new(
finished => sub { $self->continue_read(); $self->run_hooks("connect") }, finished => sub { $self->continue_read(); $self->run_hooks("connect") },
# NB: Setting remote_info to the same as remote_host # NB: Setting remote_info to the same as remote_host
callback => sub { $conn->remote_info($conn->remote_host($_[0])) }, callback => sub { $conn->remote_info($conn->remote_host($_[0])) },
host => $ip, host => $ip,
); );
return; return;
} }
sub data { sub data {
my Qpsmtpd::PollServer $self = shift; my Qpsmtpd::PollServer $self = shift;
my ($rc, $msg) = $self->run_hooks("data"); my ($rc, $msg) = $self->run_hooks("data");
return 1; return 1;
} }
@ -217,7 +223,7 @@ sub data_respond {
$self->respond(451, @$msg); $self->respond(451, @$msg);
$self->reset_transaction(); $self->reset_transaction();
return; return;
} }
elsif ($rc == DENY_DISCONNECT) { elsif ($rc == DENY_DISCONNECT) {
$msg->[0] ||= "Message denied"; $msg->[0] ||= "Message denied";
$self->respond(554, @$msg); $self->respond(554, @$msg);
@ -231,14 +237,16 @@ sub data_respond {
return; return;
} }
return $self->respond(503, "MAIL first") unless $self->transaction->sender; 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->{header_lines} = '';
$self->{data_size} = 0; $self->{data_size} = 0;
$self->{in_header} = 1; $self->{in_header} = 1;
$self->{max_size} = ($self->config('databytes'))[0] || 0; $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"); $self->respond(354, "go ahead");
@ -255,42 +263,47 @@ sub got_data {
my $remainder; my $remainder;
if ($data =~ s/^\.\r\n(.*)\z//ms) { if ($data =~ s/^\.\r\n(.*)\z//ms) {
$remainder = $1; $remainder = $1;
$done = 1; $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})) { unless (($self->{max_size} and $self->{data_size} > $self->{max_size})) {
$data =~ s/\r\n/\n/mg; $data =~ s/\r\n/\n/mg;
$data =~ s/^\.\./\./mg; $data =~ s/^\.\./\./mg;
if ($self->{in_header}) { if ($self->{in_header}) {
$self->{header_lines} .= $data; $self->{header_lines} .= $data;
if ($self->{header_lines} =~ s/\n(\n.*)\z/\n/ms) { if ($self->{header_lines} =~ s/\n(\n.*)\z/\n/ms) {
$data = $1; $data = $1;
# end of headers # end of headers
$self->{in_header} = 0; $self->{in_header} = 0;
# ... need to check that we don't reformat any of the received lines. # ... need to check that we don't reformat any of the received lines.
# #
# 3.8.2 Received Lines in Gatewaying # 3.8.2 Received Lines in Gatewaying
# When forwarding a message into or out of the Internet environment, a # When forwarding a message into or out of the Internet environment, a
# gateway MUST prepend a Received: line, but it MUST NOT alter in any # gateway MUST prepend a Received: line, but it MUST NOT alter in any
# way a Received: line that is already in the header. # way a Received: line that is already in the header.
my @header_lines = split(/^/m, $self->{header_lines}); my @header_lines = split(/^/m, $self->{header_lines});
my $header = Mail::Header->new(\@header_lines, my $header =
Modify => 0, MailFrom => "COERCE"); Mail::Header->new(
\@header_lines,
Modify => 0,
MailFrom => "COERCE"
);
$self->transaction->header($header); $self->transaction->header($header);
$self->transaction->body_write($self->{header_lines}); $self->transaction->body_write($self->{header_lines});
$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 # FIXME - call plugins to work on just the header here; can
# save us buffering the mail content. # save us buffering the mail content.
# Save the start of just the body itself # Save the start of just the body itself
$self->transaction->set_body_start(); $self->transaction->set_body_start();
} }
} }
@ -298,7 +311,6 @@ sub got_data {
$self->transaction->body_write(\$data); $self->transaction->body_write(\$data);
$self->{data_size} += length $data; $self->{data_size} += length $data;
} }
if ($done) { if ($done) {
$self->end_of_data; $self->end_of_data;
@ -309,38 +321,44 @@ sub got_data {
sub end_of_data { sub end_of_data {
my Qpsmtpd::PollServer $self = shift; my Qpsmtpd::PollServer $self = shift;
#$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); #$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; my $header = $self->transaction->header;
if (!$header) { if (!$header) {
$header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE");
$self->transaction->header($header); $self->transaction->header($header);
} }
my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; 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 $authheader;
my $sslheader; my $sslheader;
if (defined $self->connection->notes('tls_enabled') if (defined $self->connection->notes('tls_enabled')
and $self->connection->notes('tls_enabled')) and $self->connection->notes('tls_enabled'))
{ {
$smtp .= "S" if $esmtp; # RFC3848 $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) { if (defined $self->{_auth} and $self->{_auth} == OK) {
$smtp .= "A" if $esmtp; # RFC3848 $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"); my ($rc, $msg) = $self->run_hooks("data_post");
return 1; return 1;
} }

275
lib/Qpsmtpd/Postfix.pm
View File

@ -21,125 +21,131 @@ use vars qw(@ISA);
my %rec_types; my %rec_types;
sub init { sub init {
my ($self) = @_; my ($self) = @_;
%rec_types = ( %rec_types = (
REC_TYPE_SIZE => 'C', # first record, created by cleanup REC_TYPE_SIZE => 'C', # first record, created by cleanup
REC_TYPE_TIME => 'T', # time stamp, required REC_TYPE_TIME => 'T', # time stamp, required
REC_TYPE_FULL => 'F', # full name, optional REC_TYPE_FULL => 'F', # full name, optional
REC_TYPE_INSP => 'I', # inspector transport REC_TYPE_INSP => 'I', # inspector transport
REC_TYPE_FILT => 'L', # loop filter transport REC_TYPE_FILT => 'L', # loop filter transport
REC_TYPE_FROM => 'S', # sender, required REC_TYPE_FROM => 'S', # sender, required
REC_TYPE_DONE => 'D', # delivered recipient, optional REC_TYPE_DONE => 'D', # delivered recipient, optional
REC_TYPE_RCPT => 'R', # todo recipient, optional REC_TYPE_RCPT => 'R', # todo recipient, optional
REC_TYPE_ORCP => 'O', # original recipient, optional REC_TYPE_ORCP => 'O', # original recipient, optional
REC_TYPE_WARN => 'W', # warning message time REC_TYPE_WARN => 'W', # warning message time
REC_TYPE_ATTR => 'A', # named attribute for extensions REC_TYPE_ATTR => 'A', # named attribute for extensions
REC_TYPE_MESG => 'M', # start message records REC_TYPE_MESG => 'M', # start message records
REC_TYPE_CONT => 'L', # long data record REC_TYPE_CONT => 'L', # long data record
REC_TYPE_NORM => 'N', # normal data record REC_TYPE_NORM => 'N', # normal data record
REC_TYPE_XTRA => 'X', # start extracted records REC_TYPE_XTRA => 'X', # start extracted records
REC_TYPE_RRTO => 'r', # return-receipt, from headers REC_TYPE_RRTO => 'r', # return-receipt, from headers
REC_TYPE_ERTO => 'e', # errors-to, from headers REC_TYPE_ERTO => 'e', # errors-to, from headers
REC_TYPE_PRIO => 'P', # priority REC_TYPE_PRIO => 'P', # priority
REC_TYPE_VERP => 'V', # VERP delimiters REC_TYPE_VERP => 'V', # VERP delimiters
REC_TYPE_END => 'E', # terminator, required REC_TYPE_END => 'E', # terminator, required
); );
} }
sub print_rec { sub print_rec {
my ($self, $type, @list) = @_; my ($self, $type, @list) = @_;
die "unknown record type" unless ($rec_types{$type}); die "unknown record type" unless ($rec_types{$type});
$self->print($rec_types{$type}); $self->print($rec_types{$type});
# the length is a little endian base-128 number where each # the length is a little endian base-128 number where each
# byte except the last has the high bit set: # byte except the last has the high bit set:
my $s = "@list"; my $s = "@list";
my $ln = length($s); my $ln = length($s);
while ($ln >= 0x80) { while ($ln >= 0x80) {
my $lnl = $ln & 0x7F; my $lnl = $ln & 0x7F;
$ln >>= 7; $ln >>= 7;
$self->print(chr($lnl | 0x80)); $self->print(chr($lnl | 0x80));
} }
$self->print(chr($ln)); $self->print(chr($ln));
$self->print($s); $self->print($s);
} }
sub print_rec_size { sub print_rec_size {
my ($self, $content_size, $data_offset, $rcpt_count) = @_; my ($self, $content_size, $data_offset, $rcpt_count) = @_;
my $s = sprintf("%15ld %15ld %15ld", $content_size, $data_offset, $rcpt_count); my $s =
$self->print_rec('REC_TYPE_SIZE', $s); sprintf("%15ld %15ld %15ld", $content_size, $data_offset, $rcpt_count);
$self->print_rec('REC_TYPE_SIZE', $s);
} }
sub print_rec_time { sub print_rec_time {
my ($self, $time) = @_; my ($self, $time) = @_;
$time = time() unless (defined($time)); $time = time() unless (defined($time));
my $s = sprintf("%d", $time); my $s = sprintf("%d", $time);
$self->print_rec('REC_TYPE_TIME', $s); $self->print_rec('REC_TYPE_TIME', $s);
} }
sub open_cleanup { sub open_cleanup {
my ($class, $socket) = @_; my ($class, $socket) = @_;
my $self; my $self;
if ($socket =~ m#^(/.+)#) { if ($socket =~ m#^(/.+)#) {
$socket = $1; # un-taint socket path $socket = $1; # un-taint socket path
$self = IO::Socket::UNIX->new(Type => SOCK_STREAM, $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', elsif ($socket =~ /(.*):(\d+)/) {
PeerAddr => $host,PeerPort => $port) my ($host, $port) = ($1, $2); # un-taint address and port
if $host and $port; $self = IO::Socket::INET->new(
} Proto => 'tcp',
unless (ref $self) { PeerAddr => $host,
warn "Couldn't open \"$socket\": $!"; PeerPort => $port
return; )
} if $host and $port;
# allow buffered writes }
$self->autoflush(0); unless (ref $self) {
bless ($self, $class); warn "Couldn't open \"$socket\": $!";
$self->init(); return;
return $self; }
# allow buffered writes
$self->autoflush(0);
bless($self, $class);
$self->init();
return $self;
} }
sub print_attr { sub print_attr {
my ($self, @kv) = @_; my ($self, @kv) = @_;
for (@kv) { for (@kv) {
$self->print("$_\0"); $self->print("$_\0");
} }
$self->print("\0"); $self->print("\0");
} }
sub get_attr { sub get_attr {
my ($self) = @_; my ($self) = @_;
local $/ = "\0"; local $/ = "\0";
my %kv; my %kv;
for(;;) { for (; ;) {
my $k = $self->getline; my $k = $self->getline;
chomp($k); chomp($k);
last unless ($k); last unless ($k);
my $v = $self->getline; my $v = $self->getline;
chomp($v); chomp($v);
$kv{$k} = $v; $kv{$k} = $v;
} }
return %kv; return %kv;
} }
=head2 print_msg_line($line) =head2 print_msg_line($line)
print one line of a message to cleanup. print one line of a message to cleanup.
@ -151,17 +157,17 @@ and splits the line across several records if it is longer than
=cut =cut
sub print_msg_line { sub print_msg_line {
my ($self, $line) = @_; my ($self, $line) = @_;
$line =~ s/\r?\n$//s; $line =~ s/\r?\n$//s;
# split into 1k chunks. # split into 1k chunks.
while (length($line) > 1024) { while (length($line) > 1024) {
my $s = substr($line, 0, 1024); my $s = substr($line, 0, 1024);
$line = substr($line, 1024); $line = substr($line, 1024);
$self->print_rec('REC_TYPE_CONT', $s); $self->print_rec('REC_TYPE_CONT', $s);
} }
$self->print_rec('REC_TYPE_NORM', $line); $self->print_rec('REC_TYPE_NORM', $line);
} }
=head2 inject_mail($transaction) =head2 inject_mail($transaction)
@ -172,52 +178,55 @@ $transaction is supposed to be a Qpsmtpd::Transaction object.
=cut =cut
sub inject_mail { sub inject_mail {
my ($class, $transaction) = @_; my ($class, $transaction) = @_;
my @sockets = @{$transaction->notes('postfix-queue-sockets') my @sockets = @{$transaction->notes('postfix-queue-sockets')
// ['/var/spool/postfix/public/cleanup']}; // ['/var/spool/postfix/public/cleanup']};
my $strm; my $strm;
$strm = $class->open_cleanup($_) and last for @sockets; $strm = $class->open_cleanup($_) and last for @sockets;
die "Unable to open any cleanup sockets!" unless $strm; die "Unable to open any cleanup sockets!" unless $strm;
my %at = $strm->get_attr; my %at = $strm->get_attr;
my $qid = $at{queue_id}; my $qid = $at{queue_id};
print STDERR "qid=$qid\n"; print STDERR "qid=$qid\n";
$strm->print_attr('flags' => $transaction->notes('postfix-queue-flags')); $strm->print_attr('flags' => $transaction->notes('postfix-queue-flags'));
$strm->print_rec_time(); $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) { for (map { $_->address } $transaction->recipients) {
$strm->print_rec('REC_TYPE_RCPT', $_); $strm->print_rec('REC_TYPE_RCPT', $_);
} }
# add an empty message length record.
# cleanup is supposed to understand that.
# see src/pickup/pickup.c
$strm->print_rec('REC_TYPE_MESG', "");
# a received header has already been added in SMTP.pm # add an empty message length record.
# so we can just copy the message: # cleanup is supposed to understand that.
# see src/pickup/pickup.c
$strm->print_rec('REC_TYPE_MESG', "");
my $hdr = $transaction->header->as_string; # a received header has already been added in SMTP.pm
for (split(/\r?\n/, $hdr)) { # so we can just copy the message:
print STDERR "hdr: $_\n";
$strm->print_msg_line($_);
}
$transaction->body_resetpos;
while (my $line = $transaction->body_getline) {
# print STDERR "body: $line\n";
$strm->print_msg_line($line);
}
# finish it. my $hdr = $transaction->header->as_string;
$strm->print_rec('REC_TYPE_XTRA', ""); for (split(/\r?\n/, $hdr)) {
$strm->print_rec('REC_TYPE_END', ""); print STDERR "hdr: $_\n";
$strm->flush(); $strm->print_msg_line($_);
%at = $strm->get_attr; }
my $status = $at{status}; $transaction->body_resetpos;
my $reason = $at{reason}; while (my $line = $transaction->body_getline) {
$strm->close();
return wantarray ? ($status, $qid, $reason || "") : $status; # print STDERR "body: $line\n";
$strm->print_msg_line($line);
}
# finish it.
$strm->print_rec('REC_TYPE_XTRA', "");
$strm->print_rec('REC_TYPE_END', "");
$strm->flush();
%at = $strm->get_attr;
my $status = $at{status};
my $reason = $at{reason};
$strm->close();
return wantarray ? ($status, $qid, $reason || "") : $status;
} }
1; 1;
# vim:sw=2 # vim:sw=2

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

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

1197
lib/Qpsmtpd/SMTP.pm
View File

File diff suppressed because it is too large Load Diff

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

@ -4,27 +4,28 @@ use Qpsmtpd::Constants;
@ISA = qw(Qpsmtpd::SMTP); @ISA = qw(Qpsmtpd::SMTP);
sub dispatch { sub dispatch {
my $self = shift; my $self = shift;
my ($cmd) = lc shift; my ($cmd) = lc shift;
$self->{_counter}++; $self->{_counter}++;
if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) {
$self->run_hooks("unrecognized_command", $cmd, @_); $self->run_hooks("unrecognized_command", $cmd, @_);
return 1; return 1;
}
$cmd = $1;
if (1 or $self->{_commands}->{$cmd} and $self->can($cmd)) {
my ($result) = eval { $self->$cmd(@_) };
if ($@ =~ /^disconnect_tcpserver/) {
die "disconnect_tcpserver";
} elsif ($@) {
$self->log(LOGERROR, "XX: $@") if $@;
} }
return $result if defined $result; $cmd = $1;
return $self->fault("command '$cmd' failed unexpectedly");
}
return; if (1 or $self->{_commands}->{$cmd} and $self->can($cmd)) {
my ($result) = eval { $self->$cmd(@_) };
if ($@ =~ /^disconnect_tcpserver/) {
die "disconnect_tcpserver";
}
elsif ($@) {
$self->log(LOGERROR, "XX: $@") if $@;
}
return $result if defined $result;
return $self->fault("command '$cmd' failed unexpectedly");
}
return;
} }

205
lib/Qpsmtpd/TcpServer.pm
View File

@ -10,12 +10,15 @@ use POSIX ();
my $has_ipv6 = 0; my $has_ipv6 = 0;
if ( if (
eval {require Socket6;} && eval { require Socket6; }
&&
# INET6 prior to 2.01 will not work; sorry. # 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)); Socket6->import(qw(inet_ntop));
$has_ipv6=1; $has_ipv6 = 1;
} }
sub has_ipv6 { sub has_ipv6 {
@ -33,25 +36,31 @@ sub start_connection {
); );
if ($ENV{TCPREMOTEIP}) { if ($ENV{TCPREMOTEIP}) {
# started from tcpserver (or some other superserver which
# exports the TCPREMOTE* variables. # started from tcpserver (or some other superserver which
$remote_ip = $ENV{TCPREMOTEIP}; # exports the TCPREMOTE* variables.
$remote_host = $ENV{TCPREMOTEHOST} || "[$remote_ip]"; $remote_ip = $ENV{TCPREMOTEIP};
$remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host; $remote_host = $ENV{TCPREMOTEHOST} || "[$remote_ip]";
$remote_info =
$ENV{TCPREMOTEINFO}
? "$ENV{TCPREMOTEINFO}\@$remote_host"
: $remote_host;
$remote_port = $ENV{TCPREMOTEPORT}; $remote_port = $ENV{TCPREMOTEPORT};
$local_ip = $ENV{TCPLOCALIP}; $local_ip = $ENV{TCPLOCALIP};
$local_port = $ENV{TCPLOCALPORT}; $local_port = $ENV{TCPLOCALPORT};
$local_host = $ENV{TCPLOCALHOST}; $local_host = $ENV{TCPLOCALHOST};
} else { }
# Started from inetd or similar. else {
# get info on the remote host from the socket. # Started from inetd or similar.
# ignore ident/tap/... # get info on the remote host from the socket.
my $hersockaddr = getpeername(STDIN) # ignore ident/tap/...
or die "getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin"; my $hersockaddr = getpeername(STDIN)
my ($port, $iaddr) = sockaddr_in($hersockaddr); or die
$remote_ip = inet_ntoa($iaddr); "getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin";
$remote_host = gethostbyaddr($iaddr, AF_INET) || "[$remote_ip]"; my ($port, $iaddr) = sockaddr_in($hersockaddr);
$remote_info = $remote_host; $remote_ip = inet_ntoa($iaddr);
$remote_host = gethostbyaddr($iaddr, AF_INET) || "[$remote_ip]";
$remote_info = $remote_host;
} }
$self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]"); $self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]");
@ -64,20 +73,22 @@ sub start_connection {
my $now = POSIX::strftime("%H:%M:%S %Y-%m-%d", localtime); my $now = POSIX::strftime("%H:%M:%S %Y-%m-%d", localtime);
$0 = "$first_0 [$remote_ip : $remote_host : $now]"; $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_ip => $remote_ip,
remote_host => $remote_host, remote_host => $remote_host,
remote_port => $remote_port, remote_port => $remote_port,
local_ip => $local_ip, local_ip => $local_ip,
local_port => $local_port, local_port => $local_port,
local_host => $local_host, local_host => $local_host,
@_); @_
);
} }
sub run { sub run {
my ($self, $client) = @_; 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->{__client_socket} = $client;
$self->load_plugins unless $self->{hooks}; $self->load_plugins unless $self->{hooks};
@ -85,107 +96,121 @@ sub run {
my $rc = $self->start_conversation; my $rc = $self->start_conversation;
return if $rc != DONE; 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; $self->read_input;
} }
sub read_input { sub read_input {
my $self = shift; my $self = shift;
my $timeout = my $timeout = $self->config('timeoutsmtpd') # qmail smtpd control file
$self->config('timeoutsmtpd') # qmail smtpd control file || $self->config('timeout') # qpsmtpd control file
|| $self->config('timeout') # qpsmtpd control file || 1200; # default value
|| 1200; # default value
alarm $timeout;
while (<STDIN>) {
alarm 0;
$_ =~ s/\r?\n$//s; # advanced chomp
$self->log(LOGINFO, "dispatching $_");
$self->connection->notes('original_string', $_);
defined $self->dispatch(split / +/, $_, 2)
or $self->respond(502, "command unrecognized: '$_'");
alarm $timeout; alarm $timeout;
} while (<STDIN>) {
alarm(0); alarm 0;
return if $self->connection->notes('disconnected'); $_ =~ s/\r?\n$//s; # advanced chomp
$self->reset_transaction; $self->log(LOGINFO, "dispatching $_");
$self->run_hooks('disconnect'); $self->connection->notes('original_string', $_);
$self->connection->notes(disconnected => 1); defined $self->dispatch(split / +/, $_, 2)
or $self->respond(502, "command unrecognized: '$_'");
alarm $timeout;
}
alarm(0);
return if $self->connection->notes('disconnected');
$self->reset_transaction;
$self->run_hooks('disconnect');
$self->connection->notes(disconnected => 1);
} }
sub respond { sub respond {
my ($self, $code, @messages) = @_; my ($self, $code, @messages) = @_;
my $buf = ''; my $buf = '';
if ( !$self->check_socket() ) { if (!$self->check_socket()) {
$self->log(LOGERROR, "Lost connection to client, cannot send response."); $self->log(LOGERROR,
return(0); "Lost connection to client, cannot send response.");
} return (0);
}
while (my $msg = shift @messages) { while (my $msg = shift @messages) {
my $line = $code . (@messages?"-":" ").$msg; my $line = $code . (@messages ? "-" : " ") . $msg;
$self->log(LOGINFO, $line); $self->log(LOGINFO, $line);
$buf .= "$line\r\n"; $buf .= "$line\r\n";
} }
print $buf or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0); print $buf
return 1; or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0);
return 1;
} }
sub disconnect { sub disconnect {
my $self = shift; my $self = shift;
$self->log(LOGINFO,"click, disconnecting"); $self->log(LOGINFO, "click, disconnecting");
$self->SUPER::disconnect(@_); $self->SUPER::disconnect(@_);
$self->run_hooks("post-connection"); $self->run_hooks("post-connection");
$self->connection->reset; $self->connection->reset;
exit; exit;
} }
# local/remote port and ip address # local/remote port and ip address
sub lrpip { sub lrpip {
my ($server, $client, $hisaddr) = @_; my ($server, $client, $hisaddr) = @_;
my ($port, $iaddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($hisaddr)) : (sockaddr_in6($hisaddr)); my ($port, $iaddr) =
my $localsockaddr = getsockname($client); ($server->sockdomain == AF_INET)
my ($lport, $laddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($localsockaddr)) : (sockaddr_in6($localsockaddr)); ? (sockaddr_in($hisaddr))
: (sockaddr_in6($hisaddr));
my $localsockaddr = getsockname($client);
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_iaddr =
my $nto_laddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($laddr)) : (inet_ntop(AF_INET6(), $laddr)); ($server->sockdomain == AF_INET)
$nto_iaddr =~ s/::ffff://; ? (inet_ntoa($iaddr))
$nto_laddr =~ s/::ffff://; : (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://;
return ($port, $iaddr, $lport, $laddr, $nto_iaddr, $nto_laddr); return ($port, $iaddr, $lport, $laddr, $nto_iaddr, $nto_laddr);
} }
sub tcpenv { sub tcpenv {
my ($nto_laddr, $nto_iaddr, $no_rdns) = @_; my ($nto_laddr, $nto_iaddr, $no_rdns) = @_;
my $TCPLOCALIP = $nto_laddr; my $TCPLOCALIP = $nto_laddr;
my $TCPREMOTEIP = $nto_iaddr; my $TCPREMOTEIP = $nto_iaddr;
if ($no_rdns) { 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) {
foreach my $rr ($query->answer) {
next unless $rr->type eq "PTR";
$TCPREMOTEHOST = $rr->ptrdname;
} }
} my $res = new Net::DNS::Resolver;
return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || "Unknown"); $res->tcp_timeout(3);
$res->udp_timeout(3);
my $query = $res->query($nto_iaddr);
my $TCPREMOTEHOST;
if ($query) {
foreach my $rr ($query->answer) {
next unless $rr->type eq "PTR";
$TCPREMOTEHOST = $rr->ptrdname;
}
}
return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || "Unknown");
} }
sub check_socket() { sub check_socket() {
my $self = shift; my $self = shift;
return 1 if ( $self->{__client_socket}->connected ); return 1 if ($self->{__client_socket}->connected);
return 0; return 0;
} }
1; 1;

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

@ -5,75 +5,77 @@ use Qpsmtpd::Constants;
@ISA = qw(Qpsmtpd::SMTP::Prefork Qpsmtpd::TcpServer); @ISA = qw(Qpsmtpd::SMTP::Prefork Qpsmtpd::TcpServer);
my $first_0; my $first_0;
sub start_connection { sub start_connection {
my $self = shift; my $self = shift;
#reset info #reset info
$self->{_connection} = Qpsmtpd::Connection->new(); #reset connection $self->{_connection} = Qpsmtpd::Connection->new(); #reset connection
$self->reset_transaction; $self->reset_transaction;
$self->SUPER::start_connection(@_); $self->SUPER::start_connection(@_);
} }
sub read_input { sub read_input {
my $self = shift; my $self = shift;
my $timeout = my $timeout = $self->config('timeoutsmtpd') # qmail smtpd control file
$self->config('timeoutsmtpd') # qmail smtpd control file || $self->config('timeout') # qpsmtpd control file
|| $self->config('timeout') # qpsmtpd control file || 1200; # default value
|| 1200; # default value
alarm $timeout; alarm $timeout;
eval { eval {
while (<STDIN>) { while (<STDIN>) {
alarm 0; alarm 0;
$_ =~ s/\r?\n$//s; # advanced chomp $_ =~ s/\r?\n$//s; # advanced chomp
$self->log(LOGINFO, "dispatching $_"); $self->log(LOGINFO, "dispatching $_");
$self->connection->notes('original_string', $_); $self->connection->notes('original_string', $_);
defined $self->dispatch(split / +/, $_, 2) defined $self->dispatch(split / +/, $_, 2)
or $self->respond(502, "command unrecognized: '$_'"); or $self->respond(502, "command unrecognized: '$_'");
alarm $timeout; alarm $timeout;
}
unless ($self->connection->notes('disconnected')) {
$self->reset_transaction;
$self->run_hooks('disconnect');
$self->connection->notes(disconnected => 1);
}
};
if ($@ =~ /^disconnect_tcpserver/) {
die "disconnect_tcpserver";
} }
unless ($self->connection->notes('disconnected')) { else {
$self->reset_transaction; $self->run_hooks("post-connection");
$self->run_hooks('disconnect'); $self->connection->reset;
$self->connection->notes(disconnected => 1); die "died while reading from STDIN (probably broken sender) - $@";
} }
}; alarm(0);
if ($@ =~ /^disconnect_tcpserver/) {
die "disconnect_tcpserver";
} else {
$self->run_hooks("post-connection");
$self->connection->reset;
die "died while reading from STDIN (probably broken sender) - $@";
}
alarm(0);
} }
sub respond { sub respond {
my ($self, $code, @messages) = @_; my ($self, $code, @messages) = @_;
if ( !$self->check_socket() ) { if (!$self->check_socket()) {
$self->log(LOGERROR, "Lost connection to client, cannot send response."); $self->log(LOGERROR,
return(0); "Lost connection to client, cannot send response.");
} return (0);
}
while (my $msg = shift @messages) { while (my $msg = shift @messages) {
my $line = $code . (@messages?"-":" ").$msg; my $line = $code . (@messages ? "-" : " ") . $msg;
$self->log(LOGINFO, $line); $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; }
return 1;
} }
sub disconnect { sub disconnect {
my $self = shift; my $self = shift;
$self->log(LOGINFO,"click, disconnecting"); $self->log(LOGINFO, "click, disconnecting");
$self->SUPER::disconnect(@_); $self->SUPER::disconnect(@_);
$self->run_hooks("post-connection"); $self->run_hooks("post-connection");
$self->connection->reset; $self->connection->reset;
die "disconnect_tcpserver"; die "disconnect_tcpserver";
} }
1; 1;

294
lib/Qpsmtpd/Transaction.pm
View File

@ -15,13 +15,13 @@ use Time::HiRes qw(gettimeofday);
sub new { start(@_) } sub new { start(@_) }
sub start { sub start {
my $proto = shift; my $proto = shift;
my $class = ref($proto) || $proto; my $class = ref($proto) || $proto;
my %args = @_; my %args = @_;
my $self = { _rcpt => [], started => time, }; my $self = {_rcpt => [], started => time,};
bless ($self, $class); bless($self, $class);
return $self; return $self;
} }
sub add_recipient { sub add_recipient {
@ -30,27 +30,28 @@ sub add_recipient {
} }
sub remove_recipient { sub remove_recipient {
my ($self,$rcpt) = @_; my ($self, $rcpt) = @_;
$self->{_recipients} = [grep {$_->address ne $rcpt->address} $self->{_recipients} =
@{$self->{_recipients} || []}] if $rcpt; [grep { $_->address ne $rcpt->address } @{$self->{_recipients} || []}]
if $rcpt;
} }
sub recipients { sub recipients {
my $self = shift; my $self = shift;
@_ and $self->{_recipients} = [@_]; @_ and $self->{_recipients} = [@_];
($self->{_recipients} ? @{$self->{_recipients}} : ()); ($self->{_recipients} ? @{$self->{_recipients}} : ());
} }
sub sender { sub sender {
my $self = shift; my $self = shift;
@_ and $self->{_sender} = shift; @_ and $self->{_sender} = shift;
$self->{_sender}; $self->{_sender};
} }
sub header { sub header {
my $self = shift; my $self = shift;
@_ and $self->{_header} = shift; @_ and $self->{_header} = shift;
$self->{_header}; $self->{_header};
} }
# blocked() will return when we actually can do something useful with it... # blocked() will return when we actually can do something useful with it...
@ -63,32 +64,33 @@ sub header {
#} #}
sub notes { 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 @_; # Check for any additional arguments passed by the caller -- including undef
return $self->{_notes}->{$key} = shift; return $self->{_notes}->{$key} unless @_;
return $self->{_notes}->{$key} = shift;
} }
sub set_body_start { sub set_body_start {
my $self = shift; my $self = shift;
$self->{_body_start} = $self->body_current_pos; $self->{_body_start} = $self->body_current_pos;
if ($self->{_body_file}) { if ($self->{_body_file}) {
$self->{_header_size} = $self->{_body_start}; $self->{_header_size} = $self->{_body_start};
} }
else { else {
$self->{_header_size} = 0; $self->{_header_size} = 0;
if ($self->{_body_array}) { if ($self->{_body_array}) {
foreach my $line (@{ $self->{_body_array} }) { foreach my $line (@{$self->{_body_array}}) {
$self->{_header_size} += length($line); $self->{_header_size} += length($line);
} }
} }
} }
} }
sub body_start { sub body_start {
my $self = shift; my $self = shift;
@_ and die "body_start now read only"; @_ and die "body_start now read only";
$self->{_body_start}; $self->{_body_start};
} }
sub body_current_pos { sub body_current_pos {
@ -100,110 +102,116 @@ sub body_current_pos {
} }
sub body_filename { sub body_filename {
my $self = shift; my $self = shift;
$self->body_spool() unless $self->{_filename}; $self->body_spool() unless $self->{_filename};
$self->{_body_file}->flush(); # so contents won't be cached $self->{_body_file}->flush(); # so contents won't be cached
return $self->{_filename}; return $self->{_filename};
} }
sub body_spool { sub body_spool {
my $self = shift; my $self = shift;
$self->log(LOGINFO, "spooling message to disk"); $self->log(LOGINFO, "spooling message to disk");
$self->{_filename} = $self->temp_file(); $self->{_filename} = $self->temp_file();
$self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600) $self->{_body_file} =
or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error; IO::File->new($self->{_filename}, O_RDWR | O_CREAT, 0600)
if ($self->{_body_array}) { or die "Could not open file $self->{_filename} - $! "
foreach my $line (@{ $self->{_body_array} }) { ; # . $self->{_body_file}->error;
$self->{_body_file}->print($line) or die "Cannot print to temp file: $!"; if ($self->{_body_array}) {
foreach my $line (@{$self->{_body_array}}) {
$self->{_body_file}->print($line)
or die "Cannot print to temp file: $!";
}
$self->{_body_start} = $self->{_header_size};
} }
$self->{_body_start} = $self->{_header_size}; else {
} $self->log(LOGERROR, "no message body");
else { }
$self->log(LOGERROR, "no message body"); $self->{_body_array} = undef;
}
$self->{_body_array} = undef;
} }
sub body_write { sub body_write {
my $self = shift; my $self = shift;
my $data = shift; my $data = shift;
if ($self->{_body_file}) { if ($self->{_body_file}) {
#warn("body_write to file\n");
# go to the end of the file #warn("body_write to file\n");
seek($self->{_body_file},0,2) # go to the end of the file
unless $self->{_body_file_writing}; seek($self->{_body_file}, 0, 2)
$self->{_body_file_writing} = 1; unless $self->{_body_file_writing};
$self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data) $self->{_body_file_writing} = 1;
and $self->{_body_size} += length (ref $data eq "SCALAR" ? $$data : $data); $self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data)
} and $self->{_body_size} +=
else { length(ref $data eq "SCALAR" ? $$data : $data);
#warn("body_write to array\n");
$self->{_body_array} ||= [];
my $ref = ref($data) eq "SCALAR" ? $data : \$data;
pos($$ref) = 0;
while ($$ref =~ m/\G(.*?\n)/gc) {
push @{ $self->{_body_array} }, $1;
$self->{_body_size} += length($1);
++$self->{_body_current_pos};
} }
if ($$ref =~ m/\G(.+)\z/gc) { else {
push @{ $self->{_body_array} }, $1; #warn("body_write to array\n");
$self->{_body_size} += length($1); $self->{_body_array} ||= [];
++$self->{_body_current_pos}; my $ref = ref($data) eq "SCALAR" ? $data : \$data;
pos($$ref) = 0;
while ($$ref =~ m/\G(.*?\n)/gc) {
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;
$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 sub body_size { # depreceated, use data_size() instead
my $self = shift; my $self = shift;
$self->log(LOGWARN, "WARNING: body_size() is depreceated, use data_size() instead"); $self->log(LOGWARN,
$self->{_body_size} || 0; "WARNING: body_size() is depreceated, use data_size() instead");
$self->{_body_size} || 0;
} }
sub data_size { sub data_size {
shift->{_body_size} || 0; shift->{_body_size} || 0;
} }
sub body_length { sub body_length {
my $self = shift; my $self = shift;
$self->{_body_size} or return 0; $self->{_body_size} or return 0;
$self->{_header_size} or return 0; $self->{_header_size} or return 0;
return $self->{_body_size} - $self->{_header_size}; return $self->{_body_size} - $self->{_header_size};
} }
sub body_resetpos { sub body_resetpos {
my $self = shift; my $self = shift;
if ($self->{_body_file}) { if ($self->{_body_file}) {
my $start = $self->{_body_start} || 0; my $start = $self->{_body_start} || 0;
seek($self->{_body_file}, $start, 0); seek($self->{_body_file}, $start, 0);
$self->{_body_file_writing} = 0; $self->{_body_file_writing} = 0;
} }
else { else {
$self->{_body_current_pos} = $self->{_body_start}; $self->{_body_current_pos} = $self->{_body_start};
} }
1; 1;
} }
sub body_getline { sub body_getline {
my $self = shift; my $self = shift;
if ($self->{_body_file}) { if ($self->{_body_file}) {
my $start = $self->{_body_start} || 0; my $start = $self->{_body_start} || 0;
seek($self->{_body_file}, $start,0) seek($self->{_body_file}, $start, 0)
if $self->{_body_file_writing}; if $self->{_body_file_writing};
$self->{_body_file_writing} = 0; $self->{_body_file_writing} = 0;
my $line = $self->{_body_file}->getline; my $line = $self->{_body_file}->getline;
return $line; return $line;
} }
else { else {
return unless $self->{_body_array}; return unless $self->{_body_array};
$self->{_body_current_pos} ||= 0; $self->{_body_current_pos} ||= 0;
my $line = $self->{_body_array}->[$self->{_body_current_pos}]; my $line = $self->{_body_array}->[$self->{_body_current_pos}];
$self->{_body_current_pos}++; $self->{_body_current_pos}++;
return $line; return $line;
} }
} }
sub body_as_string { sub body_as_string {
@ -218,55 +226,59 @@ sub body_as_string {
} }
sub body_fh { sub body_fh {
return shift->{_body_file}; return shift->{_body_file};
} }
sub dup_body_fh { sub dup_body_fh {
my ($self) = @_; my ($self) = @_;
open(my $fh, '<&=', $self->body_fh); open(my $fh, '<&=', $self->body_fh);
return $fh; return $fh;
} }
sub DESTROY { sub DESTROY {
my $self = shift; 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) ) ); # would we save some disk flushing if we unlinked the file before
# closing it?
if ( $self->{_body_file} ) { $self->log(LOGDEBUG, sprintf("DESTROY called by %s, %s, %s", (caller)));
if ($self->{_body_file}) {
undef $self->{_body_file}; undef $self->{_body_file};
}; }
if ($self->{_filename} and -e $self->{_filename}) { if ($self->{_filename} and -e $self->{_filename}) {
if ( unlink $self->{_filename} ) { if (unlink $self->{_filename}) {
$self->log(LOGDEBUG, "unlinked ", $self->{_filename} ); $self->log(LOGDEBUG, "unlinked ", $self->{_filename});
} }
else { else {
$self->log(LOGERROR, "Could not unlink ", $self->{_filename}, ": $!"); $self->log(LOGERROR, "Could not unlink ",
$self->{_filename}, ": $!");
} }
} }
# These may not exist # These may not exist
if ( $self->{_temp_files} ) { if ($self->{_temp_files}) {
$self->log(LOGDEBUG, "Cleaning up temporary transaction 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; next unless -e $file;
unlink $file or $self->log(LOGERROR, unlink $file
"Could not unlink temporary file", $file, ": $!"); or $self->log(LOGERROR, "Could not unlink temporary file",
$file, ": $!");
}
} }
}
# Ditto
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, ": $!");
}
}
}
# Ditto
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, ": $!");
}
}
}
1; 1;
__END__ __END__

1
lib/Qpsmtpd/Utils.pm
View File

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

67
t/Test/Qpsmtpd.pm
View File

@ -9,11 +9,17 @@ use Qpsmtpd::Constants;
use Test::Qpsmtpd::Plugin; use Test::Qpsmtpd::Plugin;
sub new_conn { sub new_conn {
ok(my $smtpd = __PACKAGE__->new(), "new"); ok(my $smtpd = __PACKAGE__->new(), "new");
ok(my $conn = $smtpd->start_connection(remote_host => 'localhost', ok(
remote_ip => '127.0.0.1'), "start_connection"); my $conn =
is(($smtpd->response)[0], "220", "greetings"); $smtpd->start_connection(
($smtpd, $conn); remote_host => 'localhost',
remote_ip => '127.0.0.1'
),
"start_connection"
);
is(($smtpd->response)[0], "220", "greetings");
($smtpd, $conn);
} }
sub start_connection { sub start_connection {
@ -23,12 +29,14 @@ sub start_connection {
my $remote_host = $args{remote_host} or croak "no remote_host parameter"; my $remote_host = $args{remote_host} or croak "no remote_host parameter";
my $remote_info = "test\@$remote_host"; my $remote_info = "test\@$remote_host";
my $remote_ip = $args{remote_ip} or croak "no remote_ip parameter"; my $remote_ip = $args{remote_ip} or croak "no remote_ip parameter";
my $conn = $self->SUPER::connection->start(remote_info => $remote_info,
remote_ip => $remote_ip,
remote_host => $remote_host,
@_);
my $conn =
$self->SUPER::connection->start(
remote_info => $remote_info,
remote_ip => $remote_ip,
remote_host => $remote_host,
@_
);
$self->load_plugins; $self->load_plugins;
@ -39,33 +47,33 @@ sub start_connection {
} }
sub respond { sub respond {
my $self = shift; my $self = shift;
$self->{_response} = [@_]; $self->{_response} = [@_];
} }
sub response { sub response {
my $self = shift; my $self = shift;
$self->{_response} ? (@{ delete $self->{_response} }) : (); $self->{_response} ? (@{delete $self->{_response}}) : ();
} }
sub command { sub command {
my ($self, $command) = @_; my ($self, $command) = @_;
$self->input($command); $self->input($command);
$self->response; $self->response;
} }
sub input { sub input {
my $self = shift; my $self = shift;
my $command = shift; my $command = shift;
my $timeout = $self->config('timeout'); my $timeout = $self->config('timeout');
alarm $timeout; alarm $timeout;
$command =~ s/\r?\n$//s; # advanced chomp $command =~ s/\r?\n$//s; # advanced chomp
$self->log(LOGDEBUG, "dispatching $command"); $self->log(LOGDEBUG, "dispatching $command");
defined $self->dispatch(split / +/, $command, 2) defined $self->dispatch(split / +/, $command, 2)
or $self->respond(502, "command unrecognized: '$command'"); or $self->respond(502, "command unrecognized: '$command'");
alarm $timeout; alarm $timeout;
} }
sub config_dir { sub config_dir {
@ -95,20 +103,21 @@ sub run_plugin_tests {
my $self = shift; my $self = shift;
$self->{_test_mode} = 1; $self->{_test_mode} = 1;
my @plugins = $self->load_plugins(); my @plugins = $self->load_plugins();
# First count test number # First count test number
my $num_tests = 0; my $num_tests = 0;
foreach my $plugin (@plugins) { foreach my $plugin (@plugins) {
$plugin->register_tests(); $plugin->register_tests();
$num_tests += $plugin->total_tests(); $num_tests += $plugin->total_tests();
} }
require Test::Builder; require Test::Builder;
my $Test = Test::Builder->new(); my $Test = Test::Builder->new();
$Test->plan( tests => $num_tests ); $Test->plan(tests => $num_tests);
# Now run them # Now run them
foreach my $plugin (@plugins) { foreach my $plugin (@plugins) {
$plugin->run_tests($self); $plugin->run_tests($self);
} }

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

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