diff --git a/Changes b/Changes index 2b0ee83..be68d4e 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,92 @@ -0.40 +0.33 (to be) + + Update the sample configuration to use zen.spamhaus.org + + Support "module" plugins ("My::Plugin" in the config/plugins file) + + Make the badmailfrom plugin support (optional) rejection messages after the + rejection pattern (Robin Hugh Johnson) + + The ill-named $transaction->body_size() is depreceated now, use + $transaction->data_size() instead. Check your logs for LOGWARN messages + about "body_size" and fix your plugins. (Hanno Hecker) + + Instead of failing with cryptic message, ignore lines in config/plugins + for uninstalled plugins. (John Peacock) + + Patch to prefork code to make it run (Leonardo Helman). Add --pretty + option to qpsmtpd-prefork to change $0 for child processes (John Peacock). + + Add support for multiple plugin directories, whose paths are given by the + 'plugin_dirs' configuration. (Devin Carraway, Nick Leverton) + + Greylisting DBs may now be stored in a configured location, and are + looked for by default in /var/lib/qpsmtpd/greylisting in addition to the + previous locations relative to the qpsmtpd binary. (Devin Carraway) + + New Qpsmtpd::Postfix::Constants to encapsulate all of the current return + codes from Postfix, plus script to generate it. (Hanno Hecker) + + Experimental IPv6 support (forkserver only). (Mike Williams) + + Add ability to specific socket for syslog (Peter Eisch) + + Do the right thing for unimplemented AUTH mechanisms (Brian Szymanski) + + relay_only plugin for smart relay host. (John Peacock) + + Enhance the spamassassin plugin to support connecting to a remote + spamd process (Kjetil Kjernsmo). + + Add SSL encryption method to header to mirror other qmail/SSL patches. + Add tls_before_auth to suppress AUTH unless TLS has already been + established (Robin Johnson). + + Fix "help" command when there's no "smtpgreeting" configured (the default) + (Thanks to Thomas Ogrisegg) + + Move the Qpsmtpd::Auth POD to a top-level README to be more obvious. + + Add Qpsmtpd::Command to gather all parsing logic in one place (Hanno + Hecker) + + Fix a spurious newline at the start of messages queued via exim (Devin + Carraway) + + Make the clamdscan plugin temporarily deny mail if if can't talk to clamd + (Filippo Carletti) + + Improve Qpsmtpd::Transaction documentation (Fred Moyer) + + +0.32 - 2006/02/26 + + Add logging/file plugin for simple logging to a file (Devin Carraway and + Peter J. Holzer). + + Add logging/syslog plugin for logging via the syslog facility (Devin + Carrway) + + Add Qpsmtpd::DSN to return extended SMTP status codes from RFC-1893 and + patch existing plugins to use it when appropriate (Hanno Hecker). + + Add plugins/tls_cert to generate appropriately shaped self-signed certs for + TLS support. Add explicit use of CA used to sign cert. Abstract clone()ing + of connection information when switching to TLS. Fix the AUTH code to work + correctly with TLS. + + Add hosts_allow plugin to support pre- and post-connection hooks as well + as move --max-from-ip tests out of core (Hanno Hecker). + + Improve postfix-queue plugin to support the known processing flags (Hanno + Hecker). + + Drop root privileges before loading plugins, rather than after. + + A few fixes to the clamdscan plugin (Dave Rolsky) + + Various minor fixes and improvements + 0.31.1 - 2005/11/18 @@ -116,6 +204,7 @@ Fix typo in qpsmtpd-forkserver commandline help + 0.29 - 2005/03/03 Store entire incoming message in spool file (so that scanners can read diff --git a/MANIFEST b/MANIFEST index 36c41c1..e71a6e7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -16,10 +16,12 @@ lib/Apache/Qpsmtpd.pm lib/Qpsmtpd.pm lib/Qpsmtpd/Address.pm lib/Qpsmtpd/Auth.pm +lib/Qpsmtpd/Command.pm lib/Qpsmtpd/Connection.pm lib/Qpsmtpd/Constants.pm lib/Qpsmtpd/Plugin.pm lib/Qpsmtpd/Postfix.pm +lib/Qpsmtpd/SelectServer.pm lib/Qpsmtpd/SMTP.pm lib/Qpsmtpd/TcpServer.pm lib/Qpsmtpd/Transaction.pm @@ -82,6 +84,7 @@ plugins/virus/sophie plugins/virus/uvscan qpsmtpd qpsmtpd-forkserver +qpsmtpd-server README README.logging README.plugins diff --git a/README b/README index 836b219..0e2979d 100644 --- a/README +++ b/README @@ -59,7 +59,7 @@ run the following command in the /home/smtpd/ directory. Beware that the trunk might be unstable and unsuitable for anything but development, so you might want to get a specific release, for example: - svn co http://svn.perl.org/qpsmtpd/tags/0.31.1 . + svn co http://svn.perl.org/qpsmtpd/tags/0.31 . chmod o+t ~smtpd/qpsmtpd/ (or whatever directory you installed qpsmtpd in) to make supervise start the log process. @@ -176,6 +176,11 @@ smtpd uses during the data transactions. If this file doesnt exist, it will default to use $ENV{HOME}/tmp/. This directory should be set with a mode of 700 and owned by the smtpd user. +=item tls_before_auth + +If this file contains anything except a 0 on the first noncomment line, then +AUTH will not be offered unless TLS/SSL are in place, either with STARTTLS, +or SMTP-SSL on port 465. =item everything (?) that qmail-smtpd supports. diff --git a/README.plugins b/README.plugins index 81eaa63..ddaf057 100644 --- a/README.plugins +++ b/README.plugins @@ -333,7 +333,7 @@ loaded. It's mostly for inheritance, below. =head1 Inheritance Instead of modifying @ISA directly in your plugin, use the -C< isa_plugin > method from the C< init > subroutine. +C< isa_plugin > method from the init subroutine. # rcpt_ok_child sub init { diff --git a/config.sample/dnsbl_zones b/config.sample/dnsbl_zones index aef5e63..15c4425 100644 --- a/config.sample/dnsbl_zones +++ b/config.sample/dnsbl_zones @@ -1,4 +1,2 @@ -rbl.mail-abuse.org spamsources.fabel.dk -relays.ordb.org -sbl.spamhaus.org +zen.spamhaus.org diff --git a/config.sample/plugins b/config.sample/plugins index 91e8e9b..1d6b180 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -6,6 +6,19 @@ # plugins/http_config for details. # http_config http://localhost/~smtpd/config/ http://www.example.com/smtp.pl?config= +# The hosts_allow module must be loaded if you want the -m / --max-from-ip / +# my $MAXCONNIP = 5; # max simultaneous connections from one IP +# settings... without this it will NOT refuse more than $MAXCONNIP connections +# from one IP! +hosts_allow + +# enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <> +dont_require_anglebrackets + +# enable to reject MAIL FROM:/RCPT TO: parameters if client helo was HELO +# (strict RFC 821)... this is not used in EHLO ... +# parse_addr_withhelo + quit_fortune check_earlytalker diff --git a/config.sample/tls_before_auth b/config.sample/tls_before_auth new file mode 100644 index 0000000..d9084c2 --- /dev/null +++ b/config.sample/tls_before_auth @@ -0,0 +1,2 @@ +# change the next line to 0 if you want to offer AUTH without TLS +1 diff --git a/config.sample/tls_ciphers b/config.sample/tls_ciphers new file mode 100644 index 0000000..e889731 --- /dev/null +++ b/config.sample/tls_ciphers @@ -0,0 +1,4 @@ +# Override default security using suitable string from available ciphers at +# L +# See plugins/tls for details. +HIGH diff --git a/lib/Apache/Qpsmtpd.pm b/lib/Apache/Qpsmtpd.pm index edb28c5..f675e2e 100644 --- a/lib/Apache/Qpsmtpd.pm +++ b/lib/Apache/Qpsmtpd.pm @@ -96,6 +96,7 @@ sub config_dir { return "/var/qmail/control"; } + sub plugin_dir { my $self = shift; return "$self->{qpdir}/plugins"; @@ -130,7 +131,7 @@ sub read_input { while (defined(my $data = $self->getline)) { $data =~ s/\r?\n$//s; # advanced chomp $self->log(LOGDEBUG, "dispatching $data"); - defined $self->dispatch(split / +/, $data) + defined $self->dispatch(split / +/, $data, 2) or $self->respond(502, "command unrecognized: '$data'"); last if $self->{_quitting}; } diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm index 373f12d..d407f20 100644 --- a/lib/Danga/Client.pm +++ b/lib/Danga/Client.pm @@ -2,9 +2,11 @@ package Danga::Client; use base 'Danga::TimeoutSocket'; -use fields qw(line pause_count); +use fields qw(line pause_count read_bytes data_bytes callback get_chunks); use Time::HiRes (); +use bytes; + # 30 seconds max timeout! sub max_idle_time { 30 } sub max_connect_time { 1200 } @@ -22,21 +24,94 @@ sub reset_for_next_message { my Danga::Client $self = shift; $self->{line} = ''; $self->{pause_count} = 0; + $self->{read_bytes} = 0; + $self->{callback} = undef; + $self->{data_bytes} = ''; + $self->{get_chunks} = 0; return $self; } +sub get_bytes { + my Danga::Client $self = shift; + my ($bytes, $callback) = @_; + if ($self->{callback}) { + die "get_bytes/get_chunks currently in progress!"; + } + $self->{read_bytes} = $bytes; + $self->{data_bytes} = $self->{line}; + $self->{read_bytes} -= length($self->{data_bytes}); + $self->{line} = ''; + if ($self->{read_bytes} <= 0) { + if ($self->{read_bytes} < 0) { + $self->{line} = substr($self->{data_bytes}, + $self->{read_bytes}, # negative offset + 0 - $self->{read_bytes}, # to end of str + ""); # truncate that substr + } + $callback->($self->{data_bytes}); + return; + } + $self->{callback} = $callback; +} + +sub get_chunks { + my Danga::Client $self = shift; + my ($bytes, $callback) = @_; + if ($self->{callback}) { + die "get_bytes/get_chunks currently in progress!"; + } + $self->{read_bytes} = $bytes; + $callback->($self->{line}) if length($self->{line}); + $self->{line} = ''; + $self->{callback} = $callback; + $self->{get_chunks} = 1; +} + +sub end_get_chunks { + my Danga::Client $self = shift; + my $remaining = shift; + $self->{callback} = undef; + $self->{get_chunks} = 0; + if (defined($remaining)) { + $self->process_read_buf(\$remaining); + } +} + sub event_read { my Danga::Client $self = shift; - my $bref = $self->read(8192); - return $self->close($!) unless defined $bref; - $self->process_read_buf($bref); + if ($self->{callback}) { + $self->{alive_time} = time; + if ($self->{get_chunks}) { + my $bref = $self->read($self->{read_bytes}); + return $self->close($!) unless defined $bref; + $self->{callback}->($$bref) if length($$bref); + return; + } + if ($self->{read_bytes} > 0) { + my $bref = $self->read($self->{read_bytes}); + return $self->close($!) unless defined $bref; + $self->{read_bytes} -= length($$bref); + $self->{data_bytes} .= $$bref; + } + if ($self->{read_bytes} <= 0) { + # print "Erk, read too much!\n" if $self->{read_bytes} < 0; + my $cb = $self->{callback}; + $self->{callback} = undef; + $cb->($self->{data_bytes}); + } + } + else { + my $bref = $self->read(8192); + return $self->close($!) unless defined $bref; + $self->process_read_buf($bref); + } } sub process_read_buf { my Danga::Client $self = shift; my $bref = shift; $self->{line} .= $$bref; - return if $self->paused(); + return if $self->{pause_count} || $self->{closed}; while ($self->{line} =~ s/^(.*?\n)//) { my $line = $1; @@ -45,7 +120,7 @@ sub process_read_buf { if ($::DEBUG > 1 and $resp) { print "$$:".($self+0)."S: $_\n" for split(/\n/, $resp) } $self->write($resp) if $resp; # $self->watch_read(0) if $self->{pause_count}; - last if $self->paused(); + return if $self->{pause_count} || $self->{closed}; } } diff --git a/lib/Danga/DNS.pm b/lib/Danga/DNS.pm deleted file mode 100644 index 4dbbf15..0000000 --- a/lib/Danga/DNS.pm +++ /dev/null @@ -1,160 +0,0 @@ -# $Id: DNS.pm,v 1.12 2005/02/14 22:06:08 msergeant Exp $ - -package Danga::DNS; - -# This is the query class - it is really just an encapsulation of the -# hosts you want to query, plus the callback. All the hard work is done -# in Danga::DNS::Resolver. - -use fields qw(client hosts num_hosts callback finished results start); -use strict; - -use Danga::DNS::Resolver; - -my $resolver; - -sub trace { - my $level = shift; - print STDERR ("[$$] dns lookup: @_") if $::DEBUG >= $level; -} - -sub new { - my Danga::DNS $self = shift; - my %options = @_; - - $resolver ||= Danga::DNS::Resolver->new(); - - my $client = $options{client}; - $client->pause_read() if $client; - - $self = fields::new($self) unless ref $self; - - $self->{hosts} = $options{hosts} ? $options{hosts} : [ $options{host} ]; - $self->{num_hosts} = scalar(@{$self->{hosts}}) || "No hosts supplied"; - $self->{client} = $client; - $self->{callback} = $options{callback} || die "No callback given"; - $self->{finished} = $options{finished}; - $self->{results} = {}; - $self->{start} = time; - - if ($options{type}) { - if ( ($options{type} eq 'A') || ($options{type} eq 'PTR') ) { - if (!$resolver->query($self, @{$self->{hosts}})) { - $client->continue_read() if $client; - return; - } - } - else { - if (!$resolver->query_type($self, $options{type}, @{$self->{hosts}})) { - $client->continue_read() if $client; - return; - } - # die "Unsupported DNS query type: $options{type}"; - } - } - else { - if (!$resolver->query($self, @{$self->{hosts}})) { - $client->continue_read() if $client; - return; - } - } - - return $self; -} - -sub run_callback { - my Danga::DNS $self = shift; - my ($result, $query) = @_; - $self->{results}{$query} = $result; - trace(2, "got $query => $result\n"); - eval { - $self->{callback}->($result, $query); - }; - if ($@) { - warn($@); - } -} - -sub DESTROY { - my Danga::DNS $self = shift; - my $now = time; - foreach my $host (@{$self->{hosts}}) { - if (!exists($self->{results}{$host})) { - print STDERR "DNS timeout (presumably) looking for $host after " . ($now - $self->{start}) . " secs\n"; - $self->{callback}->("NXDOMAIN", $host); - } - } - $self->{client}->continue_read() if $self->{client}; - if ($self->{finished}) { - $self->{finished}->(); - } -} - -1; - -=head1 NAME - -Danga::DNS - a DNS lookup class for the Danga::Socket framework - -=head1 SYNOPSIS - - Danga::DNS->new(%options); - -=head1 DESCRIPTION - -This module performs asynchronous DNS lookups, making use of a single UDP -socket (unlike Net::DNS's bgsend/bgread combination), and blocking reading on -a client until the response comes back (this is useful for e.g. SMTP rDNS -lookups where you want the answer before you see the next SMTP command). - -Currently this module will only perform A or PTR lookups. A rDNS (PTR) lookup -will be performed if the host matches the regexp: C. - -The lookups time out after 15 seconds. - -=head1 API - -=head2 C<< Danga::DNS->new( %options ) >> - -Create a new DNS query. You do not need to store the resulting object as this -class is all done with callbacks. - -Example: - - Danga::DNS->new( - callback => sub { print "Got result: $_[0]\n" }, - host => 'google.com', - ); - -=over 4 - -=item B<[required]> C - -The callback to call when results come in. This should be a reference to a -subroutine. The callback receives two parameters - the result of the DNS lookup -and the host that was looked up. - -=item C - -A host name to lookup. Note that if the hostname is a dotted quad of numbers then -a reverse DNS (PTR) lookup is performend. - -=item C - -An array-ref list of hosts to lookup. - -B One of either C or C is B. - -=item C - -It is possible to specify a C object (or subclass) which you wish -to disable for reading until your DNS result returns. - -=item C - -You can specify one of: I<"A">, I<"PTR"> or I<"TXT"> here. Other types may be -supported in the future. - -=back - -=cut diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm deleted file mode 100644 index 950682e..0000000 --- a/lib/Danga/DNS/Resolver.pm +++ /dev/null @@ -1,395 +0,0 @@ -# $Id: Resolver.pm,v 1.3 2005/02/14 22:06:08 msergeant Exp $ - -package Danga::DNS::Resolver; -use base qw(Danga::Socket); - -use fields qw(res dst cache cache_timeout queries); - -use Net::DNS; -use Socket; -use strict; - -our $last_cleanup = 0; - -sub trace { - my $level = shift; - print ("$::DEBUG/$level [$$] dns lookup: @_") if $::DEBUG >= $level; -} - -sub new { - my Danga::DNS::Resolver $self = shift; - - $self = fields::new($self) unless ref $self; - - my $res = Net::DNS::Resolver->new; - - my $sock = IO::Socket::INET->new( - Proto => 'udp', - LocalAddr => $res->{'srcaddr'}, - LocalPort => ($res->{'srcport'} || undef), - ) || die "Cannot create socket: $!"; - IO::Handle::blocking($sock, 0); - - $self->{dst} = []; - - foreach my $ns (@{ $res->{nameservers} }) { - trace(2, "Using nameserver $ns:$res->{port}\n"); - my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton($ns)); - push @{$self->{dst}}, $dst_sockaddr; - } - - $self->{res} = $res; - $self->{queries} = {}; - $self->{cache} = {}; - $self->{cache_timeout} = {}; - - $self->SUPER::new($sock); - - $self->watch_read(1); - - $self->AddTimer(5, sub { $self->_do_cleanup }); - - return $self; -} - -sub ns { - my Danga::DNS::Resolver $self = shift; - my $index = shift; - return if $index > $#{$self->{dst}}; - return $self->{dst}->[$index]; -} - -sub pending { - my Danga::DNS::Resolver $self = shift; - - return keys(%{$self->{queries}}); -} - -sub _query { - my Danga::DNS::Resolver $self = shift; - my ($asker, $host, $type, $now) = @_; - - if ($ENV{NODNS}) { - $asker->run_callback("NXDNS", $host); - return 1; - } - if (exists($self->{cache}{$type}{$host}) && - $self->{cache_timeout}{$type}{$host} >= $now) { - # print "CACHE HIT!\n"; - my $result = $self->{cache}{$type}{$host}; - $self->AddTimer(0, sub { - $asker->run_callback($result, $host); - }); - return 1; - } - - my $packet = $self->{res}->make_query_packet($host, $type); - - my $packet_data = $packet->data; - my $id = $packet->header->id; - - my $query = Danga::DNS::Resolver::Query->new( - $self, $asker, $host, $type, $now, $id, $packet_data, - ) or return; - $self->{queries}->{$id} = $query; - - return 1; -} - -sub query_type { - my Danga::DNS::Resolver $self = shift; - my ($asker, $type, @hosts) = @_; - - my $now = time(); - - trace(2, "Trying to resolve $type: @hosts\n"); - - foreach my $host (@hosts) { - $self->_query($asker, $host, $type, $now) || return; - } - - return 1; -} - -sub query_txt { - my Danga::DNS::Resolver $self = shift; - my ($asker, @hosts) = @_; - return $self->query_type($asker, "TXT", @hosts); -} - -sub query_mx { - my Danga::DNS::Resolver $self = shift; - my ($asker, @hosts) = @_; - return $self->query_type($asker, "MX", @hosts); -} - -sub query { - my Danga::DNS::Resolver $self = shift; - my ($asker, @hosts) = @_; - - my $now = time(); - - trace(2, "trying to resolve A/PTR: @hosts\n"); - - foreach my $host (@hosts) { - $self->_query($asker, $host, 'A', $now) || return; - } - - return 1; -} - -sub _do_cleanup { - my Danga::DNS::Resolver $self = shift; - my $now = time; - - $self->AddTimer(5, sub { $self->_do_cleanup }); - - my $idle = $self->max_idle_time; - - my @to_delete; - while (my ($id, $obj) = each(%{$self->{queries}})) { - if ($obj->{timeout} < ($now - $idle)) { - push @to_delete, $id; - } - } - - foreach my $id (@to_delete) { - my $query = delete $self->{queries}{$id}; - $query->timeout() and next; - # add back in if timeout caused us to loop to next server - $self->{queries}->{$id} = $query; - } - - foreach my $type ('A', 'TXT', 'MX') { - @to_delete = (); - - while (my ($query, $t) = each(%{$self->{cache_timeout}{$type}})) { - if ($t < $now) { - push @to_delete, $query; - } - } - - foreach my $q (@to_delete) { - delete $self->{cache_timeout}{$type}{$q}; - delete $self->{cache}{$type}{$q}; - } - } -} - -# seconds max timeout! -sub max_idle_time { 30 } - -# Danga::DNS -sub event_err { shift->close("dns socket error") } -sub event_hup { shift->close("dns socket error") } - -my %type_to_host = ( - PTR => 'ptrdname', - A => 'address', - AAAA => 'address', - TXT => 'txtdata', - NS => 'nsdname', - CNAME => 'cname', -); - -sub event_read { - my Danga::DNS::Resolver $self = shift; - - while (my $packet = $self->{res}->bgread($self->sock)) { - my $err = $self->{res}->errorstring; - my $answers = 0; - my $header = $packet->header; - my $id = $header->id; - - my $qobj = delete $self->{queries}->{$id}; - if (!$qobj) { - trace(1, "No query for id: $id\n"); - return; - } - - my $query = $qobj->{host}; - - my $now = time(); - foreach my $rr ($packet->answer) { - if (my $host_method = $type_to_host{$rr->type}) { - my $host = $rr->$host_method; - my $type = $rr->type; - $type = 'A' if $type eq 'PTR'; - # print "DNS Lookup $type $query = $host; TTL = ", $rr->ttl, "\n"; - $self->{cache}{$type}{$query} = $host; - $self->{cache_timeout}{$type}{$query} = $now + $rr->ttl; - $qobj->run_callback($host); - } - elsif ($rr->type eq "MX") { - my $host = $rr->exchange; - my $preference = $rr->preference; - $self->{cache}{MX}{$query} = [$host, $preference]; - $self->{cache_timeout}{MX}{$query} = $now + $rr->ttl; - $qobj->run_callback([$host, $preference]); - } - else { - # came back, but not a PTR or A record - $qobj->run_callback("UNKNOWN"); - } - $answers++; - } - if (!$answers) { - if ($err eq "NXDOMAIN") { - # trace("found => NXDOMAIN\n"); - $qobj->run_callback("NXDOMAIN"); - } - elsif ($err eq "SERVFAIL") { - # try again??? - print "SERVFAIL looking for $query\n"; - #$self->query($asker, $query); - $qobj->error($err) and next; - # add back in if error() resulted in query being re-issued - $self->{queries}->{$id} = $qobj; - } - elsif ($err eq "NOERROR") { - $qobj->run_callback($err); - } - elsif($err) { - print("error: $err\n"); - $qobj->error($err) and next; - $self->{queries}->{$id} = $qobj; - } - else { - # trace("no answers\n"); - $qobj->run_callback("NOANSWER"); - } - } - } -} - -use Carp qw(confess); - -sub close { - my Danga::DNS::Resolver $self = shift; - - $self->SUPER::close(shift); - # confess "Danga::DNS::Resolver socket should never be closed!"; -} - -package Danga::DNS::Resolver::Query; - -use fields qw( resolver asker host type timeout id data repeat ns nqueries ); - -use constant MAX_QUERIES => 10; - -sub trace { - my $level = shift; - print ("$::DEBUG/$level [$$] dns lookup: @_") if $::DEBUG >= $level; -} - -sub new { - my Danga::DNS::Resolver::Query $self = shift; - $self = fields::new($self) unless ref $self; - - @$self{qw( resolver asker host type timeout id data )} = @_; - # repeat is number of retries - @$self{qw( repeat ns nqueries )} = (2,0,0); - - trace(2, "NS Query: $self->{host} ($self->{id})\n"); - - $self->send_query || return; - - return $self; -} - -#sub DESTROY { -# my $self = shift; -# trace(2, "DESTROY $self\n"); -#} - -sub timeout { - my Danga::DNS::Resolver::Query $self = shift; - - trace(2, "NS Query timeout. Trying next host\n"); - if ($self->send_query) { - # had another NS to send to, reset timeout - $self->{timeout} = time(); - return; - } - - # can we loop/repeat? - if (($self->{nqueries} <= MAX_QUERIES) && - ($self->{repeat} > 1)) - { - trace(2, "NS Query timeout. Next host failed. Trying loop\n"); - $self->{repeat}--; - $self->{ns} = 0; - return $self->timeout(); - } - - trace(2, "NS Query timeout. All failed. Running callback(TIMEOUT)\n"); - # otherwise we really must timeout. - $self->run_callback("TIMEOUT"); - return 1; -} - -sub error { - my Danga::DNS::Resolver::Query $self = shift; - my ($error) = @_; - - trace(2, "NS Query error. Trying next host\n"); - if ($self->send_query) { - # had another NS to send to, reset timeout - $self->{timeout} = time(); - return; - } - - # can we loop/repeat? - if (($self->{nqueries} <= MAX_QUERIES) && - ($self->{repeat} > 1)) - { - trace(2, "NS Query error. Next host failed. Trying loop\n"); - $self->{repeat}--; - $self->{ns} = 0; - return $self->error($error); - } - - trace(2, "NS Query error. All failed. Running callback($error)\n"); - # otherwise we really must timeout. - $self->run_callback($error); - return 1; -} - -sub run_callback { - my Danga::DNS::Resolver::Query $self = shift; - trace(2, "NS Query callback($self->{host} = $_[0]\n"); - $self->{asker}->run_callback($_[0], $self->{host}); -} - -sub send_query { - my Danga::DNS::Resolver::Query $self = shift; - - my $dst = $self->{resolver}->ns($self->{ns}++); - return unless defined $dst; - if (!$self->{resolver}->sock->send($self->{data}, 0, $dst)) { - return; - } - - $self->{nqueries}++; - return 1; -} - -1; - -=head1 NAME - -Danga::DNS::Resolver - an asynchronous DNS resolver class - -=head1 SYNOPSIS - - my $res = Danga::DNS::Resolver->new(); - - $res->query($obj, @hosts); # $obj implements $obj->run_callback() - -=head1 DESCRIPTION - -This is a low level DNS resolver class that works within the Danga::Socket -asynchronous I/O framework. Do not attempt to use this class standalone - use -the C class instead. - -=cut diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 0037643..ac6c70c 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -4,10 +4,8 @@ use vars qw($VERSION $Logger $TraceLevel $Spool_dir $Size_threshold); use Sys::Hostname; use Qpsmtpd::Constants; -use Qpsmtpd::Transaction; -use Qpsmtpd::Connection; -$VERSION = "0.40-dev"; +$VERSION = "0.33-dev"; sub version { $VERSION }; @@ -17,19 +15,28 @@ sub load_logging { # need to do this differently that other plugins so as to # not trigger logging activity my $self = shift; - #warn("load_logging: $self->{hooks}{logging} ", caller(8), "\n"); return if $self->{hooks}->{"logging"}; my $configdir = $self->config_dir("logging"); my $configfile = "$configdir/logging"; my @loggers = $self->_config_from_file($configfile,'logging'); - my $dir = $self->plugin_dir; - $self->_load_plugins($dir, @loggers); - - foreach my $logger (@loggers) { - $self->log(LOGINFO, "Loaded $logger"); + $configdir = $self->config_dir('plugin_dirs'); + $configfile = "$configdir/plugin_dirs"; + my @plugin_dirs = $self->_config_from_file($configfile,'plugin_dirs'); + unless (@plugin_dirs) { + my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); + @plugin_dirs = ( "$name/plugins" ); } + my @loaded; + for my $logger (@loggers) { + push @loaded, $self->_load_plugin($logger, @plugin_dirs); + } + + foreach my $logger (@loaded) { + $self->log(LOGINFO, "Loaded $logger"); + } + return @loggers; } @@ -76,9 +83,7 @@ sub varlog { unless ( $rc and $rc == DECLINED or $rc == OK ) { # no logging plugins registered so fall back to STDERR - my $fd = $self->fd(); warn join(" ", $$ . - (defined $fd ? " fd:$fd" : "") . (defined $plugin ? " $plugin plugin:" : defined $hook ? " running plugin ($hook):" : ""), @log), "\n" @@ -117,8 +122,8 @@ sub config { sub config_dir { my ($self, $config) = @_; my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control'; - my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); - $configdir = "$name/config" if (-e "$name/config/$config"); + my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!; + $configdir = "$path/config" if (-e "$path/config/$config"); if (exists $ENV{QPSMTPD_CONFIG}) { $ENV{QPSMTPD_CONFIG} =~ /^(.*)$/; # detaint $configdir = $1 if -e "$1/$config"; @@ -126,9 +131,15 @@ sub config_dir { return $configdir; } -sub plugin_dir { - my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); - my $dir = "$name/plugins"; +sub plugin_dirs { + my $self = shift; + my @plugin_dirs = $self->config('plugin_dirs'); + + unless (@plugin_dirs) { + my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!; + @plugin_dirs = ( "$path/plugins" ); + } + return @plugin_dirs; } sub get_qmail_config { @@ -244,112 +255,102 @@ sub expand_inclusion_ { sub load_plugins { my $self = shift; - -# if ($HOOKS) { -# return $self->{hooks} = $HOOKS; -# } - + $self->log(LOGWARN, "Plugins already loaded") if $self->{hooks}; $self->{hooks} = {}; my @plugins = $self->config('plugins'); + my @loaded; - my $dir = $self->plugin_dir; - $self->log(LOGNOTICE, "loading plugins from $dir"); + for my $plugin_line (@plugins) { + my $this_plugin = $self->_load_plugin($plugin_line, $self->plugin_dirs); + push @loaded, $this_plugin if $this_plugin; + } - @plugins = $self->_load_plugins($dir, @plugins); - -# $HOOKS = $self->{hooks}; -# - return @plugins; + return @loaded; } -sub _load_plugins { +sub _load_plugin { my $self = shift; - my ($dir, @plugins) = @_; + my ($plugin_line, @plugin_dirs) = @_; - my @ret; - for my $plugin_line (@plugins) { - my ($plugin, @args) = split ' ', $plugin_line; - + my ($plugin, @args) = split ' ', $plugin_line; + + my $package; + + if ($plugin =~ m/::/) { + # "full" package plugin (My::Plugin) + $package = $plugin; + $package =~ s/[^_a-z0-9:]+//gi; + my $eval = qq[require $package;\n] + .qq[sub ${plugin}::plugin_name { '$plugin' }]; + $eval =~ m/(.*)/s; + $eval = $1; + eval $eval; + die "Failed loading $package - eval $@" if $@; + $self->log(LOGDEBUG, "Loading $package ($plugin_line)") + unless $plugin_line =~ /logging/; + } + else { + # regular plugins/$plugin plugin my $plugin_name = $plugin; $plugin =~ s/:\d+$//; # after this point, only used for filename # Escape everything into valid perl identifiers $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg; - + # second pass cares for slashes and words starting with a digit $plugin_name =~ s{ - (/+) # directory - (\d?) # package's first character - }[ - "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "") - ]egx; - - my $package = "Qpsmtpd::Plugin::$plugin_name"; - + (/+) # directory + (\d?) # package's first character + }[ + "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "") + ]egx; + + $package = "Qpsmtpd::Plugin::$plugin_name"; + # don't reload plugins if they are already loaded unless ( defined &{"${package}::plugin_name"} ) { - Qpsmtpd::Plugin->compile($plugin_name, - $package, "$dir/$plugin", $self->{_test_mode}); - $self->log(LOGDEBUG, "Loading $plugin_line") - unless $plugin_line =~ /logging/; + PLUGIN_DIR: for my $dir (@plugin_dirs) { + if (-e "$dir/$plugin") { + Qpsmtpd::Plugin->compile($plugin_name, $package, + "$dir/$plugin", $self->{_test_mode}); + $self->log(LOGDEBUG, "Loading $plugin_line from $dir/$plugin") + unless $plugin_line =~ /logging/; + last PLUGIN_DIR; + } + else { + $self->log(LOGDEBUG, "Failed to load plugin - $plugin - ignoring"); + return 0; + } + } } - - my $plug = $package->new(); - push @ret, $plug; - $plug->_register($self, @args); - } + + my $plug = $package->new(); + $plug->_register($self, @args); - return @ret; + return $plug; } sub transaction { - my $self = shift; - return $self->{_transaction} || $self->reset_transaction(); -} - -sub reset_transaction { - my $self = shift; - $self->run_hooks("reset_transaction") if $self->{_transaction}; - return $self->{_transaction} = Qpsmtpd::Transaction->new(); -} - - -sub connection { - my $self = shift; - @_ and $self->{_connection} = shift; - return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new()); + return {}; # base class implements empty transaction } sub run_hooks { my ($self, $hook) = (shift, shift); - if ($self->{_continuation} && $hook ne "logging" && $hook ne "config") { - die "Continuations in progress from previous hook (this is the $hook hook)"; - } my $hooks = $self->{hooks}; if ($hooks->{$hook}) { my @r; my @local_hooks = @{$hooks->{$hook}}; - while (@local_hooks) { - my $code = shift @local_hooks; - @r = $self->run_hook($hook, $code, @_); - next unless @r; - if ($r[0] == CONTINUATION) { - $self->pause_read() if $self->isa('Danga::Client'); - $self->{_continuation} = [$hook, [@_], @local_hooks]; - } - last unless $r[0] == DECLINED; - } - $r[0] = DECLINED if not defined $r[0]; - return @r; + $self->{_continuation} = [$hook, [@_], @local_hooks]; + return $self->run_continuation(); } - return (0, ''); + return $self->hook_responder($hook, [0, ''], [@_]); } -sub finish_continuation { - my ($self) = @_; +sub run_continuation { + my $self = shift; die "No continuation in progress" unless $self->{_continuation}; $self->continue_read() if $self->isa('Danga::Client'); my $todo = $self->{_continuation}; @@ -359,61 +360,70 @@ sub finish_continuation { my @r; while (@$todo) { my $code = shift @$todo; - @r = $self->run_hook($hook, $code, @$args); - if ($r[0] == CONTINUATION) { - $self->pause_read() if $self->isa('Danga::Client'); - $self->{_continuation} = [$hook, $args, @$todo]; - return @r; + if ( $hook eq 'logging' ) { # without calling $self->log() + eval { (@r) = $code->{code}->($self, $self->transaction, @$args); }; + $@ and warn("FATAL LOGGING PLUGIN ERROR: ", $@) and next; } + else { + $self->varlog(LOGDEBUG, $hook, $code->{name}); + eval { (@r) = $code->{code}->($self, $self->transaction, @$args); }; + $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and next; + + !defined $r[0] + and $self->log(LOGERROR, "plugin ".$code->{name} + ." running the $hook hook returned undef!") + and next; + + if ($self->transaction) { + my $tnotes = $self->transaction->notes( $code->{name} ); + $tnotes->{"hook_$hook"}->{'return'} = $r[0] + if (!defined $tnotes || ref $tnotes eq "HASH"); + } + else { + my $cnotes = $self->connection->notes( $code->{name} ); + $cnotes->{"hook_$hook"}->{'return'} = $r[0] + if (!defined $cnotes || ref $cnotes eq "HASH"); + } + + if ($r[0] == YIELD) { + $self->pause_read() if $self->isa('Danga::Client'); + $self->{_continuation} = [$hook, $args, @$todo]; + return @r; + } + elsif ($r[0] == DENY or $r[0] == DENYSOFT or + $r[0] == DENY_DISCONNECT or $r[0] == DENYSOFT_DISCONNECT) + { + $r[1] = "" if not defined $r[1]; + $self->log(LOGDEBUG, "Plugin ".$code->{name}. + ", hook $hook returned ".return_code($r[0]).", $r[1]"); + $self->run_hooks("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny"); + } + else { + $r[1] = "" if not defined $r[1]; + $self->log(LOGDEBUG, "Plugin ".$code->{name}. + ", hook $hook returned ".return_code($r[0]).", $r[1]"); + $self->run_hooks("ok", $code->{name}, $r[0], $r[1]) unless ($hook eq "ok"); + } + + } + last unless $r[0] == DECLINED; } $r[0] = DECLINED if not defined $r[0]; - my $responder = $hook . "_respond"; - if (my $meth = $self->can($responder)) { - $self->log(LOGNOTICE, "continuation finished on $self\n"); - return $meth->($self, $r[0], $r[1], @$args); - } - die "No ${hook}_respond method"; + @r = map { split /\n/ } @r; + return $self->hook_responder($hook, \@r, $args); } -sub run_hook { - my ($self, $hook, $code, @args) = @_; - my @r; - if ( $hook eq 'logging' ) { # without calling $self->log() - eval { (@r) = $code->{code}->($self, $self->{_transaction}, @args); }; - $@ and warn("FATAL LOGGING PLUGIN ERROR: ", $@) and next; +sub hook_responder { + my ($self, $hook, $msg, $args) = @_; + + my $code = shift @$msg; + + my $responder = $hook . '_respond'; + if (my $meth = $self->can($responder)) { + return $meth->($self, $code, $msg, $args); } - else { - $self->varlog(LOGINFO, $hook, $code->{name}); - eval { (@r) = $code->{code}->($self, $self->transaction, @args); }; - $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and return; - - !defined $r[0] - and $self->log(LOGERROR, "plugin ".$code->{name} - ."running the $hook hook returned undef!") - and return; - - if ($self->transaction) { - my $tnotes = $self->transaction->notes( $code->{name} ); - $tnotes->{"hook_$hook"}->{'return'} = $r[0] - if (!defined $tnotes || ref $tnotes eq "HASH"); - } else { - my $cnotes = $self->connection->notes( $code->{name} ); - $cnotes->{"hook_$hook"}->{'return'} = $r[0] - if (!defined $cnotes || ref $cnotes eq "HASH"); - } - - # should we have a hook for "OK" too? - if ($r[0] == DENY or $r[0] == DENYSOFT or - $r[0] == DENY_DISCONNECT or $r[0] == DENYSOFT_DISCONNECT) - { - $r[1] = "" if not defined $r[1]; - $self->log(LOGDEBUG, "Plugin $code->{name}, hook $hook returned $r[0], $r[1]"); - $self->run_hooks("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny"); - } - - } - return @r; + return $code, @$msg; } sub _register_hook { @@ -487,34 +497,16 @@ sub size_threshold { return $Size_threshold; } -sub authenticated { - my ($self, $state) = @_; - $self->{_auth_state} = $state if $state; - return (defined $self->{_auth_state} ? $self->{_auth_state} : 0); -} - sub auth_user { - my ($self, $user) = @_; - $self->{_auth_user} = $user if $user; + my $self = shift; return (defined $self->{_auth_user} ? $self->{_auth_user} : "" ); } -sub auth_ticket { - my ($self, $ticket) = @_; - $self->{_auth_ticket} = $ticket if $ticket; - return (defined $self->{_auth_ticket} ? $self->{_auth_ticket} : "" ); -} - sub auth_mechanism { - my ($self, $mechanism) = @_; - $self->{_auth_mechanism} = lc($mechanism) if $mechanism; + my $self = shift; return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" ); } - -sub fd { - return shift->{fd}; -} - + 1; __END__ diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index 6a8f28a..f1381e1 100644 --- a/lib/Qpsmtpd/Address.pm +++ b/lib/Qpsmtpd/Address.pm @@ -60,7 +60,8 @@ sub new { my ($class, $user, $host) = @_; my $self = {}; if ($user =~ /^<(.*)>$/ ) { - ($user, $host) = $class->canonify($user) + ($user, $host) = $class->canonify($user); + return undef unless defined $user; } elsif ( not defined $host ) { my $address = $user; @@ -308,8 +309,8 @@ sub _addr_cmp { } #invert the address so we can sort by domain then user - $left = lc($left->host.'='.$left->user); - $right = lc($right->host.'='.$right->user); + ($left = join( '=', reverse( split('@', $left->format))) ) =~ tr/[<>]//d; + ($right = join( '=', reverse( split('@',$right->format))) ) =~ tr/[<>]//d; if ( $swap ) { ($right, $left) = ($left, $right); diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm new file mode 100644 index 0000000..6e9a2a5 --- /dev/null +++ b/lib/Qpsmtpd/Auth.pm @@ -0,0 +1,125 @@ +# See the documentation in 'perldoc README.authentication' + +package Qpsmtpd::Auth; +use Qpsmtpd::Constants; +use MIME::Base64; + +sub e64 +{ + my ($arg) = @_; + my $res = encode_base64($arg); + chomp($res); + return($res); +} + +sub SASL { + + # $DB::single = 1; + my ( $session, $mechanism, $prekey ) = @_; + my ( $user, $passClear, $passHash, $ticket, $loginas ); + + if ( $mechanism eq "plain" ) { + if (!$prekey) { + $session->respond( 334, "Please continue" ); + $prekey= ; + } + ( $loginas, $user, $passClear ) = split /\x0/, + decode_base64($prekey); + + # Authorization ID must not be different from + # Authentication ID + if ( $loginas ne '' && $loginas ne $user ) { + $session->respond(535, "Authentication invalid"); + return DECLINED; + } + } + elsif ($mechanism eq "login") { + + if ( $prekey ) { + $user = decode_base64($prekey); + } + else { + $session->respond(334, e64("Username:")); + $user = decode_base64(); + if ($user eq '*') { + $session->respond(501, "Authentification canceled"); + return DECLINED; + } + } + + $session->respond(334, e64("Password:")); + $passClear = ; + $passClear = decode_base64($passClear); + if ($passClear eq '*') { + $session->respond(501, "Authentification canceled"); + return DECLINED; + } + } + elsif ( $mechanism eq "cram-md5" ) { + + # rand() is not cryptographic, but we only need to generate a globally + # unique number. The rand() is there in case the user logs in more than + # once in the same second, of if the clock is skewed. + $ticket = sprintf( "<%x.%x\@" . $session->config("me") . ">", + rand(1000000), time() ); + + # We send the ticket encoded in Base64 + $session->respond( 334, encode_base64( $ticket, "" ) ); + my $line = ; + + if ( $line eq '*' ) { + $session->respond( 501, "Authentification canceled" ); + return DECLINED; + } + + ( $user, $passHash ) = split( ' ', decode_base64($line) ); + } + else { + #this error is now caught in SMTP.pm's sub auth + $session->respond( 500, "Internal server error" ); + return DECLINED; + } + + # Make sure that we have enough information to proceed + unless ( $user && ($passClear || $passHash) ) { + $session->respond(504, "Invalid authentification string"); + return DECLINED; + } + + # try running the specific hooks first + my ( $rc, $msg ) = + $session->run_hooks( "auth-$mechanism", $mechanism, $user, $passClear, + $passHash, $ticket ); + + # try running the polymorphous hooks next + if ( !$rc || $rc == DECLINED ) { + ( $rc, $msg ) = + $session->run_hooks( "auth", $mechanism, $user, $passClear, + $passHash, $ticket ); + } + + if ( $rc == OK ) { + $msg = "Authentication successful for $user" . + ( defined $msg ? " - " . $msg : "" ); + $session->respond( 235, $msg ); + $session->connection->relay_client(1); + $session->log( LOGINFO, $msg ); + + $session->{_auth_user} = $user; + $session->{_auth_mechanism} = $mechanism; + s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism}); + + return OK; + } + else { + $msg = "Authentication failed for $user" . + ( defined $msg ? " - " . $msg : "" ); + $session->respond( 535, $msg ); + $session->log( LOGERROR, $msg ); + return DENY; + } +} + +# tag: qpsmtpd plugin that sets RELAYCLIENT when the user authentifies + +1; diff --git a/lib/Qpsmtpd/Command.pm b/lib/Qpsmtpd/Command.pm new file mode 100644 index 0000000..a6c02c8 --- /dev/null +++ b/lib/Qpsmtpd/Command.pm @@ -0,0 +1,170 @@ +package Qpsmtpd::Command; + +=head1 NAME + +Qpsmtpd::Command - parse arguments to SMTP commands + +=head1 DESCRIPTION + +B provides just one public sub routine: B. + +This sub expects two or three arguments. The first is the name of the +SMTP command (such as I, I, ...). The second must be the remaining +of the line the client sent. + +If no third argument is given (or it's not a reference to a CODE) it parses +the line according to RFC 1869 (SMTP Service Extensions) for the I and +I commands and splitting by spaces (" ") for all other. + +Any module can supply it's own parsing routine by returning a sub routine +reference from a hook_*_parse. This sub will be called with I<$self>, I<$cmd> +and I<$line>. + +On successfull parsing it MUST return B (the constant from +I) success as first argument and a list of +values, which will be the arguments to the hook for this command. + +If parsing failed, the second returned value (if any) will be returned to the +client as error message. + +=head1 EXAMPLE + +Inside a plugin + + sub hook_unrecognized_command_parse { + my ($self, $transaction, $cmd) = @_; + return (OK, \&bdat_parser) if ($cmd eq 'bdat'); + } + + sub bdat_parser { + my ($self,$cmd,$line) = @_; + # .. do something with $line... + return (DENY, "Invalid arguments") + if $some_reason_why_there_is_a_syntax_error; + return (OK, @args); + } + + sub hook_unrecognized_command { + my ($self, $transaction, $cmd, @args) = @_; + return (DECLINED) if ($self->qp->connection->hello eq 'helo'); + return (DECLINED) unless ($cmd eq 'bdat'); + .... + } + +=cut + +use Qpsmtpd::Constants; +use vars qw(@ISA); +@ISA = qw(Qpsmtpd::SMTP); +use strict; + +sub parse { + my ($me,$cmd,$line,$sub) = @_; + return (OK) unless defined $line; # trivial case + my $self = {}; + bless $self, $me; + $cmd = lc $cmd; + if ($sub and (ref($sub) eq 'CODE')) { + my @ret = eval { $sub->($self, $cmd, $line); }; + if ($@) { + $self->log(LOGERROR, "Failed to parse command [$cmd]: $@"); + return (DENY, $line, ()); + } + ## my @log = @ret; + ## for (@log) { + ## $_ ||= ""; + ## } + ## $self->log(LOGDEBUG, "parse($cmd) => [".join("], [", @log)."]"); + return @ret; + } + my $parse = "parse_$cmd"; + if ($self->can($parse)) { + # print "CMD=$cmd,line=$line\n"; + my @out = eval { $self->$parse($cmd, $line); }; + if ($@) { + $self->log(LOGERROR, "$parse($cmd,$line) failed: $@"); + return(DENY, "Failed to parse line"); + } + return @out; + } + return(OK, split(/ +/, $line)); # default :) +} + +sub parse_rcpt { + my ($self,$cmd,$line) = @_; + return (DENY, "Syntax error in command") unless $line =~ s/^to:\s*//i; + return &_get_mail_params($cmd, $line); +} + +sub parse_mail { + my ($self,$cmd,$line) = @_; + return (DENY, "Syntax error in command") unless $line =~ s/^from:\s*//i; + return &_get_mail_params($cmd, $line); +} +### RFC 1869: +## 6. MAIL FROM and RCPT TO Parameters +## [...] +## +## esmtp-cmd ::= inner-esmtp-cmd [SP esmtp-parameters] CR LF +## esmtp-parameters ::= esmtp-parameter *(SP esmtp-parameter) +## esmtp-parameter ::= esmtp-keyword ["=" esmtp-value] +## esmtp-keyword ::= (ALPHA / DIGIT) *(ALPHA / DIGIT / "-") +## +## ; syntax and values depend on esmtp-keyword +## esmtp-value ::= 1* like + # MAIL FROM: user=name@example.net + # or RCPT TO: postmaster + + # let's see if $line contains nothing and use the first value as address: + if ($line) { + # parameter syntax error, i.e. not all of the arguments were + # stripped by the while() loop: + return (DENY, "Syntax error in parameters") + if ($line =~ /\@.*\s/); + return (OK, $line, @params); + } + + $line = shift @params; + if ($cmd eq "mail") { + return (OK, "<>") unless $line; # 'MAIL FROM:' --> 'MAIL FROM:<>' + return (DENY, "Syntax error in parameters") + if ($line =~ /\@.*\s/); # parameter syntax error + } + else { + if ($line =~ /\@/) { + return (DENY, "Syntax error in parameters") + if ($line =~ /\@.*\s/); + } + else { + # XXX: what about 'abuse' in Qpsmtpd::Address? + return (DENY, "Syntax error in parameters") if $line =~ /\s/; + return (DENY, "Syntax error in address") + unless ($line =~ /^(postmaster|abuse)$/i); + } + } + ## XXX: No: let this do a plugin, so it's not up to us to decide + ## if we require <> around an address :-) + ## unless ($line =~ /^<.*>$/) { $line = "<".$line.">"; } + return (OK, $line, @params); +} + +1; diff --git a/lib/Qpsmtpd/ConfigServer.pm b/lib/Qpsmtpd/ConfigServer.pm index ba9e065..5d870c5 100644 --- a/lib/Qpsmtpd/ConfigServer.pm +++ b/lib/Qpsmtpd/ConfigServer.pm @@ -121,6 +121,10 @@ sub cmd_quit { $self->close; } +sub cmd_shutdown { + exit; +} + sub cmd_pause { my $self = shift; @@ -169,7 +173,7 @@ sub cmd_status { if ($pob->isa("Qpsmtpd::PollServer")) { $current_connections++; } - elsif ($pob->isa("Danga::DNS::Resolver")) { + elsif ($pob->isa("ParaDNS::Resolver")) { $current_dns = $pob->pending; } } diff --git a/lib/Qpsmtpd/Connection.pm b/lib/Qpsmtpd/Connection.pm index 8492755..a415df4 100644 --- a/lib/Qpsmtpd/Connection.pm +++ b/lib/Qpsmtpd/Connection.pm @@ -136,6 +136,14 @@ These API docs assume you already have a connection object. See the source code if you need to construct one. You can access the connection object via the C object's C<< $qp->connection >> method. +=head2 new ( ) + +Instantiates a new Qpsmtpd::Connection object. + +=head2 start ( %args ) + +Initializes the connection object with %args attribute data. + =head2 remote_host( ) The remote host connecting to the server as looked up via reverse dns. @@ -144,11 +152,25 @@ The remote host connecting to the server as looked up via reverse dns. The remote IP address of the connecting host. +=head2 remote_port( ) + +The remote port. + +=head2 hello( ) + =head2 remote_info( ) If your server does an ident lookup on the remote host, this is the identity of the remote client. +=head2 local_ip( ) + +The local ip. + +=head2 local_port( ) + +The local port. + =head2 hello( ) Either C<"helo"> or C<"ehlo"> depending on how the remote client @@ -168,4 +190,14 @@ set after a successful return from those hooks. Connection-wide notes, used for passing data between plugins. +=head2 clone( ) + +Returns a copy of the Qpsmtpd::Connection object. + +=cut + +=head2 relay_client( ) + +True if the client is allowed to relay messages. + =cut diff --git a/lib/Qpsmtpd/Constants.pm b/lib/Qpsmtpd/Constants.pm index 27bebf0..0480d58 100644 --- a/lib/Qpsmtpd/Constants.pm +++ b/lib/Qpsmtpd/Constants.pm @@ -4,31 +4,49 @@ require Exporter; # log levels my %log_levels = ( - LOGDEBUG => 7, - LOGINFO => 6, - LOGNOTICE => 5, - LOGWARN => 4, - LOGERROR => 3, - LOGCRIT => 2, - LOGALERT => 1, - LOGEMERG => 0, - LOGRADAR => 0, + LOGDEBUG => 7, + LOGINFO => 6, + LOGNOTICE => 5, + LOGWARN => 4, + LOGERROR => 3, + LOGCRIT => 2, + LOGALERT => 1, + LOGEMERG => 0, + LOGRADAR => 0, ); # return codes my %return_codes = ( - OK => 900, - DENY => 901, # 550 - DENYSOFT => 902, # 450 - DENYHARD => 903, # 550 + disconnect (deprecated in 0.29) - DENY_DISCONNECT => 903, # 550 + disconnect - DENYSOFT_DISCONNECT => 904, # 450 + disconnect - DECLINED => 909, - DONE => 910, - CONTINUATION => 911, - AUTH_PENDING => 912, + OK => 900, + DENY => 901, # 550 + DENYSOFT => 902, # 450 + DENYHARD => 903, # 550 + disconnect (deprecated in 0.29) + DENY_DISCONNECT => 903, # 550 + disconnect + DENYSOFT_DISCONNECT => 904, # 450 + disconnect + DECLINED => 909, + DONE => 910, + CONTINUATION => 911, # deprecated - use YIELD + YIELD => 911, ); +my $has_ipv6; + +if ( + eval {require Socket6;} && + # INET6 prior to 2.01 will not work; sorry. + eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00");} + ) { + import Socket6; + $has_ipv6=1; +} +else { + $has_ipv6=0; +} + +sub has_ipv6 { + return $has_ipv6; +} + use vars qw(@ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = (keys(%return_codes), keys(%log_levels), "return_code", "log_level"); @@ -44,24 +62,24 @@ foreach (keys %log_levels ) { sub return_code { my $test = shift; if ( $test =~ /^\d+$/ ) { # need to return the textural form - foreach ( keys %return_codes ) { - return $_ if $return_codes{$_} =~ /$test/; - } + foreach ( keys %return_codes ) { + return $_ if $return_codes{$_} =~ /$test/; + } } else { # just return the numeric value - return $return_codes{$test}; + return $return_codes{$test}; } } sub log_level { my $test = shift; if ( $test =~ /^\d+$/ ) { # need to return the textural form - foreach ( keys %log_levels ) { - return $_ if $log_levels{$_} =~ /$test/; - } + foreach ( keys %log_levels ) { + return $_ if $log_levels{$_} =~ /$test/; + } } else { # just return the numeric value - return $log_levels{$test}; + return $log_levels{$test}; } } diff --git a/lib/Qpsmtpd/DSN.pm b/lib/Qpsmtpd/DSN.pm new file mode 100644 index 0000000..59ab1c7 --- /dev/null +++ b/lib/Qpsmtpd/DSN.pm @@ -0,0 +1,621 @@ +# +# Enhanced Mail System Status Codes - RFC 1893 +# +package Qpsmtpd::DSN; +use strict; +use Qpsmtpd::Constants; + +=head1 NAME + +Qpsmtpd::DSN - Enhanced Mail System Status Codes - RFC 1893 + +=head1 DESCRIPTION + +The B implements the I from +RFC 1893. + +=head1 USAGE + +Any B plugin can access these status codes. All sub routines are used +the same way: + use Qpsmtpd::DSN; + ...; + return Qpsmtpd::DSN->relaying_denied(); + +or + + return Qpsmtpd::DSN->relaying_denied("Relaying from $ip denied"); + +or + + return Qpsmtpd::DSN->relaying_denied(DENY,"Relaying from $ip denied"); + +If no status message was given, it will use the predefined one from the +RFC. If the first argument is numeric, it will use this as a return code, +else the default return code is used. See below which default return code +is used in the different functions. + +The first example will return +I<(DENY, "Relaying denied");> +the others +I<(DENY, "Relaying from $ip denied");> +which will be returned to qpsmtpd. + +In those sub routines which don't start with I I've added a default message which describes the status better +than the RFC message. + +=cut + +my @rfc1893 = ( + [ + "Other or Undefined Status", # x.0.x + ], + [ + "Other address status.", # x.1.0 + "Bad destination mailbox address.", # x.1.1 + "Bad destination system address.", # x.1.2 + "Bad destination mailbox address syntax.", # x.1.3 + "Destination mailbox address ambiguous.", # x.1.4 + "Destination address valid.", # x.1.5 + "Destination mailbox has moved, No forwarding address.", # x.1.6 + "Bad sender's mailbox address syntax.", # x.1.7 + "Bad sender's system address.", # x.1.8 + ], + [ + "Other or undefined mailbox status.", # x.2.0 + "Mailbox disabled, not accepting messages.", # x.2.1 + "Mailbox full.", # x.2.2 + "Message length exceeds administrative limit.", # x.2.3 + "Mailing list expansion problem.", # x.2.4 + ], + [ + "Other or undefined mail system status.", # x.3.0 + "Mail system full.", # x.3.1 + "System not accepting network messages.", # x.3.2 + "System not capable of selected features.", # x.3.3 + "Message too big for system.", # x.3.4 + "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 + "Invalid command.", # x.5.1 + "Syntax error.", # x.5.2 + "Too many recipients.", # x.5.3 + "Invalid command arguments.", # x.5.4 + "Wrong protocol version.", # x.5.5 + ], + [ + "Other or undefined media error.", # x.6.0 + "Media not supported.", # x.6.1 + "Conversion required and prohibited.", # x.6.2 + "Conversion required but not supported.", # x.6.3 + "Conversion with loss performed.", # x.6.4 + "Conversion Failed.", # x.6.5 + ], + [ + "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 { + my $return = shift; + my $const = Qpsmtpd::Constants::return_code($return); + if ($const =~ /^DENYSOFT/) { + return 4; + } + elsif ($const =~ /^DENY/) { + return 5; + } + elsif ($const eq 'OK' or $const eq 'DONE') { + return 2; + } + else { # err .... no :) + return 4; # just 2,4,5 are allowed.. temp error by default + } +} + +sub _dsn { + my ($self,$return,$reason,$default,$subject,$detail) = @_; + if (!defined $return) { + $return = $default; + } + elsif ($return !~ /^\d+$/) { + $reason = $return; + $return = $default; + } + my $msg = $rfc1893[$subject][$detail]; + unless (defined $msg) { + $detail = 0; + $msg = $rfc1893[$subject][$detail]; + unless (defined $msg) { + $subject = 0; + $msg = $rfc1893[$subject][$detail]; + } + } + my $class = &_status($return); + if (defined $reason) { + $msg = $reason; + } + return ($return, "$msg (#$class.$subject.$detail)"); +} + +sub unspecified { shift->_dsn(shift,shift,DENYSOFT,0,0); } + +=head1 ADDRESS STATUS + +=over 9 + +=item addr_unspecified + +X.1.0 +default: DENYSOFT + +=cut + +sub addr_unspecified { shift->_dsn(shift,shift,DENYSOFT,1,0); } + +=item no_such_user, addr_bad_dest_mbox + +X.1.1 +default: DENY + +=cut + +sub no_such_user { shift->_dsn(shift,(shift||"No such user"),DENY,1,1); } +sub addr_bad_dest_mbox { shift->_dsn(shift,shift,DENY,1,1); } + +=item addr_bad_dest_system + +X.1.2 +default: DENY + +=cut + +sub addr_bad_dest_system { shift->_dsn(shift,shift,DENY,1,2); } + +=item addr_bad_dest_syntax + +X.1.3 +default: DENY + +=cut + +sub addr_bad_dest_syntax { shift->_dsn(shift,shift,DENY,1,3); } + +=item addr_dest_ambigous + +X.1.4 +default: DENYSOFT + +=cut + +sub addr_dest_ambigous { shift->_dsn(shift,shift,DENYSOFT,1,4); } + +=item addr_rcpt_ok + +X.1.5 +default: OK + +=cut + +# XXX: do we need this? Maybe in all address verifying plugins? +sub addr_rcpt_ok { shift->_dsn(shift,shift,OK,1,5); } + +=item addr_mbox_moved + +X.1.6 +default: DENY + +=cut + +sub addr_mbox_moved { shift->_dsn(shift,shift,DENY,1,6); } + +=item addr_bad_from_syntax + +X.1.7 +default: DENY + +=cut + +sub addr_bad_from_syntax { shift->_dsn(shift,shift,DENY,1,7); } + +=item addr_bad_from_system + +X.1.8 +default: DENY + +=back + +=cut + +sub addr_bad_from_system { shift->_dsn(shift,shift,DENY,1,8); } + +=head1 MAILBOX STATUS + +=over 5 + +=item mbox_unspecified + +X.2.0 +default: DENYSOFT + +=cut + +sub mbox_unspecified { shift->_dsn(shift,shift,DENYSOFT,2,0); } + +=item mbox_disabled + +X.2.1 +default: DENY ...but RFC says: + The mailbox exists, but is not accepting messages. This may + be a permanent error if the mailbox will never be re-enabled + or a transient error if the mailbox is only temporarily + disabled. + +=cut + +sub mbox_disabled { shift->_dsn(shift,shift,DENY,2,1); } + +=item mbox_full + +X.2.2 +default: DENYSOFT + +=cut + +sub mbox_full { shift->_dsn(shift,shift,DENYSOFT,2,2); } + +=item mbox_msg_too_long + +X.2.3 +default: DENY + +=cut + +sub mbox_msg_too_long { shift->_dsn(shift,shift,DENY,2,3); } + +=item mbox_list_expansion_problem + +X.2.4 +default: DENYSOFT + +=back + +=cut + +sub mbox_list_expansion_problem { shift->_dsn(shift,shift,DENYSOFT,2,4); } + +=head1 MAIL SYSTEM STATUS + +=over 4 + +=item sys_unspecified + +X.3.0 +default: DENYSOFT + +=cut + +sub sys_unspecified { shift->_dsn(shift,shift,DENYSOFT,3,0); } + +=item sys_disk_full + +X.3.1 +default: DENYSOFT + +=cut + +sub sys_disk_full { shift->_dsn(shift,shift,DENYSOFT,3,1); } + +=item sys_not_accepting_mail + +X.3.2 +default: DENYSOFT + +=cut + +sub sys_not_accepting_mail { shift->_dsn(shift,shift,DENYSOFT,3,2); } + +=item sys_not_supported + +X.3.3 +default: DENYSOFT + Selected features specified for the message are not + supported by the destination system. This can occur in + gateways when features from one domain cannot be mapped onto + the supported feature in another. + +=cut + +sub sys_not_supported { shift->_dsn(shift,shift,DENYSOFT,3,3); } + +=item sys_msg_too_big + +X.3.4 +default DENY + +=back + +=cut + +sub sys_msg_too_big { shift->_dsn(shift,shift,DENY,3,4); } + +=head1 NETWORK AND ROUTING STATUS + +=cut + +=over 4 + +=item net_unspecified + +X.4.0 +default: DENYSOFT + +=cut + +sub net_unspecified { shift->_dsn(shift,shift,DENYSOFT,4,0); } + +# not useful # sub net_no_answer { shift->_dsn(shift,shift,4,1); } +# not useful # sub net_bad_connection { shift->_dsn(shift,shift,4,2); } + +=item net_directory_server_failed, temp_resolver_failed + +X.4.3 +default: DENYSOFT + +=cut + +sub temp_resolver_failed { + shift->_dsn(shift, + (shift || "Temporary address resolution failure"), + 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); } + +=item net_system_congested + +X.4.5 +default: DENYSOFT + +=cut + +sub net_system_congested { shift->_dsn(shift,shift,DENYSOFT,4,5); } + +=item net_routing_loop, too_many_hops + +X.4.6 +default: DENY, but RFC says: + A routing loop caused the message to be forwarded too many + times, either because of incorrect routing tables or a user + forwarding loop. This is useful only as a persistent + transient error. + +Why do we want to DENYSOFT something like this? + +=back + +=cut + +sub net_routing_loop { shift->_dsn(shift,shift,DENY,4,6); } +sub too_many_hops { shift->_dsn(shift,(shift || "Too many hops"),DENY,4,6,); } +# not useful # sub delivery_time_expired { shift->_dsn(shift,shift,4,7); } + +=head1 MAIL DELIVERY PROTOCOL STATUS + +=over 6 + +=item proto_unspecified + +X.5.0 +default: DENYSOFT + +=cut + +sub proto_unspecified { shift->_dsn(shift,shift,DENYSOFT,5,0); } + +=item proto_invalid_command + +X.5.1 +default: DENY + +=cut + +sub proto_invalid_command { shift->_dsn(shift,shift,DENY,5,1); } + +=item proto_syntax_error + +X.5.2 +default: DENY + +=cut + +sub proto_syntax_error { shift->_dsn(shift,shift,DENY,5,2); } + +=item proto_rcpt_list_too_long, too_many_rcpts + +X.5.3 +default: DENYSOFT + +=cut + +sub proto_rcpt_list_too_long { shift->_dsn(shift,shift,DENYSOFT,5,3); } +sub too_many_rcpts { shift->_dsn(shift,shift,DENYSOFT,5,3); } + +=item proto_invalid_cmd_args + +X.5.4 +default: DENY + +=cut + +sub proto_invalid_cmd_args { shift->_dsn(shift,shift,DENY,5,4); } + +=item proto_wrong_version + +X.5.5 +default: DENYSOFT + +=back + +=cut + +sub proto_wrong_version { shift->_dsn(shift,shift,DENYSOFT,5,5); } + +=head1 MESSAGE CONTENT OR MESSAGE MEDIA STATUS + +=over 5 + +=item media_unspecified + +X.6.0 +default: DENYSOFT + +=cut + +sub media_unspecified { shift->_dsn(shift,shift,DENYSOFT,6,0); } + +=item media_unsupported + +X.6.1 +default: DENY + +=cut + +sub media_unsupported { shift->_dsn(shift,shift,DENY,6,1); } + +=item media_conv_prohibited + +X.6.2 +default: DENY + +=cut + +sub media_conv_prohibited { shift->_dsn(shift,shift,DENY,6,2); } + +=item media_conv_unsupported + +X.6.3 +default: DENYSOFT + +=cut + +sub media_conv_unsupported { shift->_dsn(shift,shift,DENYSOFT,6,3); } + +=item media_conv_lossy + +X.6.4 +default: DENYSOFT + +=back + +=cut + +sub media_conv_lossy { shift->_dsn(shift,shift,DENYSOFT,6,4); } + +=head1 SECURITY OR POLICY STATUS + +=over 8 + +=item sec_unspecified + +X.7.0 +default: DENYSOFT + +=cut + +sub sec_unspecified { shift->_dsn(shift,shift,DENYSOFT,7,0); } + +=item sec_sender_unauthorized, bad_sender_ip, relaying_denied + +X.7.1 +default: DENY + +=cut + +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 relaying_denied { + shift->_dsn(shift,(shift || "Relaying denied"),DENY,7,1); +} + +=item sec_list_dest_prohibited + +X.7.2 +default: DENY + +=cut + +sub sec_list_dest_prohibited { shift->_dsn(shift,shift,DENY,7,2); } + +=item sec_conv_failed + +X.7.3 +default: DENY + +=cut + +sub sec_conv_failed { shift->_dsn(shift,shift,DENY,7,3); } + +=item sec_feature_unsupported + +X.7.4 +default: DENY + +=cut + +sub sec_feature_unsupported { shift->_dsn(shift,shift,DENY,7,4); } + +=item sec_crypto_failure + +X.7.5 +default: DENY + +=cut + +sub sec_crypto_failure { shift->_dsn(shift,shift,DENY,7,5); } + +=item sec_crypto_algorithm_unsupported + +X.7.6 +default: DENYSOFT + +=cut + +sub sec_crypto_algorithm_unsupported { shift->_dsn(shift,shift,DENYSOFT,7,6); } + +=item sec_msg_integrity_failure + +X.7.7 +default: DENY + +=back + +=cut + +sub sec_msg_integrity_failure { shift->_dsn(shift,shift,DENY,7,7); } + +1; + +# vim: st=4 sw=4 expandtab diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 19e9296..b6357be 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -2,11 +2,14 @@ package Qpsmtpd::Plugin; use Qpsmtpd::Constants; use strict; +# more or less in the order they will fire our @hooks = qw( - logging config queue data data_post quit rcpt mail ehlo helo - auth auth-plain auth-login auth-cram-md5 - connect reset_transaction unrecognized_command disconnect - deny ok pre-connection post-connection + logging config pre-connection connect ehlo_parse ehlo + helo_parse helo auth_parse auth auth-plain auth-login auth-cram-md5 + rcpt_parse rcpt_pre rcpt mail_parse mail mail_pre + data data_post queue_pre queue queue_post + quit reset_transaction disconnect post-connection + unrecognized_command deny ok ); our %hooks = map { $_ => 1 } @hooks; @@ -16,6 +19,10 @@ sub new { bless ({}, $class); } +sub hook_name { + return shift->{_hook}; +} + sub register_hook { my ($plugin, $hook, $method, $unshift) = @_; @@ -26,11 +33,16 @@ sub register_hook { # I can't quite decide if it's better to parse this code ref or if # we should pass the plugin object and method name ... hmn. - $plugin->qp->_register_hook($hook, { code => sub { local $plugin->{_qp} = shift; local $plugin->{_hook} = $hook; $plugin->$method(@_) }, - name => $plugin->plugin_name, - }, - $unshift, - ); + $plugin->qp->_register_hook + ($hook, + { code => sub { local $plugin->{_qp} = shift; + local $plugin->{_hook} = $hook; + $plugin->$method(@_) + }, + name => $plugin->plugin_name, + }, + $unshift, + ); } sub _register { @@ -42,18 +54,10 @@ sub _register { $self->register($qp, @_) if $self->can('register'); } -# Designed to be overloaded -sub init {} -sub register {} - sub qp { shift->{_qp}; } -sub fd { - shift->qp->fd(); -} - sub log { my $self = shift; $self->qp->varlog(shift, $self->hook_name, $self->plugin_name, @_) @@ -69,20 +73,16 @@ sub connection { shift->qp->connection; } -sub config { - shift->qp->config(@_); -} - sub spool_dir { shift->qp->spool_dir; } sub auth_user { - shift->qp->auth_user(@_); + shift->qp->auth_user; } sub auth_mechanism { - shift->qp->auth_mechanism(@_); + shift->qp->auth_mechanism; } sub temp_file { @@ -120,7 +120,7 @@ sub isa_plugin { $self->compile($self->plugin_name . "_isa_$cleanParent", $newPackage, "plugins/$parent"); # assumes Cwd is qpsmtpd root - $self->log(LOGDEBUG,"---- $newPackage\n"); + warn "---- $newPackage\n"; no strict 'refs'; push @{"${currentPackage}::ISA"}, $newPackage; } @@ -158,7 +158,6 @@ sub compile { '@ISA = qw(Qpsmtpd::Plugin);', ($test_mode ? 'use Test::More;' : ''), "sub plugin_name { qq[$plugin] }", - "sub hook_name { return shift->{_hook}; }", $line, $sub, "\n", # last line comment without newline? diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index afa1ec0..f2de0dc 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -29,7 +29,7 @@ use fields qw( ); use Qpsmtpd::Constants; use Qpsmtpd::Address; -use Danga::DNS; +use ParaDNS; use Mail::Header; use POSIX qw(strftime); use Socket qw(inet_aton AF_INET CRLF); @@ -54,6 +54,7 @@ sub new { $self->{start_time} = time; $self->{mode} = 'connect'; $self->load_plugins; + $self->load_logging; return $self; } @@ -64,7 +65,7 @@ sub uptime { } sub reset_for_next_message { - my $self = shift; + my Qpsmtpd::PollServer $self = shift; $self->SUPER::reset_for_next_message(@_); $self->{_commands} = { @@ -85,7 +86,7 @@ sub reset_for_next_message { } sub respond { - my $self = shift; + my Qpsmtpd::PollServer $self = shift; my ($code, @messages) = @_; while (my $msg = shift @messages) { my $line = $code . (@messages ? "-" : " ") . $msg; @@ -95,22 +96,16 @@ sub respond { } sub fault { - my $self = shift; + my Qpsmtpd::PollServer $self = shift; $self->SUPER::fault(@_); return; } sub process_line { - my $self = shift; + my Qpsmtpd::PollServer $self = shift; my $line = shift || return; if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; } - local $SIG{ALRM} = sub { - my ($pkg, $file, $line) = caller(); - die "ALARM: ($self->{mode}) $pkg, $file, $line"; - }; - my $prev = alarm($self->{cmd_timeout}); # must process a command in < N seconds eval { $self->_process_line($line) }; - alarm($prev); if ($@) { print STDERR "Error: $@\n"; return $self->fault("command failed unexpectedly") if $self->{mode} eq 'cmd'; @@ -121,7 +116,7 @@ sub process_line { } sub _process_line { - my $self = shift; + my Qpsmtpd::PollServer $self = shift; my $line = shift; if ($self->{mode} eq 'connect') { @@ -142,7 +137,7 @@ sub _process_line { } sub process_cmd { - my $self = shift; + my Qpsmtpd::PollServer $self = shift; my $line = shift; my ($cmd, @params) = split(/ +/, $line); my $meth = lc($cmd); @@ -158,25 +153,21 @@ sub process_cmd { } return $resp; } - elsif ( $self->authenticated == AUTH_PENDING ) { - return $self->auth_process($line); - } else { # No such method - i.e. unrecognized command my ($rc, $msg) = $self->run_hooks("unrecognized_command", $meth, @params); - return $self->unrecognized_command_respond($rc, $msg) unless $rc == CONTINUATION; return 1; } } sub disconnect { - my $self = shift; + my Qpsmtpd::PollServer $self = shift; $self->SUPER::disconnect(@_); $self->close; } sub start_conversation { - my $self = shift; + my Qpsmtpd::PollServer $self = shift; my $conn = $self->connection; # set remote_host, remote_ip and remote_port @@ -184,28 +175,26 @@ sub start_conversation { $conn->remote_ip($ip); $conn->remote_port($port); $conn->remote_info("[$ip]"); - Danga::DNS->new( - client => $self, + ParaDNS->new( + finished => sub { $self->run_hooks("connect") }, # NB: Setting remote_info to the same as remote_host callback => sub { $conn->remote_info($conn->remote_host($_[0])) }, host => $ip, ); - my ($rc, $msg) = $self->run_hooks("connect"); - return $self->connect_respond($rc, $msg) unless $rc == CONTINUATION; - return DONE; + return; } sub data { - my $self = shift; + my Qpsmtpd::PollServer $self = shift; my ($rc, $msg) = $self->run_hooks("data"); - return $self->data_respond($rc, $msg) unless $rc == CONTINUATION; return 1; } sub data_respond { - my ($self, $rc, $msg) = @_; + my Qpsmtpd::PollServer $self = shift; + my ($rc, $msg) = @_; if ($rc == DONE) { return; } @@ -234,18 +223,83 @@ sub data_respond { $self->{mode} = 'data'; - $self->{header_lines} = []; + $self->{header_lines} = ''; $self->{data_size} = 0; $self->{in_header} = 1; - $self->{max_size} = ($self->config('databytes'))[0] || 0; # this should work in scalar context + $self->{max_size} = ($self->config('databytes'))[0] || 0; $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}"); + + $self->respond(354, "go ahead"); + + my $max_get = $self->{max_size} || 1048576; + $self->get_chunks($max_get, sub { $self->got_data($_[0]) }); + return 1; +} + +sub got_data { + my Qpsmtpd::PollServer $self = shift; + my $data = shift; + + my $done = 0; + my $remainder; + if ($data =~ s/^\.\r\n(.*)\z//m) { + $remainder = $1; + $done = 1; + } + + # add a transaction->blocked check back here when we have line by line plugin access... + unless (($self->{max_size} and $self->{data_size} > $self->{max_size})) { + $data =~ s/\r\n/\n/mg; + $data =~ s/^\.\./\./mg; + + if ($self->{in_header} and $data =~ s/\A(.*?)\n[ \t]*\n//ms) { + $self->{header_lines} .= $1; + # end of headers + $self->{in_header} = 0; + + # ... need to check that we don't reformat any of the received lines. + # + # 3.8.2 Received Lines in Gatewaying + # When forwarding a message into or out of the Internet environment, a + # gateway MUST prepend a Received: line, but it MUST NOT alter in any + # way a Received: line that is already in the header. + my @header_lines = split(/\n/, $self->{header_lines}); - return $self->respond(354, "go ahead"); + my $header = Mail::Header->new(\@header_lines, + Modify => 0, MailFrom => "COERCE"); + $self->transaction->header($header); + $self->{header_lines} = ''; + + #$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/"); + + # FIXME - call plugins to work on just the header here; can + # save us buffering the mail content. + } + + if ($self->{in_header}) { + $self->{header_lines} .= $data; + } + else { + $self->transaction->body_write(\$data); + } + + $self->{data_size} += length $data; + } + + + if ($done) { + $self->{mode} = 'cmd'; + $self->end_of_data; + $self->end_get_chunks($remainder); + } + } sub data_line { - my $self = shift; + my Qpsmtpd::PollServer $self = shift; + + print "YIKES\n"; my $line = shift; @@ -293,7 +347,7 @@ sub data_line { push @{ $self->{header_lines} }, $line; } else { - $self->transaction->body_write($line); + $self->transaction->body_write(\$line); } $self->{data_size} += length $line; @@ -303,7 +357,7 @@ sub data_line { } sub end_of_data { - my $self = shift; + my Qpsmtpd::PollServer $self = shift; #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); @@ -331,7 +385,6 @@ sub end_of_data { return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size}; my ($rc, $msg) = $self->run_hooks("data_post"); - return $self->data_post_respond($rc, $msg) unless $rc == CONTINUATION; return 1; } diff --git a/lib/Qpsmtpd/Postfix.pm b/lib/Qpsmtpd/Postfix.pm index bf594ca..128089d 100644 --- a/lib/Qpsmtpd/Postfix.pm +++ b/lib/Qpsmtpd/Postfix.pm @@ -162,7 +162,7 @@ sub inject_mail { my %at = $strm->get_attr; my $qid = $at{queue_id}; print STDERR "qid=$qid\n"; - $strm->print_attr('flags' => '0000'); + $strm->print_attr('flags' => $transaction->notes('postfix-queue-flags')); $strm->print_rec_time(); $strm->print_rec('REC_TYPE_FROM', $transaction->sender->address|| ""); for (map { $_->address } $transaction->recipients) { diff --git a/lib/Qpsmtpd/Postfix/Constants.pm b/lib/Qpsmtpd/Postfix/Constants.pm new file mode 100644 index 0000000..c06ad3f --- /dev/null +++ b/lib/Qpsmtpd/Postfix/Constants.pm @@ -0,0 +1,86 @@ +# +# Qpsmtpd::Postfix::Constants +# +# This is a generated file, do not edit +# +# created by pf2qp.pl v0.1 @ Sun Oct 29 09:10:18 2006 +# postfix version 2.4 +# +package Qpsmtpd::Postfix::Constants; + +use Qpsmtpd::Constants; + +require Exporter; + +use vars qw(@ISA @EXPORT %cleanup_soft %cleanup_hard $postfix_version); +use strict; + +@ISA = qw(Exporter); +@EXPORT = qw( + %cleanup_soft + %cleanup_hard + $postfix_version + CLEANUP_FLAG_NONE + CLEANUP_FLAG_BOUNCE + CLEANUP_FLAG_FILTER + CLEANUP_FLAG_HOLD + CLEANUP_FLAG_DISCARD + CLEANUP_FLAG_BCC_OK + CLEANUP_FLAG_MAP_OK + CLEANUP_FLAG_MILTER + CLEANUP_FLAG_FILTER_ALL + CLEANUP_FLAG_MASK_EXTERNAL + CLEANUP_FLAG_MASK_INTERNAL + CLEANUP_FLAG_MASK_EXTRA + CLEANUP_STAT_OK + CLEANUP_STAT_BAD + CLEANUP_STAT_WRITE + CLEANUP_STAT_SIZE + CLEANUP_STAT_CONT + CLEANUP_STAT_HOPS + CLEANUP_STAT_RCPT + CLEANUP_STAT_PROXY + CLEANUP_STAT_DEFER + CLEANUP_STAT_MASK_CANT_BOUNCE + CLEANUP_STAT_MASK_INCOMPLETE +); + +$postfix_version = "2.4"; +use constant CLEANUP_FLAG_NONE => 0; # /* No special features */ +use constant CLEANUP_FLAG_BOUNCE => (1<<0); # /* Bounce bad messages */ +use constant CLEANUP_FLAG_FILTER => (1<<1); # /* Enable header/body checks */ +use constant CLEANUP_FLAG_HOLD => (1<<2); # /* Place message on hold */ +use constant CLEANUP_FLAG_DISCARD => (1<<3); # /* Discard message silently */ +use constant CLEANUP_FLAG_BCC_OK => (1<<4); # /* Ok to add auto-BCC addresses */ +use constant CLEANUP_FLAG_MAP_OK => (1<<5); # /* Ok to map addresses */ +use constant CLEANUP_FLAG_MILTER => (1<<6); # /* Enable Milter applications */ +use constant CLEANUP_FLAG_FILTER_ALL => (CLEANUP_FLAG_FILTER | CLEANUP_FLAG_MILTER); +use constant CLEANUP_FLAG_MASK_EXTERNAL => (CLEANUP_FLAG_FILTER_ALL | CLEANUP_FLAG_BCC_OK | CLEANUP_FLAG_MAP_OK); +use constant CLEANUP_FLAG_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_BAD => (1<<0); # /* Internal protocol error */ +use constant CLEANUP_STAT_WRITE => (1<<1); # /* Error writing message file */ +use constant CLEANUP_STAT_SIZE => (1<<2); # /* Message file too big */ +use constant CLEANUP_STAT_CONT => (1<<3); # /* Message content rejected */ +use constant CLEANUP_STAT_HOPS => (1<<4); # /* Too many hops */ +use constant CLEANUP_STAT_RCPT => (1<<6); # /* No recipients found */ +use constant CLEANUP_STAT_PROXY => (1<<7); # /* Proxy reject */ +use constant CLEANUP_STAT_DEFER => (1<<8); # /* Temporary reject */ +use constant CLEANUP_STAT_MASK_CANT_BOUNCE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_DEFER); +use constant CLEANUP_STAT_MASK_INCOMPLETE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_SIZE | CLEANUP_STAT_DEFER); + +%cleanup_soft = ( + CLEANUP_STAT_DEFER => "service unavailable (#4.7.1)", + CLEANUP_STAT_PROXY => "queue file write error (#4.3.0)", + CLEANUP_STAT_BAD => "internal protocol error (#4.3.0)", + CLEANUP_STAT_WRITE => "queue file write error (#4.3.0)", +); +%cleanup_hard = ( + CLEANUP_STAT_RCPT => "no recipients specified (#5.1.0)", + CLEANUP_STAT_HOPS => "too many hops (#5.4.0)", + CLEANUP_STAT_SIZE => "message file too big (#5.3.4)", + CLEANUP_STAT_CONT => "message content rejected (#5.7.1)", +); +1; diff --git a/lib/Qpsmtpd/Postfix/pf2qp.pl b/lib/Qpsmtpd/Postfix/pf2qp.pl new file mode 100755 index 0000000..0cd7894 --- /dev/null +++ b/lib/Qpsmtpd/Postfix/pf2qp.pl @@ -0,0 +1,115 @@ +#/usr/bin/perl -w +# +# +my $version = "0.1"; +$0 =~ s#.*/##; +my $path = $&; # sneaky way to get path back + +my $POSTFIX_SRC = shift || die <<"EOF"; +Usage: + $0 /path/to/postfix/source + +EOF + +my $header = "$POSTFIX_SRC/src/global/cleanup_user.h"; +my $src = "$POSTFIX_SRC/src/global/cleanup_strerror.c"; +my $pf_vers = "$POSTFIX_SRC/src/global/mail_version.h"; +my $postfix_version = ""; + +open VERS, $pf_vers + or die "Could not open $pf_vers: $!\n"; +while () { + next unless /^\s*#\s*define\s+MAIL_VERSION_NUMBER\s+"(.+)"\s*$/; + $postfix_version = $1; + last; +} +close VERS; +$postfix_version =~ s/^(\d+\.\d+).*/$1/; +if ($postfix_version < 2.3) { + die "Need at least postfix v2.3"; +} +my $start = <<'_END'; +# +# Qpsmtpd::Postfix::Constants +# +# This is a generated file, do not edit +# +_END +$start .= "# created by $0 v$version @ ".scalar(gmtime)."\n" + ."# postfix version $postfix_version\n" + ."#\n"; +$start .= <<'_END'; +package Qpsmtpd::Postfix::Constants; + +use Qpsmtpd::Constants; + +require Exporter; + +use vars qw(@ISA @EXPORT %cleanup_soft %cleanup_hard $postfix_version); +use strict; + +@ISA = qw(Exporter); +_END + +my @export = qw(%cleanup_soft %cleanup_hard $postfix_version); +my @out = (); + +open HEAD, $header + or die "Could not open $header: $!\n"; + +while () { + while (s/\\\n$//) { + $_ .= ; + } + chomp; + if (/^\s*#define\s/) { + s/^\s*#define\s*//; + next if /^_/; + s#(/\*.*\*/)##; + my $comment = $1 || ""; + my @words = split ' ', $_; + my $const = shift @words; + if ($const eq "CLEANUP_STAT_OK") { + push @out, ""; + } + push @export, $const; + push @out, "use constant $const => ". join(" ", @words). "; " + .($comment ? "# $comment ": ""); + } +} +close HEAD; + +open SRC, $src + or die "Could not open $src: $!\n"; +my $data; +{ + local $/ = undef; + $data = ; +} +close SRC; +$data =~ s/.*cleanup_stat_map\[\]\s*=\s*{\s*\n//s; +$data =~ s/};.*$//s; +my @array = split "\n", $data; +my (@denysoft,@denyhard); +foreach (@array) { + chomp; + s/,/ => /; + s/"(\d\.\d\.\d)",\s+"(.*)",/"$2 (#$1)",/; + s!(/\*.*\*/)!# $1!; + s/4\d\d,\s// && push @denysoft, $_; + s/5\d\d,\s// && push @denyhard, $_; +} + +open my $CONSTANTS, '>', "$path/Constants.pm"; + +print ${CONSTANTS} $start, '@EXPORT = qw(', "\n"; +while (@export) { + print ${CONSTANTS} "\t", shift @export, "\n"; +} +print ${CONSTANTS} ");\n\n", + "\$postfix_version = \"$postfix_version\";\n", + join("\n", @out),"\n\n"; +print ${CONSTANTS} "\%cleanup_soft = (\n", join("\n", @denysoft), "\n);\n\n"; +print ${CONSTANTS} "\%cleanup_hard = (\n", join("\n", @denyhard), "\n);\n\n1;\n"; + +close $CONSTANTS; diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index ec29377..bc69fc5 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -1,17 +1,21 @@ package Qpsmtpd::SMTP; use Qpsmtpd; @ISA = qw(Qpsmtpd); +my %auth_mechanisms = (); package Qpsmtpd::SMTP; use strict; use Carp; +use Qpsmtpd::Connection; +use Qpsmtpd::Transaction; use Qpsmtpd::Plugin; use Qpsmtpd::Constants; +use Qpsmtpd::Auth; use Qpsmtpd::Address (); +use Qpsmtpd::Command; use Mail::Header (); -use MIME::Base64; #use Data::Dumper; use POSIX qw(strftime); use Net::DNS; @@ -30,7 +34,7 @@ sub new { my $self = bless ({ args => \%args }, $class); my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit); - my (%commands); @commands{@commands} = (1) x @commands; + my (%commands); @commands{@commands} = ('') x @commands; # this list of valid commands should probably be a method or a set of methods $self->{_commands} = \%commands; @@ -48,15 +52,9 @@ sub dispatch { $self->{_counter}++; - if ( $self->authenticated == AUTH_PENDING ) { - # must be in the middle of prompting for auth parameters - return $self->auth_process($cmd,@_); - } - if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { - my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd, @_); - return $self->unrecognized_command_respond($rc, $msg, @_) unless $rc == CONTINUATION; - return 1; + $self->run_hooks("unrecognized_command", $cmd, @_); + return 1 } $cmd = $1; @@ -73,11 +71,11 @@ sub dispatch { sub unrecognized_command_respond { my ($self, $rc, $msg) = @_; if ($rc == DENY_DISCONNECT) { - $self->respond(521, $msg); + $self->respond(521, @$msg); $self->disconnect; } elsif ($rc == DENY) { - $self->respond(500, $msg); + $self->respond(500, @$msg); } elsif ($rc != DONE) { $self->respond(500, "Unrecognized command"); @@ -87,7 +85,8 @@ sub unrecognized_command_respond { sub fault { my $self = shift; my ($msg) = shift || "program fault - command not performed"; - print STDERR "$0[$$]: $msg ($!)\n"; + my ($name) = split /\s+/, $0, 2; + print STDERR $name,"[$$]: $msg ($!)\n"; return $self->respond(451, "Internal error - try again later - " . $msg); } @@ -96,106 +95,122 @@ sub start_conversation { my $self = shift; # this should maybe be called something else than "connect", see # lib/Qpsmtpd/TcpServer.pm for more confusion. - my ($rc, $msg) = $self->run_hooks("connect"); - return $self->connect_respond($rc, $msg) unless $rc == CONTINUATION; + $self->run_hooks("connect"); return DONE; } sub connect_respond { my ($self, $rc, $msg) = @_; - if ($rc == DENY) { - $self->respond(550, ($msg || 'Connection from you denied, bye bye.')); + if ($rc == DENY || $rc == DENY_DISCONNECT) { + $msg->[0] ||= 'Connection from you denied, bye bye.'; + $self->respond(550, @$msg); $self->disconnect; - return $rc; } - elsif ($rc == DENYSOFT) { - $self->respond(450, ($msg || 'Connection from you temporarily denied, bye bye.')); + elsif ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { + $msg->[0] ||= 'Connection from you temporarily denied, bye bye.'; + $self->respond(450, @$msg); $self->disconnect; - return $rc; - } - elsif ($rc == DONE) { - return $rc; } elsif ($rc != DONE) { my $greets = $self->config('smtpgreeting'); if ( $greets ) { - $greets .= " ESMTP"; + $greets .= " ESMTP" unless $greets =~ /(^|\W)ESMTP(\W|$)/; } else { - $greets = $self->config('me') - . " ESMTP qpsmtpd " - . $self->version - . " ready; send us your mail, but not your spam."; + $greets = $self->config('me') + . " ESMTP qpsmtpd " + . $self->version + . " ready; send us your mail, but not your spam."; } $self->respond(220, $greets); - return DONE; } } +sub transaction { + my $self = shift; + return $self->{_transaction} || $self->reset_transaction(); +} + +sub reset_transaction { + my $self = shift; + $self->run_hooks("reset_transaction") if $self->{_transaction}; + return $self->{_transaction} = Qpsmtpd::Transaction->new(); +} + + +sub connection { + my $self = shift; + @_ and $self->{_connection} = shift; + return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new()); +} + + sub helo { - my ($self, $hello_host, @stuff) = @_; + my ($self, $line) = @_; + my ($rc, @msg) = $self->run_hooks('helo_parse'); + my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('helo', $line, $msg[0]); + return $self->respond (501, "helo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host; my $conn = $self->connection; return $self->respond (503, "but you already said HELO ...") if $conn->hello; - my ($rc, $msg) = $self->run_hooks("helo", $hello_host, @stuff); - return $self->helo_respond($rc, $msg, $hello_host, @stuff) unless $rc == CONTINUATION; - return 1; + $self->run_hooks("helo", $hello_host, @stuff); } sub helo_respond { - my ($self, $rc, $msg, $hello_host) = @_; - if ($rc == DENY) { - $self->respond(550, $msg); - } - elsif ($rc == DENYSOFT) { - $self->respond(450, $msg); + my ($self, $rc, $msg, $args) = @_; + my ($hello_host) = @$args; + if ($rc == DONE) { + # do nothing + } elsif ($rc == DENY) { + $self->respond(550, @$msg); + } elsif ($rc == DENYSOFT) { + $self->respond(450, @$msg); } elsif ($rc == DENY_DISCONNECT) { - $self->respond(550, $msg); + $self->respond(550, @$msg); $self->disconnect; } elsif ($rc == DENYSOFT_DISCONNECT) { - $self->respond(450, $msg); + $self->respond(450, @$msg); $self->disconnect; - } - elsif ($rc != DONE) { + } else { my $conn = $self->connection; $conn->hello("helo"); $conn->hello_host($hello_host); $self->transaction; - $self->respond(250, $self->config('me') ." Hi " . $conn->remote_info . - " [" . $conn->remote_ip ."]; I am so happy to meet you."); + $self->respond(250, $self->config('me') ." Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]; I am so happy to meet you."); } } sub ehlo { - my ($self, $hello_host, @stuff) = @_; + my ($self, $line) = @_; + my ($rc, @msg) = $self->run_hooks('ehlo_parse'); + my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('ehlo', $line, $msg[0]); return $self->respond (501, "ehlo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host; my $conn = $self->connection; return $self->respond (503, "but you already said HELO ...") if $conn->hello; - my ($rc, $msg) = $self->run_hooks("ehlo", $hello_host, @stuff); - return $self->ehlo_respond($rc, $msg, $hello_host, @stuff) unless $rc == CONTINUATION; - return 1; + $self->run_hooks("ehlo", $hello_host, @stuff); } sub ehlo_respond { - my ($self, $rc, $msg, $hello_host) = @_; - if ($rc == DENY) { - $self->respond(550, $msg); - } - elsif ($rc == DENYSOFT) { - $self->respond(450, $msg); + my ($self, $rc, $msg, $args) = @_; + my ($hello_host) = @$args; + if ($rc == DONE) { + # do nothing + } elsif ($rc == DENY) { + $self->respond(550, @$msg); + } elsif ($rc == DENYSOFT) { + $self->respond(450, @$msg); } elsif ($rc == DENY_DISCONNECT) { - $self->respond(550, $msg); + $self->respond(550, @$msg); $self->disconnect; } elsif ($rc == DENYSOFT_DISCONNECT) { - $self->respond(450, $msg); + $self->respond(450, @$msg); $self->disconnect; - } - elsif ($rc != DONE) { + } else { my $conn = $self->connection; $conn->hello("ehlo"); $conn->hello_host($hello_host); @@ -203,10 +218,9 @@ sub ehlo_respond { my @capabilities = $self->transaction->notes('capabilities') ? @{ $self->transaction->notes('capabilities') } - : (); + : (); # Check for possible AUTH mechanisms - my %auth_mechanisms; HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { if ( $hook =~ m/^auth-?(.+)?$/ ) { if ( defined $1 ) { @@ -219,9 +233,11 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { } } - if ( %auth_mechanisms ) { + # Check if we should only offer AUTH after TLS is completed + my $tls_before_auth = ($self->config('tls_before_auth') ? ($self->config('tls_before_auth'))[0] && $self->transaction->notes('tls_enabled') : 0); + if ( %auth_mechanisms && !$tls_before_auth) { push @capabilities, 'AUTH '.join(" ",keys(%auth_mechanisms)); - $self->{_commands}->{'auth'} = "1"; + $self->{_commands}->{'auth'} = ""; } $self->respond(250, @@ -234,154 +250,44 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { } } -sub e64 -{ - my ($arg) = @_; - my $res = encode_base64($arg); - chomp($res); - return($res); +sub auth { + my ($self, $line) = @_; + $self->run_hooks('auth_parse', $line); } -sub auth { - my ( $self, $mechanism, $prekey ) = @_; +sub auth_parse_respond { + my ($self, $rc, $msg, $args) = @_; + my ($line) = @$args; + + my ($ok, $mechanism, @stuff) = Qpsmtpd::Command->parse('auth', $line, $msg->[0]); + return $self->respond(501, $mechanism || "Syntax error in command") + unless ($ok == OK); + + $mechanism = lc($mechanism); + #they AUTH'd once already return $self->respond( 503, "but you already said AUTH ..." ) - if ( $self->authenticated == OK ); + if ( defined $self->{_auth} + and $self->{_auth} == OK ); return $self->respond( 503, "AUTH not defined for HELO" ) if ( $self->connection->hello eq "helo" ); + return $self->respond( 503, "SSL/TLS required before AUTH" ) + if ( ($self->config('tls_before_auth'))[0] + and $self->transaction->notes('tls_enabled') ); - # $DB::single = 1; + # if we don't have a plugin implementing this auth mechanism, 504 + if( exists $auth_mechanisms{uc($mechanism)} ) { + return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $mechanism, @stuff ); + } else { + $self->respond( 504, "Unimplemented authentification mechanism: $mechanism" ); + return DENY; + } - $self->auth_mechanism($mechanism); - $self->authenticated(AUTH_PENDING); - if ( $prekey ) { # easy single step - unless ( $mechanism =~ /^(plain|login)$/i ) { - # must be plain or login - $self->respond( 500, "Unrecognized authentification mechanism" ); - return DECLINED; - } - my ($passHash, $user, $passClear) = split /\x0/,decode_base64($prekey); - # we have all of the elements ready to go now - if ( $mechanism =~ /login/i ) { - $self->auth_user($user); - return $self->auth_process(e64($passClear)); - } - else { - return $self->auth_process($prekey); - } - } - else { - if ( $mechanism =~ /plain/i ) { - $self->respond( 334, "Please continue" ); - } - elsif ( $mechanism =~ /login/i ) { - $self->respond( 334, e64("Username:") ); - } - elsif ( $mechanism =~ /cram-md5/i ) { - # rand() is not cryptographic, but we only need to generate a globally - # unique number. The rand() is there in case the user logs in more than - # once in the same second, or if the clock is skewed. - my $ticket = sprintf( "<%x.%x\@" . $self->config("me") . ">", - rand(1000000), time() ); - - # Store this for later - $self->auth_ticket($ticket); - # We send the ticket encoded in Base64 - $self->respond( 334, encode_base64( $ticket, "" ) ); - } - } - return DECLINED; -} - -sub auth_process { - my ($self, $line) = @_; - my ( $user, $passClear, $passHash, $ticket, $mechanism ); - - # do this once here - $mechanism = $self->auth_mechanism; - $user = $self->auth_user; - $ticket = $self->auth_ticket; - - if ( $mechanism eq 'plain' ) { - ( $passHash, $user, $passClear ) = split /\x0/, - decode_base64($line); - } - elsif ( $mechanism eq 'login' ) { - if ( $user ) { - # must be getting the password now - $passClear = decode_base64($line); - } - else { - # must be getting the user now - $user = decode_base64($line); - $self->auth_user($user); - $self->respond(334, e64("Password:")); - } - } - elsif ( $mechanism eq "cram-md5" ) { - $line =~ tr/[\r\n]//d; # cannot simply chomp CRLF - - ( $user, $passHash ) = split( ' ', decode_base64($line) ); - - } - else { - $self->respond( 500, "Unrecognized authentification mechanism" ); - return DECLINED; - } - if ($user eq '*') { - $self->respond(501, "Authentification canceled"); - return DECLINED; - } - - # check to see if we can proceed with the hooks - if ( $user and ( $passClear or $passHash ) ) { - # try running the specific hooks first - my ( $rc, $msg ) = - $self->run_hooks( "auth-$mechanism", - $mechanism, $user, $passClear, - $passHash, $ticket ); - - # try running the polymorphous hooks next - if ( !$rc || $rc == DECLINED ) { - ( $rc, $msg ) = - $self->run_hooks( "auth", $mechanism, $user, $passClear, - $passHash, $ticket ); - } - return $self->auth_respond($rc, $msg, $mechanism, $user) - unless $rc == CONTINUATION; - } - else { - return CONTINUATION; - } -} - - -sub auth_respond { - my ($self, $rc, $msg, $mechanism, $user) = @_; - if ( $rc == OK ) { - $msg = "Authentication successful for $user" . - ( defined $msg ? " - " . $msg : "" ); - $self->respond( 235, $msg ); - $self->connection->relay_client(1); - $self->log( LOGINFO, $msg ); - $self->authenticated(OK); - - return OK; - } - else { - $msg = "Authentication failed for $user" . - ( defined $msg ? " - " . $msg : "" ); - $self->respond( 535, $msg ); - $self->log( LOGERROR, $msg ); - return DENY; - } } sub mail { - my $self = shift; - return $self->respond(501, "syntax error in parameters") if !$_[0] or $_[0] !~ m/^from:/i; - + my ($self, $line) = @_; # -> from RFC2821 # The MAIL command (or the obsolete SEND, SOML, or SAML commands) # begins a mail transaction. Once started, a mail transaction @@ -405,105 +311,158 @@ sub mail { unless ($self->connection->hello) { return $self->respond(503, "please say hello first ..."); } - - my $from_parameter = join " ", @_; - $self->log(LOGINFO, "full from_parameter: $from_parameter"); - - my ($from) = ($from_parameter =~ m/^from:\s*(<[^>]*>)/i)[0]; - - # support addresses without <> ... maybe we shouldn't? - ($from) = "<" . ($from_parameter =~ m/^from:\s*(\S+)/i)[0] . ">" - unless $from; - - $self->log(LOGALERT, "from email address : [$from]"); - - if ($from eq "<>" or $from =~ m/\[undefined\]/ or $from eq "<#@[]>") { - $from = Qpsmtpd::Address->new("<>"); - } else { - $from = (Qpsmtpd::Address->parse($from))[0]; + $self->log(LOGINFO, "full from_parameter: $line"); + $self->run_hooks("mail_parse", $line); } - return $self->respond(501, "could not parse your mail from command") unless $from; +} - my ($rc, $msg) = $self->run_hooks("mail", $from); - return $self->mail_respond($rc, $msg, $from) unless $rc == CONTINUATION; - return 1; +sub mail_parse_respond { + my ($self, $rc, $msg, $args) = @_; + my ($line) = @$args; + my ($ok, $from, @params) = Qpsmtpd::Command->parse('mail', $line, $msg->[0]); + return $self->respond(501, $from || "Syntax error in command") + unless ($ok == OK); + my %param; + foreach (@params) { + my ($k,$v) = split /=/, $_, 2; + $param{lc $k} = $v; + } + # to support addresses without <> we now require a plugin + # hooking "mail_pre" to + # return (OK, "<$from>"); + # (...or anything else parseable by Qpsmtpd::Address ;-)) + # see also comment in sub rcpt() + $self->run_hooks("mail_pre", $from, \%param); +} + +sub mail_pre_respond { + my ($self, $rc, $msg, $args) = @_; + my ($from, $param) = @$args; + if ($rc == OK) { + $from = shift @$msg; + } + + $self->log(LOGALERT, "from email address : [$from]"); + return $self->respond(501, "could not parse your mail from command") + unless $from =~ /^<.*>$/; + + if ($from eq "<>" or $from =~ m/\[undefined\]/ or $from eq "<#@[]>") { + $from = Qpsmtpd::Address->new("<>"); + } + else { + $from = (Qpsmtpd::Address->parse($from))[0]; + } + return $self->respond(501, "could not parse your mail from command") unless $from; + + $self->run_hooks("mail", $from, %$param); } sub mail_respond { - my ($self, $rc, $msg, $from) = @_; - if ($rc == DONE) { - return 1; - } - elsif ($rc == DENY) { - $msg ||= $from->format . ', denied'; - $self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)"); - $self->respond(550, $msg); - } - elsif ($rc == DENYSOFT) { - $msg ||= $from->format . ', temporarily denied'; - $self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)"); - $self->respond(450, $msg); - } - elsif ($rc == DENY_DISCONNECT) { - $msg ||= $from->format . ', denied'; - $self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)"); - $self->respond(550, $msg); - $self->disconnect; - } - elsif ($rc == DENYSOFT_DISCONNECT) { - $msg ||= $from->format . ', temporarily denied'; - $self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)"); - $self->respond(450, $msg); - $self->disconnect; - } - else { # includes OK - $self->log(LOGINFO, "getting mail from ".$from->format); - $self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!"); - $self->transaction->sender($from); - } + my ($self, $rc, $msg, $args) = @_; + my ($from, $param) = @$args; + if ($rc == DONE) { + return 1; + } + elsif ($rc == DENY) { + $msg->[0] ||= $from->format . ', denied'; + $self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)"); + $self->respond(550, @$msg); + } + elsif ($rc == DENYSOFT) { + $msg->[0] ||= $from->format . ', temporarily denied'; + $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)"); + $self->respond(450, @$msg); + } + elsif ($rc == DENY_DISCONNECT) { + $msg->[0] ||= $from->format . ', denied'; + $self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)"); + $self->respond(550, @$msg); + $self->disconnect; + } + elsif ($rc == DENYSOFT_DISCONNECT) { + $msg->[0] ||= $from->format . ', temporarily denied'; + $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)"); + $self->respond(421, @$msg); + $self->disconnect; + } + else { # includes OK + $self->log(LOGINFO, "getting mail from ".$from->format); + $self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!"); + $self->transaction->sender($from); + } } sub rcpt { - my $self = shift; - return $self->respond(501, "syntax error in parameters") unless $_[0] and $_[0] =~ m/^to:/i; + my ($self, $line) = @_; + $self->run_hooks("rcpt_parse", $line); +} + +sub rcpt_parse_respond { + my ($self, $rc, $msg, $args) = @_; + my ($line) = @$args; + my ($ok, $rcpt, @param) = Qpsmtpd::Command->parse("rcpt", $line, $msg->[0]); + return $self->respond(501, $rcpt || "Syntax error in command") + unless ($ok == OK); return $self->respond(503, "Use MAIL before RCPT") unless $self->transaction->sender; - my ($rcpt) = ($_[0] =~ m/to:(.*)/i)[0]; - $rcpt = $_[1] unless $rcpt; + my %param; + foreach (@param) { + my ($k,$v) = split /=/, $_, 2; + $param{lc $k} = $v; + } + # to support addresses without <> we now require a plugin + # hooking "rcpt_pre" to + # return (OK, "<$rcpt>"); + # (... or anything else parseable by Qpsmtpd::Address ;-)) + # this means, a plugin can decide to (pre-)accept + # addresses like or + # by removing the trailing "."/" " from this example... + $self->run_hooks("rcpt_pre", $rcpt, \%param); +} + +sub rcpt_pre_respond { + my ($self, $rc, $msg, $args) = @_; + my ($rcpt, $param) = @$args; + if ($rc == OK) { + $rcpt = shift @$msg; + } $self->log(LOGALERT, "to email address : [$rcpt]"); + return $self->respond(501, "could not parse recipient") + unless $rcpt =~ /^<.*>$/; + $rcpt = (Qpsmtpd::Address->parse($rcpt))[0]; - return $self->respond(501, "could not parse recipient") unless $rcpt; + return $self->respond(501, "could not parse recipient") + if (!$rcpt or ($rcpt->format eq '<>')); - my ($rc, $msg) = $self->run_hooks("rcpt", $rcpt); - return $self->rcpt_respond($rc, $msg, $rcpt) unless $rc == CONTINUATION; - return 1; + $self->run_hooks("rcpt", $rcpt, %$param); } sub rcpt_respond { - my ($self, $rc, $msg, $rcpt) = @_; + my ($self, $rc, $msg, $args) = @_; + my ($rcpt, $param) = @$args; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { - $msg ||= 'relaying denied'; - $self->respond(550, $msg); + $msg->[0] ||= 'relaying denied'; + $self->respond(550, @$msg); } elsif ($rc == DENYSOFT) { - $msg ||= 'relaying denied'; - return $self->respond(450, $msg); + $msg->[0] ||= 'relaying denied'; + return $self->respond(450, @$msg); } elsif ($rc == DENY_DISCONNECT) { - $msg ||= 'delivery denied'; - $self->log(LOGINFO, "delivery denied ($msg)"); - $self->respond(550, $msg); + $msg->[0] ||= 'delivery denied'; + $self->log(LOGINFO, "delivery denied (@$msg)"); + $self->respond(550, @$msg); $self->disconnect; } elsif ($rc == DENYSOFT_DISCONNECT) { - $msg ||= 'relaying denied'; - $self->log(LOGINFO, "delivery denied ($msg)"); - $self->respond(421, $msg); + $msg->[0] ||= 'relaying denied'; + $self->log(LOGINFO, "delivery denied (@$msg)"); + $self->respond(421, @$msg); $self->disconnect; } elsif ($rc == OK) { @@ -520,7 +479,7 @@ sub help { my $self = shift; $self->respond(214, "This is qpsmtpd " . - $self->config('smtpgreeting') ? '' : $self->version, + ($self->config('smtpgreeting') ? '' : $self->version), "See http://smtpd.develooper.com/", 'To report bugs or send comments, mail to .'); } @@ -537,23 +496,23 @@ sub vrfy { # documented in RFC2821#3.5.1 # I also don't think it provides all the proper result codes. - my ($rc, $msg) = $self->run_hooks("vrfy"); - return $self->vrfy_respond($rc, $msg) unless $rc == CONTINUATION; - return 1; + $self->run_hooks("vrfy"); } sub vrfy_respond { - my ($self, $rc, $msg) = @_; + my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { - $self->respond(554, $msg || "Access Denied"); + $msg->[0] ||= "Access Denied"; + $self->respond(554, @$msg); $self->reset_transaction(); return 1; } elsif ($rc == OK) { - $self->respond(250, $msg || "User OK"); + $msg->[0] ||= "User OK"; + $self->respond(250, @$msg); return 1; } else { # $rc == DECLINED or anything else @@ -570,15 +529,14 @@ sub rset { sub quit { my $self = shift; - my ($rc, $msg) = $self->run_hooks("quit"); - return $self->quit_respond($rc, $msg) unless $rc == CONTINUATION; - return 1; + $self->run_hooks("quit"); } sub quit_respond { - my ($self, $rc, $msg) = @_; + my ($self, $rc, $msg, $args) = @_; if ($rc != DONE) { - $self->respond(221, $self->config('me') . " closing connection. Have a wonderful day."); + $msg->[0] ||= $self->config('me') . " closing connection. Have a wonderful day."; + $self->respond(221, @$msg); } $self->disconnect(); } @@ -589,37 +547,37 @@ sub disconnect { $self->reset_transaction; } -sub disconnect_respond { } - sub data { my $self = shift; - my ($rc, $msg) = $self->run_hooks("data"); - return $self->data_respond($rc, $msg) unless $rc == CONTINUATION; - return 1; + $self->run_hooks("data"); } sub data_respond { - my ($self, $rc, $msg) = @_; + my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { - $self->respond(554, $msg || "Message denied"); + $msg->[0] ||= "Message denied"; + $self->respond(554, @$msg); $self->reset_transaction(); return 1; } elsif ($rc == DENYSOFT) { - $self->respond(451, $msg || "Message denied temporarily"); + $msg->[0] ||= "Message denied temporarily"; + $self->respond(451, @$msg); $self->reset_transaction(); return 1; } elsif ($rc == DENY_DISCONNECT) { - $self->respond(554, $msg || "Message denied"); + $msg->[0] ||= "Message denied"; + $self->respond(554, @$msg); $self->disconnect; return 1; } elsif ($rc == DENYSOFT_DISCONNECT) { - $self->respond(421, $msg || "Message denied temporarily"); + $msg->[0] ||= "Message denied temporarily"; + $self->respond(421, @$msg); $self->disconnect; return 1; } @@ -677,8 +635,8 @@ sub data_respond { # FIXME - call plugins to work on just the header here; can # save us buffering the mail content. - # Save the start of just the body itself - $self->transaction->set_body_start(); + # Save the start of just the body itself + $self->transaction->set_body_start(); } @@ -700,44 +658,65 @@ sub data_respond { $self->transaction->header($header); my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; - my $authheader = ($self->authenticated == OK) - ? "(smtp-auth username $self->auth_user, mechanism $self->auth_mechanism)\n" - : ""; + my $esmtp = substr($smtp,0,1) eq "E"; + my $authheader; + my $sslheader; + + if (defined $self->connection->notes('tls_enabled') + and $self->connection->notes('tls_enabled')) { + $smtp .= "S" if $esmtp; # RFC3848 + $sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) "; + } + + if (defined $self->{_auth} and $self->{_auth} == OK) { + $smtp .= "A" if $esmtp; # RFC3848 + $authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n"; + } $header->add("Received", "from ".$self->connection->remote_info ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip . ")\n $authheader by ".$self->config('me')." (qpsmtpd/".$self->version - .") with $smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)), + .") with $sslheader$smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)), 0); # if we get here without seeing a terminator, the connection is # probably dead. - $self->respond(451, "Incomplete DATA"), return 1 unless $complete; + unless ( $complete ) { + $self->respond(451, "Incomplete DATA"); + $self->reset_transaction; # clean up after ourselves + return 1; + } #$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked); - $self->respond(552, "Message too big!"),return 1 if $max_size and $size > $max_size; + if ( $max_size and $size > $max_size ) { + $self->respond(552, "Message too big!"); + $self->reset_transaction; # clean up after ourselves + return 1; + } - ($rc, $msg) = $self->run_hooks("data_post"); - return $self->data_post_respond($rc, $msg) unless $rc == CONTINUATION; + $self->run_hooks("data_post"); } sub data_post_respond { - my ($self, $rc, $msg) = @_; + my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { - $self->respond(552, $msg || "Message denied"); + $msg->[0] ||= "Message denied"; + $self->respond(552, @$msg); } elsif ($rc == DENYSOFT) { - $self->respond(452, $msg || "Message denied temporarily"); + $msg->[0] ||= "Message denied temporarily"; + $self->respond(452, @$msg); } else { - $self->queue($self->transaction); + $self->queue($self->transaction); } # DATA is always the end of a "transaction" return $self->reset_transaction; + } sub getline { @@ -752,28 +731,53 @@ sub getline { sub queue { my ($self, $transaction) = @_; - my ($rc, $msg) = $self->run_hooks("queue"); - return $self->queue_respond($rc, $msg) unless $rc == CONTINUATION; - return 1; + # First fire any queue_pre hooks + $self->run_hooks("queue_pre"); +} + +sub queue_pre_respond { + my ($self, $rc, $msg, $args) = @_; + if ($rc == DONE) { + return 1; + } + elsif ($rc != OK and $rc != DECLINED and $rc != 0 ) { + return $self->log(LOGERROR, "pre plugin returned illegal value"); + return 0; + } + + # If we got this far, run the queue hooks + $self->run_hooks("queue"); } sub queue_respond { - my ($self, $rc, $msg) = @_; + my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc == OK) { - $self->respond(250, ($msg || 'Queued')); + $msg->[0] ||= 'Queued'; + $self->respond(250, @$msg); } elsif ($rc == DENY) { - $self->respond(552, $msg || "Message denied"); + $msg->[0] ||= 'Message denied'; + $self->respond(552, @$msg); } elsif ($rc == DENYSOFT) { - $self->respond(452, $msg || "Message denied temporarily"); + $msg->[0] ||= 'Message denied temporarily'; + $self->respond(452, @$msg); } else { - $self->respond(451, $msg || "Queuing declined or disabled; try again later" ); + $msg->[0] ||= 'Queuing declined or disabled; try again later'; + $self->respond(451, @$msg); } + + # And finally run any queue_post hooks + $self->run_hooks("queue_post"); +} + +sub queue_post_respond { + my ($self, $rc, $msg, $args) = @_; + $self->log(LOGERROR, @$msg) unless ($rc == OK or $rc == 0); } diff --git a/lib/Qpsmtpd/SMTP/Prefork.pm b/lib/Qpsmtpd/SMTP/Prefork.pm new file mode 100644 index 0000000..6c90386 --- /dev/null +++ b/lib/Qpsmtpd/SMTP/Prefork.pm @@ -0,0 +1,44 @@ +package Qpsmtpd::SMTP::Prefork; +use Qpsmtpd::SMTP; +use Qpsmtpd::Constants; +@ISA = qw(Qpsmtpd::SMTP); + +sub dispatch { + my $self = shift; + my ($cmd) = lc shift; + + $self->{_counter}++; + + if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { + my ($rc, @msg) = $self->run_hooks("unrecognized_command", $cmd, @_); + @msg = map { split /\n/ } @msg; + if ($rc == DENY_DISCONNECT) { + $self->respond(521, @msg); + $self->disconnect; + } + elsif ($rc == DENY) { + $self->respond(500, @msg); + } + elsif ($rc == DONE) { + 1; + } + else { + $self->respond(500, "Unrecognized command"); + } + 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; + return $self->fault("command '$cmd' failed unexpectedly"); + } + + return; +} diff --git a/lib/Qpsmtpd/SelectServer.pm b/lib/Qpsmtpd/SelectServer.pm new file mode 100644 index 0000000..9620785 --- /dev/null +++ b/lib/Qpsmtpd/SelectServer.pm @@ -0,0 +1,320 @@ +package Qpsmtpd::SelectServer; +use Qpsmtpd::SMTP; +use Qpsmtpd::Constants; +use IO::Socket; +use IO::Select; +use POSIX qw(strftime); +use Socket qw(CRLF); +use Fcntl; +use Tie::RefHash; +use Net::DNS; + +@ISA = qw(Qpsmtpd::SMTP); +use strict; + +our %inbuffer = (); +our %outbuffer = (); +our %ready = (); +our %lookup = (); +our %qp = (); +our %indata = (); + +tie %ready, 'Tie::RefHash'; +my $server; +my $select; + +our $QUIT = 0; + +$SIG{INT} = $SIG{TERM} = sub { $QUIT++ }; + +sub log { + my ($self, $trace, @log) = @_; + my $level = Qpsmtpd::TRACE_LEVEL(); + $level = $self->init_logger unless defined $level; + warn join(" ", fileno($self->client), @log), "\n" + if $trace <= $level; +} + +sub main { + my $class = shift; + my %opts = (LocalPort => 25, Reuse => 1, Listen => SOMAXCONN, @_); + $server = IO::Socket::INET->new(%opts) or die "Server: $@"; + print "Listening on $opts{LocalPort}\n"; + + nonblock($server); + + $select = IO::Select->new($server); + my $res = Net::DNS::Resolver->new; + + # TODO - make this more graceful - let all current SMTP sessions finish + # before quitting! + while (!$QUIT) { + foreach my $client ($select->can_read(1)) { + #print "Reading $client\n"; + if ($client == $server) { + my $client_addr; + $client = $server->accept(); + next unless $client; + my $ip = $client->peerhost; + my $bgsock = $res->bgsend($ip); + $select->add($bgsock); + $lookup{$bgsock} = $client; + } + elsif (my $qpclient = $lookup{$client}) { + my $packet = $res->bgread($client); + my $ip = $qpclient->peerhost; + my $hostname = $ip; + if ($packet) { + foreach my $rr ($packet->answer) { + if ($rr->type eq 'PTR') { + $hostname = $rr->rdatastr; + } + } + } + # $packet->print; + $select->remove($client); + delete($lookup{$client}); + my $qp = Qpsmtpd::SelectServer->new(); + $qp->client($qpclient); + $qp{$qpclient} = $qp; + $qp->log(LOGINFO, "Connection number " . keys(%qp)); + $inbuffer{$qpclient} = ''; + $outbuffer{$qpclient} = ''; + $ready{$qpclient} = []; + $qp->start_connection($ip, $hostname); + $qp->load_plugins; + my $rc = $qp->start_conversation; + if ($rc != DONE) { + close($client); + next; + } + $select->add($qpclient); + nonblock($qpclient); + } + else { + my $data = ''; + my $rv = $client->recv($data, POSIX::BUFSIZ(), 0); + + unless (defined($rv) && length($data)) { + freeclient($client) + unless ($! == POSIX::EWOULDBLOCK() || + $! == POSIX::EINPROGRESS() || + $! == POSIX::EINTR()); + next; + } + $inbuffer{$client} .= $data; + + while ($inbuffer{$client} =~ s/^([^\r\n]*)\r?\n//) { + #print "<$1\n"; + push @{$ready{$client}}, $1; + } + } + } + + #print "Processing...\n"; + foreach my $client (keys %ready) { + my $qp = $qp{$client}; + #print "Processing $client = $qp\n"; + foreach my $req (@{$ready{$client}}) { + if ($indata{$client}) { + $qp->data_line($req . CRLF); + } + else { + $qp->log(LOGINFO, "dispatching $req"); + defined $qp->dispatch(split / +/, $req, 2) + or $qp->respond(502, "command unrecognized: '$req'"); + } + } + delete $ready{$client}; + } + + #print "Writing...\n"; + foreach my $client ($select->can_write(1)) { + next unless $outbuffer{$client}; + #print "Writing to $client\n"; + + my $rv = $client->send($outbuffer{$client}, 0); + unless (defined($rv)) { + warn("I was told to write, but I can't: $!\n"); + next; + } + if ($rv == length($outbuffer{$client}) || + $! == POSIX::EWOULDBLOCK()) + { + #print "Sent all, or EWOULDBLOCK\n"; + if ($qp{$client}->{__quitting}) { + freeclient($client); + next; + } + substr($outbuffer{$client}, 0, $rv, ''); + delete($outbuffer{$client}) unless length($outbuffer{$client}); + } + else { + print "Error: $!\n"; + # Couldn't write all the data, and it wasn't because + # it would have blocked. Shut down and move on. + freeclient($client); + next; + } + } + } +} + +sub freeclient { + my $client = shift; + #print "Freeing client: $client\n"; + delete $inbuffer{$client}; + delete $outbuffer{$client}; + delete $ready{$client}; + delete $qp{$client}; + $select->remove($client); + close($client); +} + +sub start_connection { + my $self = shift; + my $remote_ip = shift; + my $remote_host = shift; + + $self->log(LOGNOTICE, "Connection from $remote_host [$remote_ip]"); + my $remote_info = 'NOINFO'; + + # if the local dns resolver doesn't filter it out we might get + # ansi escape characters that could make a ps axw do "funny" + # things. So to be safe, cut them out. + $remote_host =~ tr/a-zA-Z\.\-0-9//cd; + + $self->SUPER::connection->start(remote_info => $remote_info, + remote_ip => $remote_ip, + remote_host => $remote_host, + @_); +} + +sub client { + my $self = shift; + @_ and $self->{_client} = shift; + $self->{_client}; +} + +sub nonblock { + my $socket = shift; + my $flags = fcntl($socket, F_GETFL, 0) + or die "Can't get flags for socket: $!"; + fcntl($socket, F_SETFL, $flags | O_NONBLOCK) + or die "Can't set flags for socket: $!"; +} + +sub read_input { + my $self = shift; + die "read_input is disabled in SelectServer"; +} + +sub respond { + my ($self, $code, @messages) = @_; + my $client = $self->client || die "No client!"; + while (my $msg = shift @messages) { + my $line = $code . (@messages?"-":" ").$msg; + $self->log(LOGINFO, ">$line"); + $outbuffer{$client} .= "$line\r\n"; + } + return 1; +} + +sub disconnect { + my $self = shift; + #print "Disconnecting\n"; + $self->{__quitting} = 1; + $self->SUPER::disconnect(@_); +} + +sub data { + my $self = shift; + $self->respond(503, "MAIL first"), return 1 unless $self->transaction->sender; + $self->respond(503, "RCPT first"), return 1 unless $self->transaction->recipients; + $self->respond(354, "go ahead"); + $indata{$self->client()} = 1; + $self->{__buffer} = ''; + $self->{__size} = 0; + $self->{__blocked} = ""; + $self->{__in_header} = 1; + $self->{__complete} = 0; + $self->{__max_size} = $self->config('databytes') || 0; +} + +sub data_line { + my $self = shift; + local $_ = shift; + + if ($_ eq ".\r\n") { + $self->log(LOGDEBUG, "max_size: $self->{__max_size} / size: $self->{__size}"); + delete $indata{$self->client()}; + + my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; + + if (!$self->transaction->header) { + $self->transaction->header(Mail::Header->new(Modify => 0, MailFrom => "COERCE")); + } + $self->transaction->header->add("Received", "from ".$self->connection->remote_info + ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip + . ") by ".$self->config('me')." (qpsmtpd/".$self->version + .") with $smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)), + 0); + + #$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked); + $self->respond(552, "Message too big!"),return 1 if $self->{__max_size} and $self->{__size} > $self->{__max_size}; + + my ($rc, $msg) = $self->run_hooks("data_post"); + if ($rc == DONE) { + return 1; + } + elsif ($rc == DENY) { + $self->respond(552, $msg || "Message denied"); + } + elsif ($rc == DENYSOFT) { + $self->respond(452, $msg || "Message denied temporarily"); + } + else { + $self->queue($self->transaction); + } + + # DATA is always the end of a "transaction" + return $self->reset_transaction; + } + elsif ($_ eq ".\n") { + $self->respond(451, "See http://develooper.com/code/qpsmtpd/barelf.html"); + $self->{__quitting} = 1; + return; + } + + # add a transaction->blocked check back here when we have line by line plugin access... + unless (($self->{__max_size} and $self->{__size} > $self->{__max_size})) { + s/\r\n$/\n/; + s/^\.\./\./; + if ($self->{__in_header} and m/^\s*$/) { + $self->{__in_header} = 0; + my @header = split /\n/, $self->{__buffer}; + + # ... need to check that we don't reformat any of the received lines. + # + # 3.8.2 Received Lines in Gatewaying + # When forwarding a message into or out of the Internet environment, a + # gateway MUST prepend a Received: line, but it MUST NOT alter in any + # way a Received: line that is already in the header. + + my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + $header->extract(\@header); + $self->transaction->header($header); + $self->{__buffer} = ""; + } + + if ($self->{__in_header}) { + $self->{__buffer} .= $_; + } + else { + $self->transaction->body_write($_); + } + $self->{__size} += length $_; + } +} + +1; diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index 46022d7..d79423f 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -1,6 +1,7 @@ package Qpsmtpd::TcpServer; use Qpsmtpd::SMTP; use Qpsmtpd::Constants; +use Socket; @ISA = qw(Qpsmtpd::SMTP); use strict; @@ -12,12 +13,25 @@ my $first_0; sub start_connection { my $self = shift; - die "Qpsmtpd::TcpServer must be started by tcpserver\n" - unless $ENV{TCPREMOTEIP}; + my ($remote_host, $remote_info, $remote_ip); - my $remote_host = $ENV{TCPREMOTEHOST} || ( $ENV{TCPREMOTEIP} ? "[$ENV{TCPREMOTEIP}]" : "[noip!]"); - my $remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host; - my $remote_ip = $ENV{TCPREMOTEIP}; + if ($ENV{TCPREMOTEIP}) { + # started from tcpserver (or some other superserver which + # exports the TCPREMOTE* variables. + $remote_ip = $ENV{TCPREMOTEIP}; + $remote_host = $ENV{TCPREMOTEHOST} || "[$remote_ip]"; + $remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host; + } else { + # Started from inetd or similar. + # get info on the remote host from the socket. + # ignore ident/tap/... + my $hersockaddr = getpeername(STDIN) + or die "getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin"; + my ($port, $iaddr) = sockaddr_in($hersockaddr); + $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]"); # if the local dns resolver doesn't filter it out we might get @@ -61,9 +75,9 @@ sub read_input { while () { alarm 0; $_ =~ s/\r?\n$//s; # advanced chomp - $self->log(LOGDEBUG, "dispatching $_"); + $self->log(LOGINFO, "dispatching $_"); $self->connection->notes('original_string', $_); - defined $self->dispatch(split / +/, $_) + defined $self->dispatch(split / +/, $_, 2) or $self->respond(502, "command unrecognized: '$_'"); alarm $timeout; } @@ -72,18 +86,21 @@ sub read_input { sub respond { my ($self, $code, @messages) = @_; + my $buf = ''; while (my $msg = shift @messages) { my $line = $code . (@messages?"-":" ").$msg; - $self->log(LOGDEBUG, $line); - print "$line\r\n" or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0); + $self->log(LOGINFO, $line); + $buf .= "$line\r\n"; } + print $buf or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0); return 1; } sub disconnect { my $self = shift; - $self->log(LOGDEBUG,"click, disconnecting"); + $self->log(LOGINFO,"click, disconnecting"); $self->SUPER::disconnect(@_); + $self->run_hooks("post-connection"); exit; } diff --git a/lib/Qpsmtpd/TcpServer/Prefork.pm b/lib/Qpsmtpd/TcpServer/Prefork.pm new file mode 100644 index 0000000..8d34099 --- /dev/null +++ b/lib/Qpsmtpd/TcpServer/Prefork.pm @@ -0,0 +1,65 @@ +package Qpsmtpd::TcpServer::Prefork; +use Qpsmtpd::TcpServer; +use Qpsmtpd::SMTP::Prefork; +use Qpsmtpd::Constants; + +@ISA = qw(Qpsmtpd::SMTP::Prefork Qpsmtpd::TcpServer); + +my $first_0; + +sub start_connection { + my $self = shift; + + #reset info + $self->{_connection} = Qpsmtpd::Connection->new(); #reset connection + $self->{_transaction} = Qpsmtpd::Transaction->new(); #reset transaction + $self->SUPER::start_connection(@_); +} + +sub read_input { + my $self = shift; + + my $timeout = + $self->config('timeoutsmtpd') # qmail smtpd control file + || $self->config('timeout') # qpsmtpd control file + || 1200; # default value + + alarm $timeout; + eval { + while () { + alarm 0; + $_ =~ s/\r?\n$//s; # advanced chomp + $self->log(LOGDEBUG, "dispatching $_"); + $self->connection->notes('original_string', $_); + defined $self->dispatch(split / +/, $_, 2) + or $self->respond(502, "command unrecognized: '$_'"); + alarm $timeout; + } + }; + if ($@ =~ /^disconnect_tcpserver/) { + die "disconnect_tcpserver"; + } else { + die "died while reading from STDIN (probably broken sender) - $@"; + } + alarm(0); +} + +sub respond { + my ($self, $code, @messages) = @_; + while (my $msg = shift @messages) { + my $line = $code . (@messages?"-":" ").$msg; + $self->log(LOGDEBUG, $line); + print "$line\r\n" or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0); + } + return 1; +} + +sub disconnect { + my $self = shift; + $self->log(LOGDEBUG,"click, disconnecting"); + $self->SUPER::disconnect(@_); + $self->run_hooks("post-connection"); + die "disconnect_tcpserver"; +} + +1; diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index 6894208..6cfaed4 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -13,7 +13,7 @@ sub start { my $proto = shift; my $class = ref($proto) || $proto; my %args = @_; - my $self = { _notes => { capabilities => [] }, _rcpt => [], started => time }; + my $self = { _rcpt => [], started => time }; bless ($self, $class); return $self; } @@ -141,10 +141,23 @@ sub body_write { } } -sub body_size { +sub body_size { # depreceated, use data_size() instead + my $self = shift; + $self->log(LOGWARN, "WARNING: body_size() is depreceated, use data_size() instead"); + $self->{_body_size} || 0; +} + +sub data_size { shift->{_body_size} || 0; } +sub body_length { + my $self = shift; + $self->{_body_size} or return 0; + $self->{_header_size} or return 0; + return $self->{_body_size} - $self->{_header_size}; +} + sub body_resetpos { my $self = shift; @@ -190,6 +203,10 @@ sub body_as_string { return $str; } +sub body_fh { + return shift->{_body_file}; +} + sub DESTROY { my $self = shift; # would we save some disk flushing if we unlinked the file before @@ -294,6 +311,11 @@ use the notes field in the C object instead. Returns the temporary filename used to store the message contents; useful for virus scanners so that an additional copy doesn't need to be made. +Calling C also forces spooling to disk. A message is not +spooled to disk if it's size is smaller than +I<$self-Econfig("size_threshold")>, default threshold is 0, the sample +config file sets this to 10000. + =head2 body_write( $data ) Write data to the end of the email. @@ -302,7 +324,26 @@ C<$data> can be either a plain scalar, or a reference to a scalar. =head2 body_size( ) -Get the current size of the email. +B, Use I instead. + +=head2 data_size( ) + +Get the current size of the email. Note that this is not the size of the +message that will be queued, it is the size of what the client sent after +the C command. If you need the size that will be queued, use + + my $msg_len = length($transaction->header->as_string) + + $transaction->body_length; + +The line above is of course only valid in I, as other plugins +may add headers and qpsmtpd will add it's I header. + +=head2 body_length( ) + +Get the current length of the body of the email. This length includes the +empty line between the headers and the body. Until the client has sent +some data of the body of the message (i.e. headers are finished and client +sent the empty line) this will return 0. =head2 body_resetpos( ) @@ -316,6 +357,12 @@ file pointer. Returns a single line of data from the body of the email. +=head2 body_fh( ) + +Returns the file handle to the temporary file of the email. This will return +undef if the file is not opened (yet). In I or later you can +force spooling to disk by calling I<$transaction-Ebody_filename>. + =head1 SEE ALSO L, L, L diff --git a/plugins/auth/auth_vpopmail_sql b/plugins/auth/auth_vpopmail_sql index 344433a..7c8626d 100644 --- a/plugins/auth/auth_vpopmail_sql +++ b/plugins/auth/auth_vpopmail_sql @@ -60,21 +60,18 @@ sub authsql { use DBI; use Qpsmtpd::Constants; use Digest::HMAC_MD5 qw(hmac_md5_hex); - my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) - = @_; + # $DB::single = 1; my $connect = "dbi:mysql:dbname=vpopmail"; my $dbuser = "vpopmailuser"; - my $dbpasswd = "**********"; + my $dbpasswd = "vpoppasswd"; - my $dbh = DBI->connect( $connect, $dbuser, $dbpasswd, - { PrintError => 0, } ) - or ( - $self->log(LOGERROR, $DBI::errstr) - and return DECLINED - ); + my $dbh = DBI->connect( $connect, $dbuser, $dbpasswd ); + $dbh->{ShowErrorStatement} = 1; + my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = + @_; my ( $pw_name, $pw_domain ) = split "@", lc($user); unless ( defined $pw_domain ) { diff --git a/plugins/check_badmailfrom b/plugins/check_badmailfrom index 46a2542..45267b5 100644 --- a/plugins/check_badmailfrom +++ b/plugins/check_badmailfrom @@ -1,7 +1,7 @@ # -*- perl -*- =head1 NAME -check_badmailfrom - checks the standard badmailfrom config +check_badmailfrom - checks the badmailfrom config, with per-line reasons =head1 DESCRIPTION @@ -13,6 +13,9 @@ recipient address for a message if the envelope sender address is listed in badmailfrom. A line in badmailfrom may be of the form @host, meaning every address at host." +You may optionally include a message after the sender address (leave a space), +which is used when rejecting the sender. + =head1 NOTES According to the SMTP protocol, we can't reject until after the RCPT @@ -21,7 +24,7 @@ stage, so store it until later. =cut sub hook_mail { - my ($self, $transaction, $sender) = @_; + my ($self, $transaction, $sender, %param) = @_; my @badmailfrom = $self->qp->config("badmailfrom") or return (DECLINED); @@ -33,18 +36,21 @@ sub hook_mail { my $from = lc($sender->user) . '@' . $host; for my $bad (@badmailfrom) { + my $reason = $bad; + $reason =~ s/^\s*(\S+)[\t\s]+//; + $reason = "sorry, your envelope sender is in my badmailfrom list" unless $reason; $bad =~ s/^\s*(\S+).*/$1/; next unless $bad; $bad = lc $bad; $self->log(LOGWARN, "Bad badmailfrom config: No \@ sign in $bad") and next unless $bad =~ m/\@/; - $transaction->notes('badmailfrom', "sorry, your envelope sender is in my badmailfrom list") + $transaction->notes('badmailfrom', $reason) if ($bad eq $from) || (substr($bad,0,1) eq '@' && $bad eq "\@$host"); } return (DECLINED); } sub hook_rcpt { - my ($self, $transaction, $rcpt) = @_; + my ($self, $transaction, $rcpt, %param) = @_; my $note = $transaction->notes('badmailfrom'); if ($note) { $self->log(LOGINFO, $note); diff --git a/plugins/check_badmailfromto b/plugins/check_badmailfromto index 92c5054..045ee55 100644 --- a/plugins/check_badmailfromto +++ b/plugins/check_badmailfromto @@ -17,7 +17,7 @@ Based heavily on check_badmailfrom. =cut sub hook_mail { - my ($self, $transaction, $sender) = @_; + my ($self, $transaction, $sender, %param) = @_; my @badmailfromto = $self->qp->config("badmailfromto") or return (DECLINED); @@ -41,7 +41,7 @@ sub hook_mail { } sub hook_rcpt { - my ($self, $transaction, $rcpt) = @_; + my ($self, $transaction, $rcpt, %param) = @_; my $recipient = lc($rcpt->user) . '@' . lc($rcpt->host); my $sender = $transaction->notes('badmailfromto'); if ($sender) { diff --git a/plugins/check_badrcptto b/plugins/check_badrcptto index fb57e9e..a99fdb1 100644 --- a/plugins/check_badrcptto +++ b/plugins/check_badrcptto @@ -1,7 +1,8 @@ # this plugin checks the badrcptto config (like badmailfrom for rcpt address) +use Qpsmtpd::DSN; sub hook_rcpt { - my ($self, $transaction, $recipient) = @_; + my ($self, $transaction, $recipient, %param) = @_; my @badrcptto = $self->qp->config("badrcptto") or return (DECLINED); return (DECLINED) unless $recipient->host && $recipient->user; my $host = lc $recipient->host; @@ -9,9 +10,9 @@ sub hook_rcpt { for my $bad (@badrcptto) { $bad = lc $bad; $bad =~ s/^\s*(\S+)/$1/; - return (DENY, "mail to $bad not accepted here") + return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here") if $bad eq $from; - return (DENY, "mail to $bad not accepted here") + return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here") if substr($bad,0,1) eq '@' && $bad eq "\@$host"; } return (DECLINED); diff --git a/plugins/check_basicheaders b/plugins/check_basicheaders index 5efa438..8f90dbd 100644 --- a/plugins/check_basicheaders +++ b/plugins/check_basicheaders @@ -44,7 +44,7 @@ sub hook_data_post { my ($self, $transaction) = @_; return (DENY, "You have to send some data first") - if $transaction->body_size == 0; + if $transaction->data_size == 0; return (DENY, "Mail with no From header not accepted here") unless $transaction->header->get('From'); diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index 3d145a4..9987675 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -44,53 +44,42 @@ issued a deny or denysoft (depending on the value of I). The default is to react at the SMTP greeting stage by issuing the apropriate response code and terminating the SMTP connection. -=item check-at [string: connect, data] - -Defines when to check for early talkers, either at connect time (pre-greet pause) -or at DATA time (pause before sending "354 go ahead"). - -The default is I. - -Note that defer-reject has no meaning if check-at is I. - =back =cut -my $MSG = 'Connecting host started transmitting before SMTP greeting'; +use IO::Select; + +use warnings; +use strict; sub register { my ($self, $qp, @args) = @_; if (@args % 2) { - $self->log(LOGERROR, "Unrecognized/mismatched arguments"); - return undef; + $self->log(LOGERROR, "Unrecognized/mismatched arguments"); + return undef; } $self->{_args} = { - 'wait' => 1, - 'action' => 'denysoft', - 'defer-reject' => 0, - 'check-at' => 'connect', - @args, + 'wait' => 1, + 'action' => 'denysoft', + 'defer-reject' => 0, + @args, }; - print STDERR "Check at: ", $self->{_args}{'check-at'}, "\n"; - if ($qp->isa('Qpsmtpd::Apache')) { + if ($qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) { require APR::Const; APR::Const->import(qw(POLLIN SUCCESS)); - $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_apr'); + $self->register_hook('connect', 'apr_connect_handler'); } else { - $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_poll'); - } - $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_post'); - if ($self->{_args}{'check-at'} eq 'connect') { - $self->register_hook('mail', 'hook_mail') - if $self->{_args}->{'defer-reject'}; + $self->register_hook('connect', 'connect_handler'); } + $self->register_hook('mail', 'mail_handler') + if $self->{_args}->{'defer-reject'}; 1; } -sub check_talker_apr { +sub apr_connect_handler { my ($self, $transaction) = @_; return DECLINED if ($self->qp->connection->notes('whitelistclient')); @@ -107,53 +96,47 @@ sub check_talker_apr { $self->qp->connection->notes('earlytalker', 1); } else { - return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny'; - return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft'; + my $msg = 'Connecting host started transmitting before SMTP greeting'; + return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny'; + return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft'; } } else { $self->log(LOGINFO, "remote host said nothing spontaneous, proceeding"); } - return DECLINED; } -sub check_talker_poll { +sub connect_handler { my ($self, $transaction) = @_; - - my $qp = $self->qp; - my $conn = $qp->connection; - $qp->AddTimer($self->{_args}{'wait'}, sub { read_now($qp, $conn, $self->{_args}{'check-at'}) }); - return CONTINUATION; -} + my $in = new IO::Select; + my $ip = $self->qp->connection->remote_ip; -sub read_now { - my ($qp, $conn, $phase) = @_; - - if ($qp->has_data) { - $qp->log(LOGNOTICE, 'remote host started talking before we said hello'); - $qp->clear_data if $phase eq 'data'; - $conn->notes('earlytalker', 1); + return DECLINED + if ($self->qp->connection->notes('whitelistclient')); + + $in->add(\*STDIN) || return DECLINED; + if ($in->can_read($self->{_args}->{'wait'})) { + $self->log(LOGNOTICE, "remote host started talking before we said hello [$ip]"); + if ($self->{_args}->{'defer-reject'}) { + $self->qp->connection->notes('earlytalker', 1); + } else { + my $msg = 'Connecting host started transmitting before SMTP greeting'; + return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny'; + return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft'; + } + } else { + $self->log(LOGINFO, 'remote host said nothing spontaneous, proceeding'); } - $qp->finish_continuation; + return DECLINED; } -sub check_talker_post { - my ($self, $transaction) = @_; - - my $conn = $self->qp->connection; - return DECLINED unless $conn->notes('earlytalker'); - return DECLINED if $self->{'defer-reject'}; - return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny'; - return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft'; - return DECLINED; # assume action eq 'log' -} - -sub hook_mail { +sub mail_handler { my ($self, $txn) = @_; + my $msg = 'Connecting host started transmitting before SMTP greeting'; - return DECLINED unless $self->connection->notes('earlytalker'); - return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny'; - return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft'; + return DECLINED unless $self->qp->connection->notes('earlytalker'); + return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny'; + return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft'; return DECLINED; } diff --git a/plugins/check_loop b/plugins/check_loop index ff64ee8..3b6e86a 100644 --- a/plugins/check_loop +++ b/plugins/check_loop @@ -25,8 +25,9 @@ Written by Keith C. Ivey Released to the public domain, 17 June 2005. =cut +use Qpsmtpd::DSN; -sub register { +sub init { my ($self, $qp, @args) = @_; $self->{_max_hops} = $args[0] || 100; @@ -45,7 +46,8 @@ sub hook_data_post { $transaction->header->get('Delivered-To'); if ( $hops >= $self->{_max_hops} ) { - return DENY, "Too many hops. This message is looping."; + # default of too_many_hops is DENY, see comment in POD of Qpsmtpd::DSN + return Qpsmtpd::DSN->too_many_hops(); } return DECLINED; diff --git a/plugins/check_relay b/plugins/check_relay index a79da91..e294c9d 100644 --- a/plugins/check_relay +++ b/plugins/check_relay @@ -19,7 +19,7 @@ sub hook_connect { $connection->relay_client(1); last; } - $client_ip =~ s/\d+\.?$//; # strip off another 8 bits + $client_ip =~ s/(\d|\w|::)+(:|\.)?$//; # strip off another 8 bits } return (DECLINED); diff --git a/plugins/count_unrecognized_commands b/plugins/count_unrecognized_commands index d369307..92110e2 100644 --- a/plugins/count_unrecognized_commands +++ b/plugins/count_unrecognized_commands @@ -25,8 +25,13 @@ sub register { $self->{_unrec_cmd_max} = 4; } - $qp->connection->notes('unrec_cmd_count', 0); +} +sub hook_connect { + my ($self, $transaction) = @_; + + $self->qp->connection->notes('unrec_cmd_count', 0); + return DECLINED; } sub hook_unrecognized_command { diff --git a/plugins/dns_whitelist_soft b/plugins/dns_whitelist_soft index 0def06a..8a47cd4 100644 --- a/plugins/dns_whitelist_soft +++ b/plugins/dns_whitelist_soft @@ -139,7 +139,7 @@ sub process_sockets { } sub hook_rcpt { - my ($self, $transaction, $rcpt) = @_; + my ($self, $transaction, $rcpt, %param) = @_; my $ip = $self->qp->connection->remote_ip || return (DECLINED); my $note = $self->process_sockets; if ( $note ) { diff --git a/plugins/dnsbl b/plugins/dnsbl index cc3ff00..48df98f 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -1,8 +1,17 @@ -#!/usr/bin/perl -w +#!perl -w -use Danga::DNS; +=head1 NAME -sub init { +dnsbl - handle DNS BlackList lookups + +=head1 DESCRIPTION + +Plugin that checks the IP address of the incoming connection against +a configurable set of RBL services. + +=cut + +sub register { my ($self, $qp, $denial ) = @_; if ( defined $denial and $denial =~ /^disconnect$/i ) { $self->{_dnsbl}->{DENY} = DENY_DISCONNECT; @@ -16,7 +25,7 @@ sub init { sub hook_connect { my ($self, $transaction) = @_; - my $remote_ip = $self->connection->remote_ip; + my $remote_ip = $self->qp->connection->remote_ip; # perform RBLSMTPD checks to mimic Dan Bernstein's rblsmtpd if (defined($ENV{'RBLSMTPD'})) { @@ -31,94 +40,162 @@ sub hook_connect { $self->log(LOGDEBUG, "RBLSMTPD not set for $remote_ip"); } - my $allow = grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } $self->config('dnsbl_allow'); + my $allow = grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } $self->qp->config('dnsbl_allow'); return DECLINED if $allow; - my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->config('dnsbl_zones'); + my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); return DECLINED unless %dnsbl_zones; my $reversed_ip = join(".", reverse(split(/\./, $remote_ip))); - my $total_zones = keys %dnsbl_zones; - my $qp = $self->qp; + # we should queue these lookups in the background and just fetch the + # results in the first rcpt handler ... oh well. + + my $res = new Net::DNS::Resolver; + $res->tcp_timeout(30); + $res->udp_timeout(30); + + my $sel = IO::Select->new(); + + my $dom; for my $dnsbl (keys %dnsbl_zones) { # fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp + $dom->{"$reversed_ip.$dnsbl"} = 1; if (defined($dnsbl_zones{$dnsbl})) { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background"); - Danga::DNS->new( - callback => sub { process_a_result($qp, $dnsbl_zones{$dnsbl}, @_) }, - finished => sub { $total_zones--; finished($qp, $total_zones) }, - host => "$reversed_ip.$dnsbl", - type => 'A', - client => $self->qp->input_sock, - ); + $sel->add($res->bgsend("$reversed_ip.$dnsbl")); } else { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record in the background"); - Danga::DNS->new( - callback => sub { process_txt_result($qp, @_) }, - finished => sub { $total_zones--; finished($qp, $total_zones) }, - host => "$reversed_ip.$dnsbl", - type => 'TXT', - client => $self->qp->input_sock, - ); + $sel->add($res->bgsend("$reversed_ip.$dnsbl", "TXT")); } } - return CONTINUATION; + $self->qp->connection->notes('dnsbl_sockets', $sel); + $self->qp->connection->notes('dnsbl_domains', $dom); + + return DECLINED; } -sub finished { - my ($qp, $total_zones) = @_; - $qp->finish_continuation unless $total_zones; -} +sub process_sockets { + my ($self) = @_; -sub process_a_result { - my ($qp, $template, $result, $query) = @_; - - $qp->log(LOGINFO, "Result for A $query: $result\n"); - if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) { - # NXDOMAIN or ERROR possibly... - # $qp->finish_continuation if $qp->input_sock->readable; - return; + my $conn = $self->qp->connection; + + return $conn->notes('dnsbl') + if $conn->notes('dnsbl'); + + my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); + + my $res = new Net::DNS::Resolver; + $res->tcp_timeout(30); + $res->udp_timeout(30); + + my $sel = $conn->notes('dnsbl_sockets') or return ""; + my $dom = $conn->notes('dnsbl_domains'); + my $remote_ip = $self->qp->connection->remote_ip; + + my $result; + + $self->log(LOGDEBUG, "waiting for dnsbl dns"); + + # don't wait more than 8 seconds here + my @ready = $sel->can_read(8); + + $self->log(LOGDEBUG, "DONE waiting for dnsbl dns, got " , scalar @ready, " answers ...") ; + return '' unless @ready; + + for my $socket (@ready) { + my $query = $res->bgread($socket); + $sel->remove($socket); + undef $socket; + + my $dnsbl; + + if ($query) { + my $a_record = 0; + foreach my $rr ($query->answer) { + my $name = $rr->name; + $self->log(LOGDEBUG, "name $name"); + next unless $dom->{$name}; + $self->log(LOGDEBUG, "name $name was queried"); + $a_record = 1 if $rr->type eq "A"; + ($dnsbl) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $dnsbl; + $dnsbl = $name unless $dnsbl; + next unless $rr->type eq "TXT"; + $self->log(LOGDEBUG, "got txt record"); + $result = $rr->txtdata and last; + } + #$a_record and $result = "Blocked by $dnsbl"; + + if ($a_record) { + if (defined $dnsbl_zones{$dnsbl}) { + $result = $dnsbl_zones{$dnsbl}; + #$result =~ s/%IP%/$ENV{'TCPREMOTEIP'}/g; + $result =~ s/%IP%/$remote_ip/g; + } else { + # shouldn't get here? + $result = "Blocked by $dnsbl"; + } + } } - - my $conn = $qp->connection; - my $ip = $conn->remote_ip; - $template =~ s/%IP%/$ip/g; - $conn->notes('dnsbl', $template) unless $conn->notes('dnsbl'); - # $qp->finish_continuation if $qp->input_sock->readable; -} - -sub process_txt_result { - my ($qp, $result, $query) = @_; - - $qp->log(LOGINFO, "Result for TXT $query: $result\n"); - if ($result !~ /[a-z]/) { - # NXDOMAIN or ERROR probably... - # $qp->finish_continuation if $qp->input_sock->readable; - return; + else { + $self->log(LOGERROR, "$dnsbl query failed: ", $res->errorstring) + unless $res->errorstring eq "NXDOMAIN"; } - - my $conn = $qp->connection; - $conn->notes('dnsbl', $result) unless $conn->notes('dnsbl'); - # $qp->finish_continuation if $qp->input_sock->readable; + + if ($result) { + #kill any other pending I/O + $conn->notes('dnsbl_sockets', undef); + $result = join("\n", $self->qp->config('dnsbl_rejectmsg'), $result); + return $conn->notes('dnsbl', $result); + } + } + + if ($sel->count) { + # loop around if we have dns blacklists left to see results from + return $self->process_sockets(); + } + + # er, the following code doesn't make much sense anymore... + + # if there was more to read; then forget it + $conn->notes('dnsbl_sockets', undef); + + return $conn->notes('dnsbl', $result); + } sub hook_rcpt { - my ($self, $transaction, $rcpt) = @_; + my ($self, $transaction, $rcpt, %param) = @_; my $connection = $self->qp->connection; # RBLSMTPD being non-empty means it contains the failure message to return if (defined ($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') { my $result = $ENV{'RBLSMTPD'}; - my $remote_ip = $self->connection->remote_ip; + my $remote_ip = $connection->remote_ip; $result =~ s/%IP%/$remote_ip/g; - return (DENY, join(" ", $self->config('dnsbl_rejectmsg'), $result)); + return ($self->{_dnsbl}->{DENY}, + join(" ", $self->qp->config('dnsbl_rejectmsg'), $result)); } - my $note = $self->connection->notes('dnsbl'); - return (DENY, $note) if $note; + my $note = $self->process_sockets; + my $whitelist = $connection->notes('whitelisthost'); + if ( $note ) { + if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) { + $self->log(LOGWARN, "Don't blacklist special account: ".$rcpt->user); + } + elsif ( $whitelist ) { + $self->log(LOGWARN, "Whitelist overrode blacklist: $whitelist"); + } + elsif ( $connection->relay_client() ) { + $self->log(LOGWARN, "Don't blacklist relay/auth clients"); + } + else { + return ($self->{_dnsbl}->{DENY}, $note); + } + } return DECLINED; + } sub hook_disconnect { @@ -131,14 +208,18 @@ sub hook_disconnect { 1; -=head1 NAME +=head1 Usage -dnsbl - handle DNS BlackList lookups +Add the following line to the config/plugins file: -=head1 DESCRIPTION + dnsbl [disconnect] -Plugin that checks the IP address of the incoming connection against -a configurable set of RBL services. +If you want to immediately drop the connection (since some blacklisted +servers attempt multiple sends per session), add the optional keyword +"disconnect" (case insensitive) to the config line. In most cases, an +IP address that is listed should not be given the opportunity to begin +a new transaction, since even the most volatile blacklists will return +the same answer for a short period of time (the minimum DNS cache period). =head1 Configuration files diff --git a/plugins/domainkeys b/plugins/domainkeys new file mode 100644 index 0000000..ccabf59 --- /dev/null +++ b/plugins/domainkeys @@ -0,0 +1,116 @@ +sub init { + my ($self, $qp, %args) = @_; + + foreach my $key ( %args ) { + $self->{$key} = $args{$key}; + } +} + +sub hook_data_post { + use Mail::DomainKeys::Message; + use Mail::DomainKeys::Policy; + + my ($self, $transaction) = @_; + + # if this isn't signed, just move along + return DECLINED + unless $transaction->header->get('DomainKey-Signature'); + + my @body; + + $transaction->body_resetpos; + + $transaction->body_getline; # \r\n seperator is NOT part of the body + + while (my $line = $transaction->body_getline) { + push @body, $line; + } + + my $message = load Mail::DomainKeys::Message( + HeadString => $transaction->header->as_string, + BodyReference => \@body) or + $self->log(LOGWARN, "unable to load message"), + return DECLINED; + + # no sender domain means no verification + $message->senderdomain or + return DECLINED; + + my $status; + + # key testing + if ( $message->testing ) { + # Don't do anything else + $status = "testing"; + } + elsif ( $message->signed and $message->verify ) { + # verified: add good header + $status = $message->signature->status; + } + else { # not signed or not verified + my $policy = fetch Mail::DomainKeys::Policy( + Protocol => "dns", + Domain => $message->senderdomain + ); + if ( $policy ) { + if ( $policy->testing ) { + # Don't do anything else + $status = "testing"; + } + elsif ( $policy->signall ) { + # if policy requires all mail to be signed + $status = undef; + } + else { # $policy->signsome + # not signed and domain doesn't sign all + $status = "no signature"; + } + } + else { + $status = $message->signed ? "non-participant" : "no signature"; + } + } + + + if ( defined $status ) { + $transaction->header->replace("DomainKey-Status", $status); + $self->log(LOGWARN, "DomainKeys-Status: $status"); + return DECLINED; + } + else { + $self->log(LOGERROR, "DomainKeys signature failed to verify"); + if ( $self->{warn_only} ) { + return DECLINED; + } + else { + return (DENY, "DomainKeys signature failed to verify"); + } + } +} + +=cut + +=head1 NAME + +domainkeys: validate a DomainKeys signature on an incoming mail + +=head1 SYNOPSIS + + domainkeys [warn_only 1] + +Performs a DomainKeys validation on the message. Takes a single +configuration + + warn_only 1 + +which means that messages which are not correctly signed (i.e. signed but +modified or deliberately forged) will not be DENY'd, but an error will still +be issued to the logfile. + +=head1 COPYRIGHT + +Copyright (C) 2005-2006 John Peacock. + +Portions Copyright (C) 2004 Anthony D. Urso. All rights reserved. This +program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. diff --git a/plugins/dont_require_anglebrackets b/plugins/dont_require_anglebrackets new file mode 100644 index 0000000..ac06bef --- /dev/null +++ b/plugins/dont_require_anglebrackets @@ -0,0 +1,19 @@ +# +# dont_require_anglebrackets - accept addresses in MAIL FROM:/RCPT TO: +# commands without surrounding <> +# +sub hook_mail_pre { + my ($self,$transaction, $addr) = @_; + unless ($addr =~ /^<.*>$/) { + $addr = "<".$addr.">"; + } + return (OK, $addr); +} + +sub hook_rcpt_pre { + my ($self,$transaction, $addr) = @_; + unless ($addr =~ /^<.*>$/) { + $addr = "<".$addr.">"; + } + return (OK, $addr); +} diff --git a/plugins/greylisting b/plugins/greylisting index 89df1bc..3731ab2 100644 --- a/plugins/greylisting +++ b/plugins/greylisting @@ -78,6 +78,22 @@ deliveries); in 'off' mode we do nothing (useful for turning greylisting off globally if using per_recipient configs). Default: denysoft. +=item db_dir + +Path to a directory in which the greylisting DB will be stored. This +directory must be writable by the qpsmtpd user. By default, the first +usable directory from the following list will be used: + +=over 4 + +=item /var/lib/qpsmtpd/greylisting + +=item I/var/db (where BINDIR is the location of the qpsmtpd binary) + +=item I/config + +=back + =item per_recipient Flag to indicate whether to use per-recipient configs. @@ -85,7 +101,8 @@ Flag to indicate whether to use per-recipient configs. =item per_recipient_db Flag to indicate whether to use per-recipient greylisting -databases (default is to use a shared database). +databases (default is to use a shared database). Per-recipient configuration +directories, if determined, supercede I. =back @@ -191,7 +208,10 @@ sub denysoft_greylist { # Setup database location my $dbdir = $transaction->notes('per_rcpt_configdir') if $config->{per_recipient_db}; - $dbdir ||= -d "$QPHOME/var/db" ? "$QPHOME/var/db" : "$QPHOME/config"; + for my $d ($dbdir, $config->{db_dir}, "/var/lib/qpsmtpd/greylisting", + "$QPHOME/var/db", "$QPHOME/config") { + last if $dbdir ||= $d && -d $d && $d; + } my $db = "$dbdir/$DB"; $self->log(LOGINFO,"using $db as greylisting database"); diff --git a/plugins/hosts_allow b/plugins/hosts_allow new file mode 100644 index 0000000..ca445c6 --- /dev/null +++ b/plugins/hosts_allow @@ -0,0 +1,80 @@ + +=head1 NAME + +hosts_allow - decide if a host is allowed to send mail + +=head1 DESCRIPTION + +The B module decides before the SMTP-Greeting if a host is +allowed to connect. It checks for too many (running) connections from one +host (see -m/--max-from-ip options in qpsmtpd-forkserver) and the config +file I. +The plugin takes no arguments. + +=head1 CONFIG + +The config file contains lines with two or three items. The first is either +an IP address or a network/mask pair. The second is a (valid) return code +from Qpsmtpd::Constants. The last is a comment which will be returned to the +connecting client if the return code is DENY or DENYSOFT (and of course +DENY_DISCONNECT and DENYSOFT_DISCONNECT). +Example: + + 192.168.3.4 DECLINED + 192.168.3.0/24 DENY Sorry, known spam only source + +This would exclude 192.168.3.4 from the DENY of 192.168.3.0/24. + +=cut + +use Qpsmtpd::Constants; +use Socket; + +sub hook_pre_connection { + my ($self,$transaction,%args) = @_; + + # remote_ip => inet_ntoa($iaddr), + # remote_port => $port, + # local_ip => inet_ntoa($laddr), + # local_port => $lport, + # max_conn_ip => $MAXCONNIP, + # child_addrs => [values %childstatus], + + my $remote = $args{remote_ip}; + + if ($args{max_conn_ip}) { + my $num_conn = 1; # seed with current value + my $raddr = inet_aton($remote); + foreach my $rip (@{$args{child_addrs}}) { + ++$num_conn if (defined $rip && $rip eq $raddr); + } + if ($num_conn > $args{max_conn_ip}) { + $self->log(LOGINFO, + "Too many connections from $remote: " + . "$num_conn > " . $args{max_conn_ip} + . "Denying connection."); + return (DENYSOFT, "Sorry, too many connections from $remote, " + ."try again later"); + } + } + + foreach ($self->qp->config("hosts_allow")) { + s/^\s*//; + my ($ipmask, $const, $message) = split /\s+/, $_, 3; + next unless defined $const; + + my ($net,$mask) = split '/', $ipmask, 2; + if (!defined $mask) { + $mask = 32; + } + $mask = pack "B32", "1"x($mask)."0"x(32-$mask); + if (join(".", unpack("C4", inet_aton($remote) & $mask)) eq $net) { + $const = Qpsmtpd::Constants::return_code($const) || DECLINED; + return($const, $message); + } + } + + return (DECLINED); +} + +# vim: sw=4 ts=4 expandtab syn=perl diff --git a/plugins/logging/adaptive b/plugins/logging/adaptive index 76f0f26..27d0eba 100644 --- a/plugins/logging/adaptive +++ b/plugins/logging/adaptive @@ -44,10 +44,8 @@ sub hook_logging { # wlog return DECLINED if defined $plugin and $plugin eq $self->plugin_name; if ( defined $self->{_maxlevel} && $trace <= $self->{_maxlevel} ) { - my $fd = $self->fd(); warn join( " ", $$. - (defined $fd ? " fd:$fd" : "") . ( defined $plugin ? " $plugin plugin:" : defined $hook ? " running plugin ($hook):" diff --git a/plugins/logging/file b/plugins/logging/file new file mode 100644 index 0000000..1dcdf28 --- /dev/null +++ b/plugins/logging/file @@ -0,0 +1,267 @@ +#!/usr/bin/perl +# $Id$ + +=head1 NAME + +file - Simple log-to-file logging for qpsmtpd + +=head1 DESCRIPTION + +The 'file' logging plugin for qpsmtpd records qpsmtpd log messages into a +file (or a named pipe, if you prefer.) + +=head1 CONFIGURATION + +To enable the logging plugin, add a line of this form to the qpsmtpd plugins +configuration file: + +=over + +logging/file [loglevel I] [reopen] [nosplit] I + +For example: + +logging/file loglevel LOGINFO /var/log/qpsmtpd.log +logging/file /var/log/qpsmtpd.log.%Y-%m-%d +logging/file loglevel LOGCRIT reopen |/usr/local/sbin/page-sysadmin + +=back + +Multiple instances of the plugin can be configured by appending :I for any +integer(s) I, to log to multiple files simultaneously, e.g. to log critical +errors and normally verbose logs elsewhere. + +The filename or command given can include strftime conversion specifiers, +which can be used to substitute time and date information into the logfile. +The file will be reopened whenever this output changes (for example, with a +format of qpsmtpd.log.%Y-%m-%d-%h, the log would be reopened once per hour). + +The list of supported conversion specifiers depends on the strftime() +implementation of your C library. See strftime(3) for details. Additionally, +%i will be expanded to a (hopefully) unique session-id; if %i is used, a new +logfile will be started for each SMTP connection. + +The following optional configuration setting can be supplied: + +=over + +=item nosplit + +If specified, the output file or pipe will be reopened at once once per +connection, and only prior to the first log output. This prevents logs for +sessions that span log intervals being split across multiple logfiles. +Without this option, the log will be reopened only when its output filename +changes; if strftime specifiers are not used, the log will not be reopened +at all. + +=item reopen + +Forces the log output to be reopened once per connection, as soon as something +is available to be logged. This can be combined with a high log severity (see +I below) to facilitate SMTP service alarms with Nagios or a similar +monitoring agent. + +=item loglevel I + +The internal log level below which messages will be logged. The I +given should be chosen from the list below. Priorities count downward (for +example, if LOGWARN were selected, LOGERROR, LOGCRIT and LOGEMERG messages +would be logged as well). + +=over + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + +=back + + +The chosen I should be writable by the user running qpsmtpd; it will be +created it did not already exist, and appended to otherwise. + +=head1 AUTHORS + +Devin Carraway , with contributions by Peter J. +Holzer . + +=head1 LICENSE + +Copyright (c) 2005-2006, Devin Carraway +Copyright (c) 2006, Peter J. Holzer. + +This plugin is licensed under the same terms as the qpsmtpd package itself. +Please see the LICENSE file included with qpsmtpd for details. + +=cut + +use strict; +use warnings; + +use IO::File; +use Sys::Hostname; +use POSIX qw(strftime); + +sub register { + my ($self, $qp, @args) = @_; + my %args; + + $self->{_loglevel} = LOGWARN; + + while (1) { + last if !@args; + if (lc $args[0] eq 'loglevel') { + shift @args; + my $ll = shift @args; + if (!defined $ll) { + warn "Malformed arguments to logging/file plugin"; + return; + } + if ($ll =~ /^(\d+)$/) { + $self->{_loglevel} = $1; + } + elsif ($ll =~ /^(LOG\w+)$/) { + $self->{_loglevel} = log_level($1); + defined $self->{_loglevel} or $self->{_loglevel} = LOGWARN; + } + } + elsif (lc $args[0] eq 'nosplit') { + shift @args; + $self->{_nosplit} = 1; + } + elsif (lc $args[0] eq 'reopen') { + shift @args; + $self->{_reopen} = 1; + } + else { last } + } + + unless (@args && $args[0]) { + warn "Malformed arguments to syslog plugin"; + return; + } + + my $output = join(' ', @args); + + if ($output =~ /^\s*\|(.*)/) { + $self->{_log_pipe} = 1; + $self->{_log_format} = $1; + } else { + $output =~ /^(.*)/; # detaint + $self->{_log_format} = $1; + } + $self->{_current_output} = ''; + $self->{_session_counter} = 0; + 1; +} + +sub log_output { + my ($self, $txn) = @_; + my $output = $self->{_log_format}; + $output =~ s/%i/($txn->notes('logging-session-id') || 'parent')/ge; + $output = strftime $output, localtime; + $output; +} + +sub open_log { + my ($self,$output,$qp) = @_; + + if ($self->{_log_pipe}) { + unless ($self->{_f} = new IO::File "|$output") { + warn "Error opening log output to command $output: $!"; + return undef; + } + } else { + unless ($self->{_f} = new IO::File ">>$output") { + warn "Error opening log output to path $output: $!"; + return undef; + } + } + $self->{_current_output} = $output; + $self->{_f}->autoflush(1); + 1; +} + + +# Reopen the output iff the interpolated output filename has changed +# from the one currently open, or if reopening was selected and we haven't +# yet done so during this session. +# +# Returns true if the file was reopened, zero if not, undef on error. +sub maybe_reopen { + my ($self, $txn) = @_; + + my $new_output = $self->log_output($txn); + if (!$self->{_current_output} || + $self->{_current_output} ne $new_output || + ($self->{_reopen} && + !$txn->notes('file-reopened-this-session'))) { + unless ($self->open_log($new_output, $txn)) { + return undef; + } + $txn->notes('file-reopened-this-session', 1); + return 1; + } + return 0; +} + +sub hook_connect { + my ($self, $txn) = @_; + + $txn->notes('file-logged-this-session', 0); + $txn->notes('file-reopened-this-session', 0); + $txn->notes('logging-session-id', + sprintf("%08d-%04d-%d", + scalar time, $$, ++$self->{_session_counter})); + return DECLINED; +} + +sub hook_disconnect { + my ($self) = @_; + + if ($self->{reopen_} && $self->{_f}) { + $self->{_f} = undef; + } + return DECLINED; +} + +sub hook_logging { + my ($self, $txn, $trace, $hook, $plugin, @log) = @_; + + return DECLINED if !defined $self->{_loglevel} or + $trace > $self->{_loglevel}; + return DECLINED if defined $plugin and $plugin eq $self->plugin_name; + + # Possibly reopen the log iff: + # - It's not already open + # - We're allowed to split sessions across logfiles + # - We haven't logged anything yet this session + if (!$self->{_f} || + !$self->{_nosplit} || + !$txn->notes('file-logged-this-session')) { + unless (defined $self->maybe_reopen($txn)) { + return DECLINED; + } + $txn->notes('file-logged-this-session', 1); + } + + my $f = $self->{_f}; + print $f scalar localtime, ' ', hostname(), '[', $$, ']: ', @log, "\n"; + return DECLINED; +} + +# vi: tabstop=4 shiftwidth=4 expandtab: diff --git a/plugins/logging/syslog b/plugins/logging/syslog new file mode 100644 index 0000000..6ea90b6 --- /dev/null +++ b/plugins/logging/syslog @@ -0,0 +1,187 @@ +#!/usr/bin/perl +# $Id$ + +=head1 NAME + +syslog - Syslog logging plugin for qpsmtpd + +=head1 DESCRIPTION + +The syslog plugin for qpsmtpd passes qpsmtpd log messages into the standard +UNIX syslog facility, mapping qpsmtpd priorities to syslog priorities. + +=head1 CONFIGURATION + +To enable the logging plugin, add a line of this form to the qpsmtpd plugins +configuration file: + +=over + +logging/syslog [loglevel l] [priority p] [ident str] [facility f] [logsock t] + +For example: + +logging/syslog loglevel LOGINFO priority LOG_NOTICE + +=back + +The following optional configuration settings can be supplied: + +=over + +=item B + +The internal log level below which messages will be logged. Priorities count +downward as follows: + +=over + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + + +=item B + +Normally, log messages will be mapped from the above log levels into the +syslog(3) log levels of their corresponding names. This will cause various +messages to appear or not in syslog outputs according to your syslogd +configuration (typically /etc/syslog.conf). However, if the B +setting is used, all messages will be logged at that priority regardless of +what the original priority might have been. + +=item B + +The ident string that will be attached to messages logged via this plugin. +The default is 'qpsmtpd'. + +=item B + +The syslog facility to which logged mesages will be directed. See syslog(3) +for details. The default is LOG_MAIL. + +=item B + +The syslog socket where messages should be sent via syslogsock(). The valid +options are 'udp', 'tcp', 'unix', 'stream' and 'console'. Not all are +available on all systems. See Sys::Syslog for details. The default is +the above list in that order. To select specific sockets, use a comma to +separate the types. + +=over + + logsock udp,unix + logsock stream + +=back + +=back + +=head1 AUTHOR + +Devin Carraway +Peter Eisch (logsock support) + +=head1 LICENSE + +Copyright (c) 2005, Devin Carraway. + +This plugin is licensed under the same terms as the qpsmtpd package itself. +Please see the LICENSE file included with qpsmtpd for details. + +=cut + +use strict; +use warnings; + +use Sys::Syslog qw(:DEFAULT setlogsock); + +sub register { + my ($self, $qp, @args) = @_; + my %args; + + if (@args % 2 == 0) { + %args = @args; + } else { + warn "Malformed arguments to syslog plugin"; + return; + } + + my $ident = 'qpsmtpd'; + my $logopt = 'pid'; + my $facility = 'LOG_MAIL'; + + $self->{_loglevel} = LOGWARN; + + if ($args{loglevel}) { + if ($args{loglevel} =~ /^(\d+)$/) { + $self->{_loglevel} = $1; + } + elsif ($args{loglevel} =~ /^(LOG\w+)$/) { + $self->{_loglevel} = log_level($1) || LOGWARN; + } + } + + if ($args{priority}) { + if ($args{priority} =~ /^(\d+|LOG\w+)$/) { + $self->{_priority} = $1; + } + } + + if ($args{ident} && $args{ident} =~ /^([\w\-.]+)$/) { + $ident = $1; + } + if ($args{facility} && $args{facility} =~ /^(\w+)$/) { + $facility = $1; + } + + if ($args{logsock}) { + my @logopt = split(/,/, $args{logsock}); + setlogsock(@logopt); + } + + unless (openlog $ident, $logopt, $facility) { + warn "Error opening syslog output"; + return; + } +} + +my %priorities_ = ( + 0 => 'LOG_EMERG', + 1 => 'LOG_ALERT', + 2 => 'LOG_CRIT', + 3 => 'LOG_ERR', + 4 => 'LOG_WARNING', + 5 => 'LOG_NOTICE', + 6 => 'LOG_INFO', + 7 => 'LOG_DEBUG', +); + +sub hook_logging { + my ($self, $txn, $trace, $hook, $plugin, @log) = @_; + + return DECLINED if $trace > $self->{_loglevel}; + return DECLINED if defined $plugin and $plugin eq $self->plugin_name; + + my $priority = $self->{_priority} ? + $self->{_priority} : $priorities_{$trace}; + + syslog $priority, '%s', join(' ', @log); + return DECLINED; +} + +# vi: tabstop=4 shiftwidth=4 expandtab diff --git a/plugins/logging/warn b/plugins/logging/warn index 2308b74..ce25399 100644 --- a/plugins/logging/warn +++ b/plugins/logging/warn @@ -10,10 +10,10 @@ sub register { $self->{_level} = LOGWARN; if ( defined($loglevel) ) { if ($loglevel =~ /^\d+$/) { - $self->{_level} = $loglevel; + $self->{_level} = $loglevel; } else { - $self->{_level} = log_level($loglevel); + $self->{_level} = log_level($loglevel); } } @@ -29,13 +29,11 @@ sub hook_logging { # then these lines will not be logged at all. You can safely comment # out this line and it will not cause an infinite loop. return DECLINED if defined $plugin and $plugin eq $self->plugin_name; - my $fd = $self->fd(); warn join(" ", $$ . - (defined $fd ? " fd:$fd" : "") . - (defined $plugin ? " $plugin plugin:" : - defined $hook ? " running plugin ($hook):" : ""), + (defined $plugin ? " $plugin plugin:" : + defined $hook ? " running plugin ($hook):" : ""), @log), "\n" if ($trace <= $self->{_level}); diff --git a/plugins/milter b/plugins/milter index ff0e122..2be6b42 100644 --- a/plugins/milter +++ b/plugins/milter @@ -135,7 +135,7 @@ sub hook_helo { } sub hook_mail { - my ($self, $transaction, $address) = @_; + my ($self, $transaction, $address, %param) = @_; my $milter = $self->qp->connection->notes('milter'); @@ -148,7 +148,7 @@ sub hook_mail { } sub hook_rcpt { - my ($self, $transaction, $address) = @_; + my ($self, $transaction, $address, %param) = @_; my $milter = $self->qp->connection->notes('milter'); diff --git a/plugins/parse_addr_withhelo b/plugins/parse_addr_withhelo new file mode 100644 index 0000000..f26f8db --- /dev/null +++ b/plugins/parse_addr_withhelo @@ -0,0 +1,60 @@ +# parse_addr_withhelo +# +# strict RFC 821 forbids parameters after the +# MAIL FROM: +# and +# RCPT TO: +# +# load this plugin to enforce, else the default EHLO parsing with +# parameters is done. +# + +sub hook_mail_parse { + my $self = shift; + return (OK, \&_parse) if ($self->qp->connection->hello eq 'helo'); + return (DECLINED); +} + +sub hook_rcpt_parse { + my $self = shift; + return (OK, \&_parse) if ($self->qp->connection->hello eq 'helo'); + return (DECLINED); +} + +sub _parse { + my ($self,$cmd,$line) = @_; + $self->log(LOGDEBUG, "_parse() cmd=[$cmd], line=[$line]"); + if ($cmd eq 'mail') { + return(DENY, "Syntax error in command") + unless ($line =~ s/^from:\s*//i); + } + else { # cmd eq 'rcpt' + return(DENY, "Syntax error in command") + unless ($line =~ s/^to:\s*//i); + } + + if ($line =~ s/^(<.*>)\s*//) { + my $addr = $1; + return (DENY, "No parameters allowed in ".uc($cmd)) + if ($line =~ /^\S/); + return (OK, $addr, ()); + } + + ## now, no <> are given + $line =~ s/\s*$//; + if ($line =~ /\@/) { + return (DENY, "No parameters allowed in ".uc($cmd)) + if ($line =~ /\@\S+\s+\S/); + return (OK, $line, ()); + } + + if ($cmd eq "mail") { + return (OK, "<>") unless $line; # 'MAIL FROM:' -> 'MAIL FROM:<>' + return (DENY, "Could not parse your MAIL FROM command"); + } + else { + return (DENY, "Could not parse your RCPT TO command") + unless $line =~ /^(postmaster|abuse)$/i; + } +} + diff --git a/plugins/queue/exim-bsmtp b/plugins/queue/exim-bsmtp index 1258c40..8d02eff 100644 --- a/plugins/queue/exim-bsmtp +++ b/plugins/queue/exim-bsmtp @@ -90,8 +90,7 @@ sub hook_queue { "MAIL FROM:<", ($txn->sender->address || ''), ">\n"; print $tmp "RCPT TO:<", ($_->address || ''), ">\n" for $txn->recipients; - print $tmp "DATA\n", - $txn->header->as_string, "\n"; + print $tmp "DATA\n", $txn->header->as_string; $txn->body_resetpos; while (my $line = $txn->body_getline) { $line =~ s/^\./../; diff --git a/plugins/queue/postfix-queue b/plugins/queue/postfix-queue index db7259e..fa471c5 100644 --- a/plugins/queue/postfix-queue +++ b/plugins/queue/postfix-queue @@ -1,3 +1,4 @@ + =head1 NAME postfix-queue @@ -8,37 +9,183 @@ This plugin passes mails on to the postfix cleanup daemon. =head1 CONFIG -It takes one optional parameter, the location of the cleanup socket. +The first optional parameter is the location of the cleanup socket. If it does +not start with a ``/'', it is treated as a flag for cleanup (see below). +If set, the environment variable POSTFIXQUEUE overrides this setting. -If set the environment variable POSTFIXQUEUE overrides this setting. +All other parameters are flags for cleanup, no flags are enabled by default. +See below in ``POSTFIX COMPATIBILITY'' for flags understood by your postfix +version. Supported by all postfix versions E= 2.1 are: + +=over 4 + +=item FLAG_FILTER + +Set the CLEANUP_FLAG_FILTER for cleanup. This enables the use of +I, I or I in postfix' main.cf. + +=item FLAG_BCC_OK + +Setting this flag enables (for example) the I parameter + +=item FLAG_MAP_OK + +This flag enables the use of other recipient mappings (e.g. +I) in postfix' cleanup. + +=item FLAG_MASK_EXTERNAL + +This flag mask combines FLAG_FILTER, FLAG_MILTER (only in postfix >= 2.3) +FLAG_BCC_OK and FLAG_MAP_OK and is used by postfix for external messages. +This is probably what you want to use. + +=back + +For more flags see below in ``POSTFIX COMPATIBILITY'', your postfix version +(grep _FLAG_ src/global/cleanup_user.h) and/or lib/Qpsmtpd/Postfix/Constants.pm + +=head1 POSTFIX COMPATIBILITY + +The first version of this plugin was written for postfix 1.x. + +The next step for Postfix 2.1 (and later) was to add the FLAG_FILTER, +FLAG_BCC_OK and FLAG_MAP_OK flags for submission to the cleanup deamon. + +This version can use all flags found in Postfix 2.x (up to 2.4 currently). +Unknown flags are ignored by the cleanup daemon (just tested with postfix +2.1), so it should be safe to set flags just understood by later versions +of postfix/cleanup. + +Even if all known flags can be set, some are not that useful when feeding +the message from qpsmtpd, e.g. + +=head2 FLAG_NONE + +no effect + +=head2 FLAG_DISCARD + +DON'T USE, use another plugin which hooks the I and returns +B just for the messages you want to drop. As long as this plugin does +not support setting queue flags on the fly from other modules, this flag +would drop ALL messages. Don't use! + +=head2 FLAG_BOUNCE + +Qpsmtpd should be configured not to accept bad messages... + +=head2 FLAG_HOLD + +Not useful in production setup, maybe in testing environment (untested, what +real effects this has). + +=over 4 + +=item Flags known by postfix 1.1: + + FLAG_NONE - No special features + FLAG_BOUNCE - Bounce bad messages + FLAG_FILTER - Enable content filter + +=item Flags known by postfix 2.1, 2.2 + +all flags from postfix 1.1, plus the following: + FLAG_HOLD - Place message on hold + FLAG_DISCARD - Discard message silently + FLAG_BCC_OK - Ok to add auto-BCC addresses + FLAG_MAP_OK - Ok to map addresses + FLAG_MASK_INTERNAL - alias for FLAG_MAP_OK + FLAG_MASK_EXTERNAL - FILTER, BCC_OK and MAP_OK + +=item Flags known by postfix 2.3 + +all flags from postfix 2.1, up to FLAG_MASK_INTERNAL. New or changed: + FLAG_MILTER - Enable Milter applications + FLAG_FILTER_ALL - FILTER and MILTER + FLAG_MASK_EXTERNAL - FILTER_ALL, BCC_OK, MAP_OK + +=item Flags known by postfix 2.4 + +currently (postfix-2.4-20061019) the same as 2.3 + +=back + +=head1 MAYBE IN FUTURE + +Settings the (additional) queue flags from another plugin. Currently at the +beginning of I all flags are reset to the flags given as plugin +parameters. =cut use Qpsmtpd::Postfix; +use Qpsmtpd::Postfix::Constants; sub register { - my ($self, $qp, @args) = @_; + my ($self, $qp, @args) = @_; - if (@args > 0) { - $self->{_queue_socket} = $args[0]; - $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 1); - } else { - $self->{_queue_socket} = "/var/spool/postfix/public/cleanup"; - } + $self->log(LOGDEBUG, "using constants generated from Postfix" + ."v$postfix_version"); + $self->{_queue_flags} = 0; + if (@args > 0) { + if ($args[0] =~ m#^/#) { + $self->{_queue_socket} = shift @args; + } + else { + $self->{_queue_socket} = "/var/spool/postfix/public/cleanup"; + } - $self->{_queue_socket} = $ENV{POSTFIXQUEUE} if $ENV{POSTFIXQUEUE}; + foreach (@args) { + if ($self->can("CLEANUP_".$_) and /^(FLAG_[A-Z0-9_]+)$/) { + $_ = $1; + $self->{_queue_flags} |= (eval "CLEANUP_$_;" || 0); + #print STDERR "queue flag: $_: ".$self->{_queue_flags}."\n"; + } + else { + $self->log(LOGWARN, "Ignoring unkown cleanup flag $_"); + } + } + } + else { + $self->{_queue_socket} = "/var/spool/postfix/public/cleanup"; + } + + $self->{_queue_socket} = $ENV{POSTFIXQUEUE} if $ENV{POSTFIXQUEUE}; } sub hook_queue { - my ($self, $transaction) = @_; + my ($self, $transaction) = @_; + $transaction->notes('postfix-queue-flags', $self->{_queue_flags}); - my ($status, $qid, $reason) = Qpsmtpd::Postfix->inject_mail($transaction); - $status and return(DECLINED, "Unable to queue message ($status, $reason)"); + # $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags')); + my ($status, $qid, $reason) = Qpsmtpd::Postfix->inject_mail($transaction); + if ($status) { + # this split is needed, because if cleanup returns + # CLEANUP_STAT_MASK_INCOMPLETE we might return DENY (CLEANUP_STAT_SIZE) + # instead of DENYSOFT (CLEANUP_STAT_WRITE, CLEANUP_STAT_BAD, + # CLEANUP_STAT_DEFER) ... n.b. this is the behaviour of 667. + foreach my $key (keys %cleanup_soft) { + my $stat = eval $key # keys have the same names as the constants + or next; + if ($status & $stat) { + return (DENYSOFT, $reason || $cleanup_soft{$key}); + } + } + foreach my $key (keys %cleanup_hard) { + my $stat = eval $key # keys have the same names as the constants + or next; + if ($status & $stat) { + return (DENY, $reason || $cleanup_hard{$key}); + } + } + # we have no idea why we're here. + return (DECLINED, $reason || "Unable to queue message ($status, $reason)"); + } - my $msg_id = $transaction->header->get('Message-Id') || ''; - $msg_id =~ s/[\r\n].*//s; # don't allow newlines in the Message-Id here - return (OK, "Queued! $msg_id (Queue-Id: $qid)"); + my $msg_id = $transaction->header->get('Message-Id') || ''; + $msg_id =~ s/[\r\n].*//s; # don't allow newlines in the Message-Id here + return (OK, "Queued! $msg_id (Queue-Id: $qid)"); } -#vim: sw=2 ts=8 +# vim: sw=2 ts=8 syn=perl diff --git a/plugins/queue/smtp-forward b/plugins/queue/smtp-forward index 1d56a6f..f7e212b 100644 --- a/plugins/queue/smtp-forward +++ b/plugins/queue/smtp-forward @@ -21,7 +21,7 @@ Optionally you can also add a port: use Net::SMTP; -sub register { +sub init { my ($self, $qp, @args) = @_; if (@args > 0) { diff --git a/plugins/quit_fortune b/plugins/quit_fortune index ffcd895..211f963 100644 --- a/plugins/quit_fortune +++ b/plugins/quit_fortune @@ -9,8 +9,6 @@ sub hook_quit { my $fortune = '/usr/games/fortune'; return DECLINED unless -e $fortune; - # local %ENV = (); - my @fortune = `$fortune -s`; @fortune = map { chop; s/^/ \/ /; $_ } @fortune; $qp->respond(221, $qp->config('me') . " closing connection.", @fortune); diff --git a/plugins/rcpt_ok b/plugins/rcpt_ok index aa547e7..a27fa67 100644 --- a/plugins/rcpt_ok +++ b/plugins/rcpt_ok @@ -2,9 +2,10 @@ # # It should be configured to be run _LAST_! # +use Qpsmtpd::DSN; sub hook_rcpt { - my ($self, $transaction, $recipient) = @_; + my ($self, $transaction, $recipient, %param) = @_; my $host = lc $recipient->host; my @rcpt_hosts = ($self->qp->config("me"), $self->qp->config("rcpthosts")); @@ -30,6 +31,8 @@ sub hook_rcpt { return (OK); } else { - return (DENY); + # default of relaying_denied is obviously DENY, + # we use the default "Relaying denied" message... + return Qpsmtpd::DSN->relaying_denied(); } } diff --git a/plugins/relay_only b/plugins/relay_only new file mode 100644 index 0000000..a25fc52 --- /dev/null +++ b/plugins/relay_only @@ -0,0 +1,35 @@ +#!/usr/bin/perl -w +=head1 NAME + +relay_only - this plugin only permits relaying + +=head1 SYNOPSIS + +# in config/plugins + +check_relay + +relay_only + +# other rcpt hooks go here + +=head1 DESCRIPTION + +This plugin can be used for the case where a server is used as the smart +relay host for internal users and external/authenticated users, but should +not be considered a normal inbound MX server + +It should be configured to be run _AFTER_ check_relay and before other +RCPT hooks! Only clients that have authenticated or are listed in the +relayclient file will be allowed to send mail. + +=cut + +sub hook_rcpt { + if ( shift->qp->connection->relay_client ) { + return (OK); + } + else { + return (DENY); + } +} diff --git a/plugins/require_resolvable_fromhost b/plugins/require_resolvable_fromhost index acab9e1..78579e9 100644 --- a/plugins/require_resolvable_fromhost +++ b/plugins/require_resolvable_fromhost @@ -1,89 +1,130 @@ -#!/usr/bin/perl -use Danga::DNS; +use Qpsmtpd::DSN; +use Net::DNS qw(mx); +use Socket; my %invalid = (); - -sub init { - my ($self, $qp) = @_; - foreach my $i ($qp->config("invalid_resolvable_fromhost")) { - $i =~ s/^\s*//; - $i =~ s/\s*$//; - if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) { - $invalid{$1} = $3; - } - } -} +my $has_ipv6 = Qpsmtpd::Constants::has_ipv6; sub hook_mail { - my ($self, $transaction, $sender) = @_; - return DECLINED - if ($self->qp->connection->notes('whitelistclient')); - - $self->transaction->notes('resolvable', 1); - return DECLINED if $sender->format eq "<>"; - return $self->check_dns($sender->host); + my ($self, $transaction, $sender, %param) = @_; + + return DECLINED + if ($self->qp->connection->notes('whitelistclient')); + + foreach my $i ($self->qp->config("invalid_resolvable_fromhost")) { + $i =~ s/^\s*//; + $i =~ s/\s*$//; + if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) { + $invalid{$1} = $3; + } + } + + if ($sender ne "<>" + and $self->qp->config("require_resolvable_fromhost") + and !$self->check_dns($sender->host)) { + if ($sender->host) { + # default of temp_resolver_failed is DENYSOFT + return Qpsmtpd::DSN->temp_resolver_failed("Could not resolve " . $sender->host); + } + else { + # default of addr_bad_from_system is DENY, we use DENYSOFT here to + # get the same behaviour as without Qpsmtpd::DSN... + return Qpsmtpd::DSN->addr_bad_from_system(DENYSOFT, + "FQDN required in the envelope sender"); + } + } + return DECLINED; + } sub check_dns { - my ($self, $host) = @_; - - # for stuff where we can't even parse a hostname out of the address - return DECLINED unless $host; - - if( $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/ ) { - $self->transaction->notes('resolvable', 1); - return DECLINED; + my ($self, $host) = @_; + my @host_answers; + + # for stuff where we can't even parse a hostname out of the address + return 0 unless $host; + + return 1 if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; + + my $res = new Net::DNS::Resolver; + $res->tcp_timeout(30); + $res->udp_timeout(30); + my @mx = mx($res, $host); + foreach my $mx (@mx) { + return mx_valid($self, $mx->exchange, $host); + } + my $query = $res->search($host); + if ($query) { + foreach my $rrA ($query->answer) { + push(@host_answers, $rrA); } - - my $total_queries = 2; - my $qp = $self->qp; - $self->log(LOGDEBUG, "Checking $host for MX record in the background"); - Danga::DNS->new( - callback => sub { dns_result($qp, @_) }, - finished => sub { $total_queries--; finished($qp, $total_queries) }, - host => $host, - type => "MX", - client => $qp->input_sock, - ); - $self->log(LOGDEBUG, "Checking $host for A record in the background"); - Danga::DNS->new( - callback => sub { dns_result($qp, @_) }, - finished => sub { $total_queries--; finished($qp, $total_queries) }, - host => $host, - client => $qp->input_sock, - ); - return CONTINUATION; -} - -sub finished { - my ($qp, $total_zones) = @_; - $qp->finish_continuation unless $total_zones; -} - -sub dns_result { - my ($qp, $result, $query) = @_; - - if ($result =~ /^[A-Z]+$/) { - # probably an error - $qp->log(LOGDEBUG, "DNS error: $result looking up $query"); - } else { - $qp->transaction->notes('resolvable', 1); - $qp->log(LOGDEBUG, "DNS lookup $query returned: $result"); + } + if ($has_ipv6) { + my $query = $res->search($host, 'AAAA'); + if ($query) { + foreach my $rrAAAA ($query->answer) { + push(@host_answers, $rrAAAA); + } } -} - - -sub hook_rcpt { - my ($self, $transaction) = @_; - - if (!$transaction->notes('resolvable')) { - my $sender = $transaction->sender; - $self->log(LOGDEBUG, "Could not resolve " .$sender->host) if $sender->host; - return (DENYSOFT, - ($sender->host - ? "Could not resolve ". $sender->host - : "FQDN required in the envelope sender")); + } + if (@host_answers) { + foreach my $rr (@host_answers) { + return is_valid($rr->address) if $rr->type eq "A" or $rr->type eq "AAAA"; + return mx_valid($self, $rr->exchange, $host) if $rr->type eq "MX"; } - - return DECLINED; + } + else { + $self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring) + unless $res->errorstring eq "NXDOMAIN"; + } + return 0; } + +sub is_valid { + my $ip = shift; + my ($net,$mask); + ### while (($net,$mask) = each %invalid) { + ### ... does NOT reset to beginning, will start on + ### 2nd invocation after where it denied the first time..., so + ### 2nd time the same "MAIL FROM" would be accepted! + foreach $net (keys %invalid) { + $mask = $invalid{$net}; + $mask = pack "B32", "1"x($mask)."0"x(32-$mask); + return 0 + if join(".", unpack("C4", inet_aton($ip) & $mask)) eq $net; + } + return 1; +} + +sub mx_valid { + my ($self, $name, $host) = @_; + my $res = new Net::DNS::Resolver; + my @mx_answers; + my $query = $res->search($name, 'A'); + if ($query) { + foreach my $rrA ($query->answer) { + push(@mx_answers, $rrA); + } + } + if ($has_ipv6) { + my $query = $res->search($name, 'AAAA'); + if ($query) { + foreach my $rrAAAA ($query->answer) { + push(@mx_answers, $rrAAAA); + } + } + } + if (@mx_answers) { + foreach my $rr (@mx_answers) { + next unless $rr->type eq "A" or $rr->type eq "AAAA"; + return is_valid($rr->address); + } + } + else { + $self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring) + unless $res->errorstring eq "NXDOMAIN"; + } + return 0; +} + +# vim: ts=2 sw=2 expandtab syn=perl diff --git a/plugins/rhsbl b/plugins/rhsbl index 5fc3368..a9b8e56 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -1,32 +1,38 @@ -#!/usr/bin/perl -use Danga::DNS; sub hook_mail { - my ($self, $transaction, $sender) = @_; + my ($self, $transaction, $sender, %param) = @_; + my $res = new Net::DNS::Resolver; + my $sel = IO::Select->new(); my %rhsbl_zones_map = (); - # Perform any RHS lookups in the background. We just send the query packets here - # and pick up any results in the RCPT handler. + # Perform any RHS lookups in the background. We just send the query packets + # here and pick up any results in the RCPT handler. # MTAs gets confused when you reject mail during MAIL FROM: - my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->config('rhsbl_zones'); + my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->qp->config('rhsbl_zones'); if ($sender->format ne '<>' and %rhsbl_zones) { - my $helo = $self->connection->hello_host; push(my @hosts, $sender->host); - push(@hosts, $helo) if $helo && $helo ne $sender->host; + #my $helo = $self->qp->connection->hello_host; + #push(@hosts, $helo) if $helo && $helo ne $sender->host; for my $host (@hosts) { - for my $rhsbl (keys %rhsbl_zones) { + for my $rhsbl (keys %rhsbl_zones) { + # fix to find TXT records, if the rhsbl_zones line doesn't have second field + if (defined($rhsbl_zones{$rhsbl})) { $self->log(LOGDEBUG, "Checking $host.$rhsbl for A record in the background"); - Danga::DNS->new( - callback => sub { $self->process_result($host, $rhsbl_zones{$rhsbl}, @_) }, - host => "$host.$rhsbl", - client => $self->qp->input_sock, - ); + $sel->add($res->bgsend("$host.$rhsbl")); + } else { + $self->log(LOGDEBUG, "Checking $host.$rhsbl for TXT record in the background"); + $sel->add($res->bgsend("$host.$rhsbl", "TXT")); } + $rhsbl_zones_map{"$host.$rhsbl"} = $rhsbl_zones{$rhsbl}; } + } + + %{$self->{_rhsbl_zones_map}} = %rhsbl_zones_map; + $transaction->notes('rhsbl_sockets', $sel); } else { $self->log(LOGDEBUG, 'no RHS checks necessary'); } @@ -34,28 +40,84 @@ sub hook_mail { return DECLINED; } -sub process_result { - my ($self, $host, $template, $result, $query) = @_; - - if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) { - # NXDOMAIN or error - return; - } - - my $tran = $self->transaction; - return if $tran->notes('rhsbl'); - if ($host eq $tran->sender->host) { - $tran->notes('rhsbl', "Mail from $host rejected because it $template"); - } - else { - $tran->notes('rhsbl', "Mail from HELO $host rejected because it $template"); - } -} - sub hook_rcpt { my ($self, $transaction, $rcpt) = @_; + my $host = $transaction->sender->host; + my $hello = $self->qp->connection->hello_host; - my $result = $transaction->notes('rhsbl'); + my $result = $self->process_sockets; + if ($result && defined($self->{_rhsbl_zones_map}{$result})) { + if ($result =~ /^$host\./ ) { + return (DENY, "Mail from $host rejected because it " . $self->{_rhsbl_zones_map}{$result}); + } else { + return (DENY, "Mail from HELO $hello rejected because it " . $self->{_rhsbl_zones_map}{$result}); + } + } return (DENY, $result) if $result; return DECLINED; } + +sub process_sockets { + my ($self) = @_; + my $trans = $self->transaction; + my $result = ''; + + return $trans->notes('rhsbl') if $trans->notes('rhsbl'); + + my $res = new Net::DNS::Resolver; + my $sel = $trans->notes('rhsbl_sockets') or return ''; + + $self->log(LOGDEBUG, 'waiting for rhsbl dns'); + + # don't wait more than 8 seconds here + my @ready = $sel->can_read(8); + + $self->log(LOGDEBUG, 'DONE waiting for rhsbl dns, got ' , scalar @ready, ' answers ...') ; + return '' unless @ready; + + for my $socket (@ready) { + my $query = $res->bgread($socket); + $sel->remove($socket); + undef $socket; + + if ($query) { + foreach my $rr ($query->answer) { + $self->log(LOGDEBUG, 'got an ' . $rr->type . ' record ' . $rr->name); + if ($rr->type eq 'A') { + $result = $rr->name; + $self->log(LOGDEBUG, "A record found for $result with IP " . $rr->address); + last; + } elsif ($rr->type eq 'TXT') { + $result = $rr->txtdata; + $self->log(LOGDEBUG, "TXT record found: " . $rr->txtdata); + last; + } + } + } else { + $self->log(LOGCRIT, "query failed: ", $res->errorstring) unless $res->errorstring eq 'NXDOMAIN'; + } + + if ($result) { + #kill any other pending I/O + $trans->notes('rhsbl_sockets', undef); + return $trans->notes('rhsbl', $result); + } + } + + if ($sel->count) { + # loop around if we have dns results left + return $self->process_sockets(); + } + + # if there was more to read; then forget it + $trans->notes('rhsbl_sockets', undef); + + return $trans->notes('rhsbl', $result); +} + +sub hook_disconnect { + my ($self, $transaction) = @_; + + $transaction->notes('rhsbl_sockets', undef); + return DECLINED; +} diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index a0c678d..287847e 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -34,7 +34,7 @@ sub register { } sub hook_mail { - my ($self, $transaction, $sender) = @_; + my ($self, $transaction, $sender, %param) = @_; return (DECLINED) unless ($sender->format ne "<>" and $sender->host && $sender->user); @@ -71,7 +71,7 @@ sub hook_mail { } sub hook_rcpt { - my ($self, $transaction, $rcpt) = @_; + my ($self, $transaction, $rcpt, %param) = @_; # special addresses don't get SPF-tested. return DECLINED if $rcpt and $rcpt->user and $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i; diff --git a/plugins/spamassassin b/plugins/spamassassin index 96360c4..5b62153 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -44,11 +44,12 @@ might want to make another plugin that does this on a per user basis. The default is to never munge the subject based on the SpamAssassin score. -=item spamd_socket [/path/to/socket] +=item spamd_socket [/path/to/socket|spamd.host:port] -Beginning with Mail::SpamAssassin 2.60, it is possible to use Unix -domain sockets for spamd. This is faster and more secure than using -a TCP connection. +Beginning with Mail::SpamAssassin 2.60, it is possible to use Unix +domain sockets for spamd. This is faster and more secure than using a +TCP connection, but if you run spamd on a remote machine, you need to +use a TCP connection. =item leave_old_headers [drop|rename|keep] @@ -71,6 +72,7 @@ Make the "subject munge string" configurable =cut +use Qpsmtpd::DSN; use Socket qw(:DEFAULT :crlf); use IO::Handle; @@ -94,12 +96,16 @@ sub hook_data_post { # check_spam my ($self, $transaction) = @_; $self->log(LOGDEBUG, "check_spam"); - return (DECLINED) if $transaction->body_size > 500_000; + return (DECLINED) if $transaction->data_size > 500_000; my $leave_old_headers = lc($self->{_args}->{leave_old_headers}) || 'rename'; my $remote = 'localhost'; my $port = 783; + if ($self->{_args}->{spamd_socket} =~ /^([\w.-]+):(\d+)$/) { + $remote = $1; + $port = $2; + } if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') } die "No port" unless $port; my $iaddr = inet_aton($remote) or @@ -225,7 +231,8 @@ sub check_spam_reject { my $score = $self->get_spam_score($transaction) or return DECLINED; $self->log(LOGDEBUG, "check_spam_reject: score=$score"); - return (DENY, "spam score exceeded threshold") + # default of media_unsupported is DENY, so just change the message + return Qpsmtpd::DSN->media_unsupported("spam score exceeded threshold") if $score >= $self->{_args}->{reject_threshold}; $self->log(LOGDEBUG, "check_spam_reject: passed"); diff --git a/plugins/stats b/plugins/stats deleted file mode 100644 index 43c6e37..0000000 --- a/plugins/stats +++ /dev/null @@ -1,67 +0,0 @@ -#!/usr/bin/perl -w - -use Time::HiRes qw(time); - -my $START_TIME = time; -our $MAILS_RECEIVED = 0; -our $MAILS_REJECTED = 0; -our $MAILS_TEMPFAIL = 0; - -sub get_stats { - my $class = shift; - my $uptime = $class->uptime; - my $recvd = $class->mails_received; - my $reject = $class->mails_rejected; - my $soft = $class->mails_tempfailed; - my $rate = $class->mails_per_sec; - return sprintf(" Uptime: %0.2f sec\n". - " Mails Received: % 10d\n". - " 5xx: % 10d\n". - " 4xx: % 10d\n". - "Mails per second: %0.2f\n", - $uptime, $recvd, $reject, $soft, $rate); -} - -sub hook_deny { - my ($self, $tran, $plugin, $level) = @_; - - if ($level == DENY or $level == DENY_DISCONNECT) { - $MAILS_REJECTED++; - } - elsif ($level == DENYSOFT or $level == DENYSOFT_DISCONNECT) { - $MAILS_TEMPFAIL++; - } - - return DECLINED; -} - -sub hook_mail { - my $self = shift; - - $MAILS_RECEIVED++; - - return DECLINED; -} - -sub uptime { - return (time() - $START_TIME); -} - -sub mails_received { - return $MAILS_RECEIVED; -} - -sub mails_rejected { - return $MAILS_REJECTED; -} - -sub mails_tempfailed { - return $MAILS_TEMPFAIL; -} - -sub mails_per_sec { - my $class = shift; - return ($MAILS_RECEIVED / $class->uptime()); -} - - diff --git a/plugins/tls b/plugins/tls index 2731449..c21c792 100644 --- a/plugins/tls +++ b/plugins/tls @@ -8,46 +8,89 @@ tls - plugin to support STARTTLS # in config/plugins - tls ssl/cert.pem ssl/privkey.pem +tls [B] + +=over indentlevel + +=item B + +Path to the server certificate file. Default: I + +=item B + +Path to the private key file. Default: I + +=item B + +Path to the certificate autority file. Default: I =head1 DESCRIPTION -This plugin implements basic TLS support. +This plugin implements basic TLS support. It can also be used to support +port 465 (SMTP over SSL), but only with qpsmtpd-forkserver. In this case, +be sure to load plugins/tls before any other connect plugins and start +qpsmtpd like this: + + qpsmtpd-forkserver --port 25 --port 465 + +You can also specify multiple --listen-address options as well; see the help +for qpsmtpd-forkserver for more details. If TLS is successfully negotiated then the C field in the Connection notes is set. If you wish to make TLS mandatory you should check that field and take appropriate action. Note that you can only do that from MAIL FROM onwards. +Use the script C to automatically generate a self-signed +certificate with the appropriate characteristics. Otherwise, you should +give absolute pathnames to the certificate, key, and the CA root cert +used to sign that certificate. + +=head1 CIPHERS and COMPATIBILITY + +By default, we use only the plugins that openssl considers to be +"high security". If you need to tweak the available ciphers for some +broken client (such as Versamail 3.x), have a look at the available +ciphers at L, +and put a suitable string in config/tls_ciphers (e.g. "DEFAULT" or +"HIGH:MEDIUM") + =cut -use IO::Socket::SSL; # qw(debug1 debug2 debug3 debug4); +use IO::Socket::SSL;# qw(debug1 debug2 debug3 debug4); sub init { - my ($self, $qp, $cert, $key) = @_; + my ($self, $qp, $cert, $key, $ca) = @_; $cert ||= 'ssl/qpsmtpd-server.crt'; $key ||= 'ssl/qpsmtpd-server.key'; - unless ( -f $cert && -f $key ) { - $self->log(LOGERROR, "Cannot locate cert/key! Run plugins/tls_cert to generate"); - return; + $ca ||= 'ssl/qpsmtpd-ca.crt'; + unless ( -f $cert && -f $key && -f $ca ) { + $self->log(LOGERROR, "Cannot locate cert/key! Run plugins/tls_cert to generate"); + return; } $self->tls_cert($cert); $self->tls_key($key); + $self->tls_ca($ca); + $self->tls_ciphers($self->qp->config('tls_ciphers') || 'HIGH'); + $self->log(LOGINFO, "ciphers: $self->tls_ciphers"); + local $^W; # this bit is very noisy... my $ssl_ctx = IO::Socket::SSL::SSL_Context->new( SSL_use_cert => 1, SSL_cert_file => $self->tls_cert, SSL_key_file => $self->tls_key, - SSL_cipher_list => 'HIGH', + SSL_ca_file => $self->tls_ca, + SSL_cipher_list => $self->tls_ciphers, SSL_server => 1 ) or die "Could not create SSL context: $!"; - # now extract the password... + $self->ssl_context($ssl_ctx); # Check for possible AUTH mechanisms HOOK: foreach my $hook ( keys %{$qp->{hooks}} ) { + no strict 'refs'; if ( $hook =~ m/^auth-?(.+)?$/ ) { if ( defined $1 ) { my $hooksub = "hook_$hook"; @@ -68,8 +111,10 @@ sub hook_ehlo { return DECLINED if $self->connection->notes('tls_enabled'); return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed'); my $cap = $transaction->notes('capabilities'); + $cap ||= []; push @$cap, 'STARTTLS'; $transaction->notes('tls_enabled', 1); + $transaction->notes('capabilities', $cap); return DECLINED; } @@ -82,43 +127,7 @@ sub hook_unrecognized_command { # OK, now we setup TLS $self->qp->respond (220, "Go ahead with TLS"); - eval { - my $tlssocket; - if ($self->qp->isa('Danga::Socket')) { - # high_perf - $tlssocket = IO::Socket::SSL->start_SSL($self->qp->sock, - SSL_use_cert => 1, - SSL_cert_file => $self->tls_cert, - SSL_key_file => $self->tls_key, - SSL_cipher_list => 'HIGH', - SSL_server => 1, - SSL_reuse_ctx => $self->ssl_context, - ) or die "Could not convert SSL socket: $!"; - } - else { - $tlssocket = IO::Socket::SSL->new_from_fd( - fileno(STDIN), '+>', - SSL_use_cert => 1, - SSL_cert_file => $self->tls_cert, - SSL_key_file => $self->tls_key, - SSL_cipher_list => 'HIGH', - SSL_server => 1, - SSL_reuse_ctx => $self->ssl_context, - ) or die "Could not create SSL socket: $!"; - } - - # Clone connection object (without data received from client) - $self->qp->connection($self->connection->clone()); - $self->qp->reset_transaction; - if ($self->qp->isa('Danga::Socket')) { - $self->connection->notes('tls_socket', $tlssocket); - } - else { - *STDIN = *STDOUT = $self->connection->notes('tls_socket', $tlssocket); - } - $self->connection->notes('tls_enabled', 1); - }; - if ($@) { + unless ( _convert_to_ssl($self) ) { # SSL setup failed. Now we must respond to every command with 5XX warn("TLS failed: $@\n"); $transaction->notes('ssl_failed', 1); @@ -129,6 +138,48 @@ sub hook_unrecognized_command { return DONE; } +sub hook_connect { + my ($self, $transaction) = @_; + + my $local_port = $self->qp->connection->local_port; + return DECLINED unless $local_port == 465; # SMTPS + + unless ( _convert_to_ssl($self) ) { + return (DENY_DISCONNECT, "Cannot establish SSL session"); + } + $self->log(LOGWARN, "Connected via SMTPS"); + return DECLINED; +} + +sub _convert_to_ssl { + my ($self) = @_; + + eval { + my $tlssocket = IO::Socket::SSL->new_from_fd( + fileno(STDIN), '+>', + SSL_use_cert => 1, + SSL_cert_file => $self->tls_cert, + SSL_key_file => $self->tls_key, + SSL_ca_file => $self->tls_ca, + SSL_cipher_list => $self->tls_ciphers, + SSL_server => 1, + SSL_reuse_ctx => $self->ssl_context, + ) or die "Could not create SSL socket: $!"; + + # Clone connection object (without data received from client) + $self->qp->connection($self->connection->clone()); + $self->qp->reset_transaction; + *STDIN = *STDOUT = $self->connection->notes('tls_socket', $tlssocket); + $self->connection->notes('tls_enabled', 1); + }; + if ($@) { + return 0; + } + else { + return 1; + } +} + sub can_do_tls { my ($self) = @_; $self->tls_cert && -r $self->tls_cert; @@ -146,6 +197,18 @@ sub tls_key { $self->{_tls_key}; } +sub tls_ca { + my $self = shift; + @_ and $self->{_tls_ca} = shift; + $self->{_tls_ca}; +} + +sub tls_ciphers { + my $self = shift; + @_ and $self->{_tls_ciphers} = shift; + $self->{_tls_ciphers}; +} + sub ssl_context { my $self = shift; @_ and $self->{_ssl_ctx} = shift; diff --git a/plugins/tls_cert b/plugins/tls_cert index 51c83d2..3b4d312 100755 --- a/plugins/tls_cert +++ b/plugins/tls_cert @@ -65,7 +65,7 @@ system('openssl', 'genrsa', '-out', $SERVER_key, 1024) == 0 system('openssl', 'req', '-config', $SERVERfilename, '-new', '-key', $SERVER_key, '-out', $SERVER_csr) == 0 - or die "Cannot create CA cert: $?"; + or die "Cannot create server cert: $?"; my ($SIGN, $SIGNfilename) = tempfile( $template, DIR => "ssl", UNLINK => 1); print ${SIGN} <<"EOT"; diff --git a/plugins/virus/bitdefender b/plugins/virus/bitdefender index b29d50c..57eb974 100644 --- a/plugins/virus/bitdefender +++ b/plugins/virus/bitdefender @@ -80,10 +80,10 @@ sub register { sub hook_data_post { my ( $self, $transaction ) = @_; - if ( $transaction->body_size > $self->{"_bitd"}->{"max_size"} ) { + if ( $transaction->data_size > $self->{"_bitd"}->{"max_size"} ) { $self->log( LOGWARN, 'Mail too large to scan (' - . $transaction->body_size . " vs " + . $transaction->data_size . " vs " . $self->{"_bitd"}->{"max_size"} . ")" ); return (DECLINED); diff --git a/plugins/virus/clamav b/plugins/virus/clamav index 85a928a..a74e0f1 100644 --- a/plugins/virus/clamav +++ b/plugins/virus/clamav @@ -27,6 +27,13 @@ Path to the clamav commandline scanner. Mail will be passed to the clamav scanner in Berkeley mbox format (that is, with a "From " line). See the discussion below on which commandline scanner to use. +=item clamd_conf=I (e.g. I) + +Path to the clamd configuration file. Passed as an argument to the +command-line scanner (--config-file=I). + +The default value is '/etc/clamd.conf'. + =item action=EI | IE (e.g. I) Selects an action to take when an inbound message is found to be infected. @@ -42,7 +49,7 @@ Specifies the maximum size, in bytes, for mail to be scanned. Any mail exceeding this size will be left alone. This is recommended, as large mail can take an exceedingly long time to scan. The default is 524288, or 512k. -=item tmp_dir=I (e.g. I) +=item tmp_dir=I (e.g. I) Specify an alternate temporary directory. If not specified, the qpsmtpd I will be used. If neither is available, I<~/tmp/> will be tried, @@ -120,6 +127,9 @@ sub register { elsif (/^clamscan_path=(\/[\/\-\_\.a-z0-9A-Z]*)$/) { $self->{_clamscan_loc} = $1; } + elsif (/^clamd_conf=(\/[\/\-\_\.a-z0-9A-Z]*)$/) { + $self->{_clamd_conf} = "$1"; + } elsif (/^tmp_dir=(\/[\/\-\_\.a-z0-9A-Z]*)$/) { $self->{_spool_dir} = $1; } @@ -138,6 +148,7 @@ sub register { $self->{_max_size} ||= 512 * 1024; $self->{_spool_dir} ||= $self->spool_dir(); $self->{_back_compat} ||= ''; # make sure something is set + $self->{_clamd_conf} ||= '/etc/clamd/conf'; # make sure something is set unless ($self->{_spool_dir}) { $self->log(LOGERROR, "No spool dir configuration found"); @@ -153,9 +164,9 @@ sub register { sub hook_data_post { my ($self, $transaction) = @_; - if ($transaction->body_size > $self->{_max_size}) { + if ($transaction->data_size > $self->{_max_size}) { $self->log(LOGWARN, 'Mail too large to scan ('. - $transaction->body_size . " vs $self->{_max_size})" ); + $transaction->data_size . " vs $self->{_max_size})" ); return (DECLINED); } @@ -172,9 +183,11 @@ sub hook_data_post { } # Now do the actual scanning! - my $cmd = $self->{_clamscan_loc}." --stdout " - .$self->{_back_compat} - ." --disable-summary $filename 2>&1"; + my $cmd = $self->{_clamscan_loc} + . " --stdout " + . $self->{_back_compat} + . " --config-file=" . $self->{_clamd_conf} + . " --disable-summary $filename 2>&1"; $self->log(LOGDEBUG, "Running: $cmd"); my $output = `$cmd`; diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index e18bf68..36f647d 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -107,8 +107,8 @@ sub hook_data_post { my ( $self, $transaction ) = @_; $DB::single = 1; - if ( $transaction->body_size > $self->{"_clamd"}->{"max_size"} * 1024 ) { - $self->log( LOGNOTICE, "Declining due to body_size" ); + if ( $transaction->data_size > $self->{"_clamd"}->{"max_size"} * 1024 ) { + $self->log( LOGNOTICE, "Declining due to data_size" ); return (DECLINED); } @@ -154,8 +154,8 @@ sub hook_data_post { } unless ( $clamd->ping() ) { - $self->log( LOGERROR, "Cannot ping clamd server - did you provide the correct clamd port or socket?" ); - return DECLINED; + $self->log( LOGERROR, "Cannot ping clamd server - did you provide the correct clamd port or socket?" ); + return DENYSOFT; } if ( my %found = $clamd->scan($filename) ) { diff --git a/plugins/virus/klez_filter b/plugins/virus/klez_filter index 4c6b9b8..620de98 100644 --- a/plugins/virus/klez_filter +++ b/plugins/virus/klez_filter @@ -4,9 +4,9 @@ sub hook_data_post { # klez files are always sorta big .. how big? Dunno. return (DECLINED) - if $transaction->body_size < 60_000; + if $transaction->data_size < 60_000; # 220k was too little, so let's just disable the "big size check" - # or $transaction->body_size > 1_000_000; + # or $transaction->data_size > 1_000_000; # maybe it would be worthwhile to add a check for # Content-Type: multipart/alternative; here? diff --git a/plugins/virus/sophie b/plugins/virus/sophie index 6850590..0b35d32 100644 --- a/plugins/virus/sophie +++ b/plugins/virus/sophie @@ -16,8 +16,8 @@ sub hook_data_post { my ( $self, $transaction ) = @_; $DB::single = 1; - if ( $transaction->body_size > $self->{"_sophie"}->{"max_size"} * 1024 ) { - $self->log( LOGNOTICE, "Declining due to body_size" ); + if ( $transaction->data_size > $self->{"_sophie"}->{"max_size"} * 1024 ) { + $self->log( LOGNOTICE, "Declining due to data_size" ); return (DECLINED); } diff --git a/plugins/virus/uvscan b/plugins/virus/uvscan index 55447ed..bfe3345 100644 --- a/plugins/virus/uvscan +++ b/plugins/virus/uvscan @@ -55,7 +55,7 @@ sub hook_data_post { my ($self, $transaction) = @_; return (DECLINED) - if $transaction->body_size > 250_000; + if $transaction->data_size > 250_000; # Ignore non-multipart emails my $content_type = $transaction->header->get('Content-Type'); diff --git a/qpsmtpd b/qpsmtpd index c139011..092cd3a 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -1,347 +1,31 @@ -#!/usr/bin/perl - -use lib "./lib"; -BEGIN { - delete $ENV{ENV}; - delete $ENV{BASH_ENV}; - $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin:/usr/local/bin'; -} +#!/usr/bin/perl -Tw +# Copyright (c) 2001 Ask Bjoern Hansen. See the LICENSE file for details. +# The "command dispatch" system is taken from colobus - http://trainedmonkey.com/colobus/ +# +# this is designed to be run under tcpserver (http://cr.yp.to/ucspi-tcp.html) +# or inetd if you're into that sort of thing +# +# +# For more information see http://develooper.com/code/qpsmtpd/ +# +# +use lib 'lib'; +use Qpsmtpd::TcpServer; use strict; -use vars qw($DEBUG); -use FindBin qw(); -# TODO: need to make this taint friendly -use lib "$FindBin::Bin/lib"; -use Danga::Socket; -use Danga::Client; -use Qpsmtpd::PollServer; -use Qpsmtpd::ConfigServer; -use Qpsmtpd::Constants; -use IO::Socket; -use Carp; -use POSIX qw(WNOHANG); -use Getopt::Long; +$| = 1; -$|++; +delete $ENV{ENV}; +$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin'; -use Socket qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET); +my $qpsmtpd = Qpsmtpd::TcpServer->new(); +$qpsmtpd->load_plugins(); +$qpsmtpd->start_connection(); +$qpsmtpd->run(); -$SIG{'PIPE'} = "IGNORE"; # handled manually +__END__ -$DEBUG = 0; -my $CONFIG_PORT = 20025; -my $CONFIG_LOCALADDR = '127.0.0.1'; -my $PORT = 2525; -my $LOCALADDR = '0.0.0.0'; -my $PROCS = 1; -my $MAXCONN = 15; # max simultaneous connections -my $USER = 'smtpd'; # user to suid to -my $MAXCONNIP = 5; # max simultaneous connections from one IP -my $PAUSED = 0; -my $NUMACCEPT = 20; -sub help { - print < \$PORT, - 'l|listen-address=s' => \$LOCALADDR, - 'j|procs=i' => \$PROCS, - 'd|debug+' => \$DEBUG, - 'c|limit-connections=i' => \$MAXCONN, - 'm|max-from-ip=i' => \$MAXCONNIP, - 'u|user=s' => \$USER, - 'a|accept=i' => \$NUMACCEPT, - 'h|help' => \&help, - 'use-poll' => \&force_poll, -) || help(); - -# detaint the commandline -if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &help } -if ($LOCALADDR =~ /^([\d\w\-.]+)$/) { $LOCALADDR = $1 } else { &help } -if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &help } -if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &help } -if ($PROCS =~ /^(\d+)$/) { $PROCS = $1 } else { &help } -if ($NUMACCEPT =~ /^(\d+)$/) { $NUMACCEPT = $1 } else { &help } -my $_NUMACCEPT = $NUMACCEPT; -# This is a bit of a hack, but we get to approximate MAXCONN stuff when we -# have multiple children listening on the same socket. -$MAXCONN /= $PROCS; -$MAXCONNIP /= $PROCS; - -sub force_poll { - $Danga::Socket::HaveEpoll = 0; - $Danga::Socket::HaveKQueue = 0; -} - -# Danga::Socket::init_poller(); - -my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" : - $Danga::Socket::HaveKQueue ? "kqueue()" : "poll()"); - -my $SERVER; -my $CONFIG_SERVER; - -my %childstatus = (); - -run_as_server(); -exit(0); - -sub _fork { - my $pid = fork; - if (!defined($pid)) { die "Cannot fork: $!" } - return $pid if $pid; - - # Fixup Net::DNS randomness after fork - srand($$ ^ time); - - local $^W; - delete $INC{'Net/DNS/Header.pm'}; - require Net::DNS::Header; - - # cope with different versions of Net::DNS - eval { - $Net::DNS::Resolver::global{id} = 1; - $Net::DNS::Resolver::global{id} = int(rand(Net::DNS::Resolver::MAX_ID())); - # print "Next DNS ID: $Net::DNS::Resolver::global{id}\n"; - }; - if ($@) { - # print "Next DNS ID: " . Net::DNS::Header::nextid() . "\n"; - } - - # Fixup lost kqueue after fork - $Danga::Socket::HaveKQueue = undef; - Danga::Socket::init_poller(); -} - -sub spawn_child { - _fork and return; - - $SIG{CHLD} = "DEFAULT"; - - Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler); - Qpsmtpd::PollServer->EventLoop(); - exit; -} - -sub sig_chld { - $SIG{CHLD} = 'IGNORE'; - while ( (my $child = waitpid(-1,WNOHANG)) > 0) { - last unless $child > 0; - print "child $child died\n"; - delete $childstatus{$child}; - } - # restart a new child (assuming this one died) - spawn_child(); - $SIG{CHLD} = \&sig_chld; -} - -sub run_as_server { - local $::MAXconn = $MAXCONN; - # establish SERVER socket, bind and listen. - $SERVER = IO::Socket::INET->new(LocalPort => $PORT, - LocalAddr => $LOCALADDR, - Type => SOCK_STREAM, - Proto => IPPROTO_TCP, - Blocking => 0, - Reuse => 1, - Listen => SOMAXCONN ) - or die "Error creating server $LOCALADDR:$PORT : $@\n"; - - IO::Handle::blocking($SERVER, 0); - binmode($SERVER, ':raw'); - - $CONFIG_SERVER = IO::Socket::INET->new(LocalPort => $CONFIG_PORT, - LocalAddr => $CONFIG_LOCALADDR, - Type => SOCK_STREAM, - Proto => IPPROTO_TCP, - Blocking => 0, - Reuse => 1, - Listen => 1 ) - or die "Error creating server $CONFIG_LOCALADDR:$CONFIG_PORT : $@\n"; - - IO::Handle::blocking($CONFIG_SERVER, 0); - binmode($CONFIG_SERVER, ':raw'); - - # Drop priviledges - my (undef, undef, $quid, $qgid) = getpwnam $USER or - die "unable to determine uid/gid for $USER\n"; - $) = ""; - POSIX::setgid($qgid) or - die "unable to change gid: $!\n"; - POSIX::setuid($quid) or - die "unable to change uid: $!\n"; - $> = $quid; - - # Load plugins here - my $plugin_loader = Qpsmtpd::SMTP->new(); - $plugin_loader->load_plugins; - - $plugin_loader->log(LOGINFO, 'Running as user '. - (getpwuid($>) || $>) . - ', group '. - (getgrgid($)) || $))); - - if ($PROCS > 1) { - $SIG{'CHLD'} = \&sig_chld; - my @kids; - for (1..$PROCS) { - push @kids, spawn_child(); - } - $SIG{INT} = $SIG{TERM} = sub { $SIG{CHLD} = "IGNORE"; kill 2 => @kids; exit }; - $plugin_loader->log(LOGDEBUG, "Listening on $PORT with $PROCS children $POLL"); - sleep while (1); - } - else { - $plugin_loader->log(LOGDEBUG, "Listening on $PORT with single process $POLL"); - Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler, - fileno($CONFIG_SERVER) => \&config_handler, - ); - while (1) { - Qpsmtpd::PollServer->EventLoop(); - } - exit; - } - -} - -sub config_handler { - my $csock = $CONFIG_SERVER->accept(); - if (!$csock) { - # warn("accept failed on config server: $!"); - return; - } - binmode($csock, ':raw'); - - printf("Config server connection\n") if $DEBUG; - - IO::Handle::blocking($csock, 0); - setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; - - my $client = Qpsmtpd::ConfigServer->new($csock); - $client->watch_read(1); - return; -} - -# Accept all new connections -sub accept_handler { - my $running; - my $descriptors = Danga::Client->DescriptorMap; - $running = scalar keys %$descriptors; - - for (1 .. $NUMACCEPT) { - if ($running >= $MAXCONN) { - ::log(LOGINFO,"Too many connections: $running >= $MAXCONN."); - return; - } - $running++; - if (! _accept_handler($running)) { - # got here because we have too many accepts. - $NUMACCEPT = $_NUMACCEPT; - return; - } - } - - # got here because we have accept's left. - # So double the number we accept next time. - $NUMACCEPT *= 2; -} - -use Errno qw(EAGAIN EWOULDBLOCK); - -sub _accept_handler { - my $running = shift; - - my $csock = $SERVER->accept(); - if (!$csock) { - # warn("accept() failed: $!"); - return; - if ($! == EAGAIN || $! == EWOULDBLOCK) { - return; - } - else { - warn("accept() failed: $!"); - return 1; - } - } - binmode($csock, ':raw'); - - printf("Listen child making a Qpsmtpd::PollServer for %d.\n", fileno($csock)) - if $DEBUG; - - IO::Handle::blocking($csock, 0); - setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; - - # multiplex mode - my $client = Qpsmtpd::PollServer->new($csock); - my $rem_ip = $client->peer_ip_string; - - if ($PAUSED) { - $client->write("451 Sorry, this server is currently paused\r\n"); - $client->close; - return 1; - } - - if ($MAXCONNIP) { - my $num_conn = 1; # seed with current value - - # If we for-loop directly over values %childstatus, a SIGCHLD - # can call REAPER and slip $rip out from under us. Causes - # "Use of freed value in iteration" under perl 5.8.4. - my $descriptors = Danga::Client->DescriptorMap; - my @obj = values %$descriptors; - foreach my $obj (@obj) { - local $^W; - # This is a bit of a slow way to do this. Wish I could cache the method call. - ++$num_conn if ($obj->peer_ip_string eq $rem_ip); - } - - if ($num_conn > $MAXCONNIP) { - $client->log(LOGINFO,"Too many connections from $rem_ip: " - ."$num_conn > $MAXCONNIP. Denying connection."); - $client->write("451 Sorry, too many connections from $rem_ip, try again later\r\n"); - $client->close; - return 1; - } - $client->log(LOGINFO, "accepted connection $running/$MAXCONN ($num_conn/$MAXCONNIP) from $rem_ip"); - } - - $client->push_back_read("Connect\n"); - $client->watch_read(1); - return 1; -} - -######################################################################## - -sub log { - my ($level,$message) = @_; - # $level not used yet. this is reimplemented from elsewhere anyway - warn("$$ fd:? $message\n"); -} - -sub pause { - my ($pause) = @_; - $PAUSED = $pause; -} +1; diff --git a/qpsmtpd-async b/qpsmtpd-async new file mode 100755 index 0000000..0890ba4 --- /dev/null +++ b/qpsmtpd-async @@ -0,0 +1,311 @@ +#!/usr/bin/perl + +use lib "./lib"; +BEGIN { + delete $ENV{ENV}; + delete $ENV{BASH_ENV}; + $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin:/usr/local/bin'; +} + +use strict; +use vars qw($DEBUG); +use FindBin qw(); +# TODO: need to make this taint friendly +use lib "$FindBin::Bin/lib"; +use Danga::Socket; +use Danga::Client; +use Qpsmtpd::PollServer; +use Qpsmtpd::ConfigServer; +use Qpsmtpd::Constants; +use IO::Socket; +use Carp; +use POSIX qw(WNOHANG); +use Getopt::Long; + +$|++; + +use Socket qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET); + +$SIG{'PIPE'} = "IGNORE"; # handled manually + +$DEBUG = 0; + +my $CONFIG_PORT = 20025; +my $CONFIG_LOCALADDR = '127.0.0.1'; + +my $PORT = 2525; +my $LOCALADDR = '0.0.0.0'; +my $PROCS = 1; +my $USER = 'smtpd'; # user to suid to +my $PAUSED = 0; +my $NUMACCEPT = 20; +my $ACCEPT_RSET = Danga::Socket->AddTimer(30, \&reset_num_accept); + +# make sure we don't spend forever doing accept() +use constant ACCEPT_MAX => 1000; + +sub reset_num_accept { + $NUMACCEPT = 20; +} + +sub help { + print < \$PORT, + 'l|listen-address=s' => \$LOCALADDR, + 'j|procs=i' => \$PROCS, + 'd|debug+' => \$DEBUG, + 'u|user=s' => \$USER, + 'h|help' => \&help, +) || help(); + +# detaint the commandline +if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &help } +if ($LOCALADDR =~ /^([\d\w\-.]+)$/) { $LOCALADDR = $1 } else { &help } +if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &help } +if ($PROCS =~ /^(\d+)$/) { $PROCS = $1 } else { &help } + +sub force_poll { + $Danga::Socket::HaveEpoll = 0; + $Danga::Socket::HaveKQueue = 0; +} + +my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" : + $Danga::Socket::HaveKQueue ? "kqueue()" : "poll()"); + +my $SERVER; +my $CONFIG_SERVER; + +my %childstatus = (); + +run_as_server(); +exit(0); + +sub _fork { + my $pid = fork; + if (!defined($pid)) { die "Cannot fork: $!" } + return $pid if $pid; + + # Fixup Net::DNS randomness after fork + srand($$ ^ time); + + local $^W; + delete $INC{'Net/DNS/Header.pm'}; + require Net::DNS::Header; + + # cope with different versions of Net::DNS + eval { + $Net::DNS::Resolver::global{id} = 1; + $Net::DNS::Resolver::global{id} = int(rand(Net::DNS::Resolver::MAX_ID())); + # print "Next DNS ID: $Net::DNS::Resolver::global{id}\n"; + }; + if ($@) { + # print "Next DNS ID: " . Net::DNS::Header::nextid() . "\n"; + } + + # Fixup lost kqueue after fork + $Danga::Socket::HaveKQueue = undef; +} + +sub spawn_child { + my $plugin_loader = shift || Qpsmtpd::SMTP->new; + if (my $pid = _fork) { + return $pid; + } + + $SIG{HUP} = $SIG{CHLD} = $SIG{INT} = $SIG{TERM} = 'DEFAULT'; + $SIG{PIPE} = 'IGNORE'; + + Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler); + + $plugin_loader->run_hooks('post-fork'); + + Qpsmtpd::PollServer->EventLoop(); + exit; +} + +sub sig_chld { + my $spawn_count = 0; + while ( (my $child = waitpid(-1,WNOHANG)) > 0) { + if (!defined $childstatus{$child}) { + next; + } + + last unless $child > 0; + print "SIGCHLD: child $child died\n"; + delete $childstatus{$child}; + $spawn_count++; + } + if ($spawn_count) { + for (1..$spawn_count) { + # restart a new child if in poll server mode + my $pid = spawn_child(); + $childstatus{$pid} = 1; + } + } + $SIG{CHLD} = \&sig_chld; +} + +sub HUNTSMAN { + $SIG{CHLD} = 'DEFAULT'; + kill 'INT' => keys %childstatus; + exit(0); +} + +sub run_as_server { + # establish SERVER socket, bind and listen. + $SERVER = IO::Socket::INET->new(LocalPort => $PORT, + LocalAddr => $LOCALADDR, + Type => SOCK_STREAM, + Proto => IPPROTO_TCP, + Blocking => 0, + Reuse => 1, + Listen => SOMAXCONN ) + or die "Error creating server $LOCALADDR:$PORT : $@\n"; + + IO::Handle::blocking($SERVER, 0); + binmode($SERVER, ':raw'); + + $CONFIG_SERVER = IO::Socket::INET->new(LocalPort => $CONFIG_PORT, + LocalAddr => $CONFIG_LOCALADDR, + Type => SOCK_STREAM, + Proto => IPPROTO_TCP, + Blocking => 0, + Reuse => 1, + Listen => 1 ) + or die "Error creating server $CONFIG_LOCALADDR:$CONFIG_PORT : $@\n"; + + IO::Handle::blocking($CONFIG_SERVER, 0); + binmode($CONFIG_SERVER, ':raw'); + + # Drop priviledges + my (undef, undef, $quid, $qgid) = getpwnam $USER or + die "unable to determine uid/gid for $USER\n"; + $) = ""; + POSIX::setgid($qgid) or + die "unable to change gid: $!\n"; + POSIX::setuid($quid) or + die "unable to change uid: $!\n"; + $> = $quid; + + # Load plugins here + my $plugin_loader = Qpsmtpd::SMTP->new(); + $plugin_loader->load_plugins; + + $plugin_loader->log(LOGINFO, 'Running as user '. + (getpwuid($>) || $>) . + ', group '. + (getgrgid($)) || $))); + + $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; + + if ($PROCS > 1) { + for (1..$PROCS) { + my $pid = spawn_child($plugin_loader); + $childstatus{$pid} = 1; + } + $plugin_loader->log(LOGDEBUG, "Listening on $PORT with $PROCS children $POLL"); + $SIG{'CHLD'} = \&sig_chld; + sleep while (1); + } + else { + $plugin_loader->log(LOGDEBUG, "Listening on $PORT with single process $POLL"); + Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler, + fileno($CONFIG_SERVER) => \&config_handler, + ); + $plugin_loader->run_hooks('post-fork'); + while (1) { + Qpsmtpd::PollServer->EventLoop(); + } + exit; + } + +} + +sub config_handler { + my $csock = $CONFIG_SERVER->accept(); + if (!$csock) { + # warn("accept failed on config server: $!"); + return; + } + binmode($csock, ':raw'); + + printf("Config server connection\n") if $DEBUG; + + IO::Handle::blocking($csock, 0); + setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; + + my $client = Qpsmtpd::ConfigServer->new($csock); + $client->watch_read(1); + return; +} + +# Accept all new connections +sub accept_handler { + for (1 .. $NUMACCEPT) { + return unless _accept_handler(); + } + + # got here because we have accept's left. + # So double the number we accept next time. + $NUMACCEPT *= 2; + $NUMACCEPT = ACCEPT_MAX if $NUMACCEPT > ACCEPT_MAX; + $ACCEPT_RSET->cancel; + $ACCEPT_RSET = Danga::Socket->AddTimer(30, \&reset_num_accept); +} + +use Errno qw(EAGAIN EWOULDBLOCK); + +sub _accept_handler { + my $csock = $SERVER->accept(); + if (!$csock) { + # warn("accept() failed: $!"); + return; + } + binmode($csock, ':raw'); + + printf("Listen child making a Qpsmtpd::PollServer for %d.\n", fileno($csock)) + if $DEBUG; + + IO::Handle::blocking($csock, 0); + #setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; + + my $client = Qpsmtpd::PollServer->new($csock); + + if ($PAUSED) { + $client->write("451 Sorry, this server is currently paused\r\n"); + $client->close; + return 1; + } + + $client->push_back_read("Connect\n"); + $client->watch_read(1); + return 1; +} + +######################################################################## + +sub log { + my ($level,$message) = @_; + # $level not used yet. this is reimplemented from elsewhere anyway + warn("$$ fd:? $message\n"); +} + +sub pause { + my ($pause) = @_; + $PAUSED = $pause; +} diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 6593a56..6504367 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -7,75 +7,92 @@ # use lib 'lib'; +use Qpsmtpd::TcpServer; use Qpsmtpd::Constants; use IO::Socket; use IO::Select; -use Qpsmtpd::PollServer; use Socket; use Getopt::Long; use POSIX qw(:sys_wait_h :errno_h :signal_h); +use Net::DNS::Header; use strict; $| = 1; +my $has_ipv6 = Qpsmtpd::Constants::has_ipv6; + +if ($has_ipv6) { + eval 'use Socket6'; +} + # Configuration my $MAXCONN = 15; # max simultaneous connections -my $PORT = 2525; # port number +my @PORT; # port number(s) my @LOCALADDR; # ip address(es) to bind to my $USER = 'smtpd'; # user to suid to my $MAXCONNIP = 5; # max simultaneous connections from one IP -my $PID_FILE = ''; # file to which server PID will be written +my $PID_FILE = ''; my $DETACH; # daemonize on startup -our $DEBUG = 0; sub usage { print <<"EOT"; usage: qpsmtpd-forkserver [ options ] -l, --listen-address addr : listen on specific address(es); can be specified multiple times for multiple bindings. Default is - 0.0.0.0 (all interfaces). - -p, --port P : listen on a specific port; default 2525 + 0.0.0.0 (all interfaces). + -p, --port P : listen on a specific port; default 2525; can be + specified multiple times for multiple bindings. -c, --limit-connections N : limit concurrent connections to N; default 15 -u, --user U : run as a particular user (default 'smtpd') -m, --max-from-ip M : limit connections from a single IP; default 5 --pid-file P : print main servers PID to file P - -h, --help : this page - --use-poll : force use of poll() instead of epoll()/kqueue() -d, --detach : detach from controlling terminal (daemonize) EOT exit 0; } -GetOptions('l|listen-address=s' => \@LOCALADDR, - 'c|limit-connections=i' => \$MAXCONN, - 'm|max-from-ip=i' => \$MAXCONNIP, - 'p|port=i' => \$PORT, - 'u|user=s' => \$USER, - 'pid-file=s' => \$PID_FILE, - 'debug+' => \$DEBUG, - 'use-poll' => \&force_poll, - 'h|help' => \&usage, - 'd|detach' => \$DETACH, - ) || &usage; - -sub force_poll { - $Danga::Socket::HaveEpoll = 0; - $Danga::Socket::HaveKQueue = 0; -} +GetOptions('h|help' => \&usage, + 'l|listen-address=s' => \@LOCALADDR, + 'c|limit-connections=i' => \$MAXCONN, + 'm|max-from-ip=i' => \$MAXCONNIP, + 'p|port=s' => \@PORT, + 'u|user=s' => \$USER, + 'pid-file=s' => \$PID_FILE, + 'd|detach' => \$DETACH, + ) || &usage; # detaint the commandline -if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &usage } -@LOCALADDR = ( '0.0.0.0' ) if !@LOCALADDR; +if ($has_ipv6) { + @LOCALADDR = ( '[::]' ) if !@LOCALADDR; +} +else { + @LOCALADDR = ( '0.0.0.0' ) if !@LOCALADDR; +} +@PORT = ( 2525 ) if !@PORT; + +my @LISTENADDR; for (0..$#LOCALADDR) { - if ($LOCALADDR[$_] =~ /^([\d\w\-.]+)$/) { - $LOCALADDR[$_] = $1; + if ($LOCALADDR[$_] =~ /^(\[.*\]|[\d\w\-.]+)(?::(\d+))?$/) { + if ( defined $2 ) { + push @LISTENADDR, { 'addr' => $1, 'port' => $2 }; + } else { + my $addr = $1; + for (0..$#PORT) { + if ( $PORT[$_] =~ /^(\d+)$/ ) { + push @LISTENADDR, { 'addr' => $addr, 'port' => $1 }; + } else { + &usage; + } + } + } } else { &usage; } } + if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &usage } if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &usage } -delete @ENV{'ENV','CDPATH','IFS','BASH_ENV'}; +delete $ENV{ENV}; $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin'; my %childstatus = (); @@ -101,16 +118,24 @@ $SIG{INT} = \&HUNTSMAN; $SIG{TERM} = \&HUNTSMAN; my $select = new IO::Select; +my $server; # establish SERVER socket(s), bind and listen. -for my $listen_addr (@LOCALADDR) { - my $server = IO::Socket::INET->new(LocalPort => $PORT, - LocalAddr => $listen_addr, +for my $listen_addr (@LISTENADDR) { + my @Socket_opts = (LocalPort => $listen_addr->{'port'}, + LocalAddr => $listen_addr->{'addr'}, Proto => 'tcp', Reuse => 1, Blocking => 0, - Listen => SOMAXCONN ) - or die "Creating TCP socket $listen_addr:$PORT: $!\n"; + Listen => SOMAXCONN); + if ($has_ipv6) { + $server = IO::Socket::INET6->new(@Socket_opts) + or die "Creating TCP socket $listen_addr->{'addr'}:$listen_addr->{'port'}: $!\n"; + } + else { + $server = IO::Socket::INET->new(@Socket_opts) + or die "Creating TCP socket $listen_addr->{'addr'}:$listen_addr->{'port'}: $!\n"; + } IO::Handle::blocking($server, 0); $select->add($server); } @@ -138,7 +163,7 @@ if ($PID_FILE) { } # Load plugins here -my $qpsmtpd = bless {},'Qpsmtpd'; # ugh - probably should have new() in Qpsmtpd.pm +my $qpsmtpd = Qpsmtpd::TcpServer->new(); # Drop privileges my (undef, undef, $quid, $qgid) = getpwnam $USER or @@ -147,7 +172,7 @@ my $groups = "$qgid $qgid"; while (my ($name,$passwd,$gid,$members) = getgrent()) { my @m = split(/ /, $members); if (grep {$_ eq $USER} @m) { - $groups .= " $gid"; + $groups .= " $gid"; } } $) = $groups; @@ -159,11 +184,13 @@ $> = $quid; $qpsmtpd->load_plugins; -::log(LOGINFO,"Listening on port $PORT"); +foreach my $listen_addr ( @LISTENADDR ) { + ::log(LOGINFO,"Listening on $listen_addr->{'addr'}:$listen_addr->{'port'}"); +} ::log(LOGINFO, 'Running as user '. - (getpwuid($>) || $>) . - ', group '. - (getgrgid($)) || $))); + (getpwuid($>) || $>) . + ', group '. + (getgrgid($)) || $))); if ($DETACH) { open STDIN, '/dev/null' or die "/dev/null: $!"; @@ -200,32 +227,46 @@ while (1) { # possible something condition... next; } - # Make this client blocking while we figure out if we actually want to - # do something with it. IO::Handle::blocking($client, 1); - my ($port, $iaddr) = sockaddr_in($hisaddr); - if ($MAXCONNIP) { - my $num_conn = 1; # seed with current value - - foreach my $rip (values %childstatus) { - ++$num_conn if (defined $rip && $rip eq $iaddr); + my ($port, $iaddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($hisaddr)) : (sockaddr_in6($hisaddr)); + my $localsockaddr = getsockname($client); + my ($lport, $laddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($localsockaddr)) : (sockaddr_in6($localsockaddr)); + my $nto_iaddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($iaddr)) : (inet_ntop(AF_INET6(), $iaddr)); + my $ton_iaddr = ($server->sockdomain == AF_INET) ? (inet_aton($iaddr)) : (inet_pton(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://; + + my ($rc, @msg) = $qpsmtpd->run_hooks("pre-connection", + remote_ip => $nto_iaddr, + remote_port => $port, + local_ip => $nto_laddr, + local_port => $lport, + max_conn_ip => $MAXCONNIP, + child_addrs => [values %childstatus], + ); + if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { + unless ($msg[0]) { + @msg = ("Sorry, try again later"); } - - if ($num_conn > $MAXCONNIP) { - my $rem_ip = inet_ntoa($iaddr); - ::log(LOGINFO,"Too many connections from $rem_ip: " - ."$num_conn > $MAXCONNIP. Denying connection."); - $client->autoflush(1); - print $client "451 Sorry, too many connections from $rem_ip, try again later\r\n"; - close $client; - next; + &respond_client($client, 451, @msg); + close $client; + next; + } + elsif ($rc == DENY || $rc == DENY_DISCONNECT) { + unless ($msg[0]) { + @msg = ("Sorry, service not available for you"); } + &respond_client($client, 550, @msg); + close $client; + next; } + my $pid = safe_fork(); if ($pid) { # parent - $childstatus{$pid} = $iaddr; # add to table - # $childstatus{$pid} = 1; # add to table + $childstatus{$pid} = $iaddr; # add to table + # $childstatus{$pid} = 1; # add to table $running++; close($client); next; @@ -233,7 +274,10 @@ while (1) { # otherwise child # all children should have different seeds, to prevent conflicts - srand( time ^ ($$ + ($$ << 15)) ); + srand(); + for (0 .. rand(65536)) { + Net::DNS::Header::nextid(); + } close($server); @@ -243,35 +287,37 @@ while (1) { ::log(LOGINFO, "Connection Timed Out"); exit; }; - my $localsockaddr = getsockname($client); - my ($lport, $laddr) = sockaddr_in($localsockaddr); - $ENV{TCPLOCALIP} = inet_ntoa($laddr); + $ENV{TCPLOCALIP} = $nto_laddr; # my ($port, $iaddr) = sockaddr_in($hisaddr); - $ENV{TCPREMOTEIP} = inet_ntoa($iaddr); - $ENV{TCPREMOTEHOST} = gethostbyaddr($iaddr, AF_INET) || "Unknown"; - + $ENV{TCPREMOTEIP} = $nto_iaddr; + + if ($server->sockdomain == AF_INET) { + $ENV{TCPREMOTEHOST} = gethostbyaddr($iaddr, AF_INET) || "Unknown"; + } + else { + my ($family, $socktype, $proto, $saddr, $canonname, @res) = getaddrinfo($iaddr, $port, AF_UNSPEC); + $ENV{TCPREMOTEHOST} = $canonname || "Unknown"; + } + # don't do this! #$0 = "qpsmtpd-forkserver: $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}"; ::log(LOGINFO, "Accepted connection $running/$MAXCONN from $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}"); - $::LineMode = 1; + # dup to STDIN/STDOUT + POSIX::dup2(fileno($client), 0); + POSIX::dup2(fileno($client), 1); - # Make this client non-blocking so it works with the Danga framework - IO::Handle::blocking($client, 0); - my $qp = Qpsmtpd::PollServer->new($client); - $qp->load_plugins; - $qp->init_logger; - $qp->push_back_read("Connect\n"); - Qpsmtpd::PollServer->AddTimer(0.1, sub { }); - while (1) { - $qp->enable_read; - my $line = $qp->get_line; - last if !defined($line); - my $output = $qp->process_line($line); - $qp->write($output) if $output; - } + $qpsmtpd->start_connection + ( + local_ip => $ENV{TCPLOCALIP}, + local_port => $lport, + remote_ip => $ENV{TCPREMOTEIP}, + remote_port => $port, + ); + $qpsmtpd->run(); + $qpsmtpd->run_hooks("post-connection"); exit; # child leaves } } @@ -281,6 +327,18 @@ sub log { $qpsmtpd->log($level,$message); } +sub respond_client { + my ($client, $code, @message) = @_; + $client->autoflush(1); + while (my $msg = shift @message) { + my $line = $code . (@message?"-":" ").$msg; + ::log(LOGDEBUG, $line); + print $client "$line\r\n" + or (::log(LOGERROR, "Could not print [$line]: $!"), return 0); + } + return 1; +} + ### routine to protect process during fork sub safe_fork { diff --git a/qpsmtpd-prefork b/qpsmtpd-prefork new file mode 100755 index 0000000..2874054 --- /dev/null +++ b/qpsmtpd-prefork @@ -0,0 +1,601 @@ +#!/usr/bin/perl -Tw +# High performance pre-forking qpsmtpd daemon, Copyright (C) 2006 SoftScan +# http://www.softscan.co.uk +# +# Based on qpsmtpd-forkserver Copyright (C) 2001 Ask Bjoern Hansen +# See the LICENSE file for details. +# +# For more information see http://develooper.com/code/qpsmtpd/ + +# safety guards +use strict; + +# includes +use IO::Socket; +use POSIX; +use IPC::Shareable(':all'); +use lib 'lib'; +use Qpsmtpd::TcpServer::Prefork; +use Qpsmtpd::Constants; +use Getopt::Long; + +#use Time::HiRes qw(gettimeofday tv_interval); + +# secure shell +$ENV{'PATH'} = '/bin:/usr/bin'; +delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; + +# version +my $VERSION = "1.0"; + +# qpsmtpd instance +my $qpsmtpd; + +# cmd's needed by IPC +my $ipcrm = '/usr/bin/ipcrm'; +my $ipcs = '/usr/bin/ipcs'; +my $xargs = '/usr/bin/xargs'; + +# vars we need +my $chld_shmem; # shared mem to keep track of children (and their connections) +my %children; +my $chld_pool; +my $chld_busy; +my $d; # socket + +# default settings +my $pid_path = '/var/run/qpsmtpd/'; +my $PID = $pid_path . "/qpsmtpd.pid"; +my $d_port = 25; +my $d_addr = "0.0.0.0"; +my $debug = 0; +my $max_children = 15; # max number of child processes to spawn +my $idle_children = 5; # number of idle child processes to spawn +my $maxconnip = 10; +my $child_lifetime = 100; # number of times a child may be reused +my $loop_sleep = 30; # seconds main_loop sleeps before checking children +my $re_nice = 5; # substracted from parents current nice level +my $d_start = 0; +my $quiet = 0; +my $status = 0; +my $signal = ''; +my $pretty = 0; +my $user; + +# help text +sub usage { + print <<"EOT"; +Usage: qpsmtpd-prefork [ options ] +--quiet : Be quiet (even errors are suppressed) +--version : Show version information +--debug : Enable debug output +--interface addr : Interface daemon should listen on (default: $d_addr) +--port int : TCP port daemon should listen on (default: $d_port) +--max-from-ip int : Limit number of connections from single IP (default: $maxconnip, 0 to disable) +--children int : Max number of children that can be spawned (default: $max_children) +--idle-children int : Number of idle children to spawn (default: $idle_children, 0 to disable) +--pretty-child : Change child process name (default: 0) +--user username : User the daemon should run as +--pid-file path : Path to pid file +--renice-parent int : Subtract value from parent process nice level (default: $re_nice) +--help : This message +EOT + exit 0; +} + +# get arguments +GetOptions( + 'quiet' => \$quiet, + 'version' => sub { print "Qpsmtpd Daemon - version $VERSION\n"; exit 0; }, + 'debug' => \$debug, + 'interface=s' => \$d_addr, + 'port=i' => \$d_port, + 'max-from-ip=i' => \$maxconnip, + 'children=i' => \$max_children, + 'idle-children=i' => \$idle_children, + 'pretty-child' => \$pretty, + 'user=s' => \$user, + 'renice-parent=i' => \$re_nice, + 'help' => \&usage, + ) || &usage; + +$user = $1 if ($user =~ /(\w+)/); + +# set max from ip to max number of children if option is set to disabled +$maxconnip = $max_children if ($maxconnip == 0); + +#to fix limit counter error in plugin +$maxconnip++; + +#ensure that idle_children matches value given to max_children +$idle_children = $max_children + if (!$idle_children || $idle_children > $max_children || $idle_children < -1); +$chld_pool = $idle_children; + +run(); + +#start daemon +sub run { + # get UUID/GUID + my ($uuid, $ugid, $group); + if ($user) { + my $T_uuid = `id -u $user`; + my $T_ugid = `id -g $user`; + my $T_group = `id -n -g $user`; + chomp($T_uuid); + chomp($T_ugid); + chomp($T_group); + + # make the following vars taint happy + $uuid = $1 if ($T_uuid =~ /(\d+)/); + $ugid = $1 if ($T_ugid =~ /(\d+)/); + $group = $1 if ($T_group =~ /(\w+)/); + die("FATAL: unknown user <$user> or missing group information") + if (!$uuid || !$ugid); + } + + # create new socket (used by clients to communicate with daemon) + $d = + new IO::Socket::INET( + LocalPort => $d_port, + LocalAddr => $d_addr, + Proto => 'tcp', + Listen => SOMAXCONN, + Reuse => 1, + ); + die "FATAL: Failed to start daemon.\nReason: $!\n(It may be nessesary to " + . "wait 20 secs before starting daemon again)\n" + unless $d; + + info("qpsmtpd-prefork daemon, version: $VERSION, staring on host: " . + "$d_addr, port: $d_port (user: $user [$<])"); + + # reset priority + my $old_nice = getpriority(0, 0); + my $new_nice = $old_nice - $re_nice; + if ($new_nice < 20 && $new_nice > -20) { + setpriority(0, 0, $1) if ($new_nice =~ /(\-?\d+)/); + info("parent daemon nice level: $1"); + } + else { + die "FATAL: new nice level: $new_nice is not between -19 and 19 " + . "(old level = $old_nice, renice value = $re_nice)"; + } + + if ($user) { + # change UUID/UGID + $) = "$ugid $ugid"; # effective gid + $( = $ugid; # real gid + $> = $uuid; # effective uid + $< = $uuid; # real uid. we now cannot setuid anymore + die "FATAL: failed to setuid to user: $user, uid: $uuid\n" + if ($> != $uuid and $> != ($uuid - 2**32)); + } + + # setup shared memory + $chld_shmem = shmem("qpsmtpd", 1); + untie $chld_shmem; + + # Interrupt handler + $SIG{INT} = $SIG{TERM} = sub { + # terminate daemon (and children) + my $sig = shift; + + # prevent another signal and disable reaper + $SIG{$sig} = $SIG{CHLD} = $SIG{HUP} = 'IGNORE'; + unlink("$PID"); + + # close socket + $d->close(); + my $cnt = kill 'INT' => keys %children; + + # cleanup shared memory + IPC::Shareable->clean_up; + info("shutdown of daemon (and $cnt children)"); + exit; + }; + + # Hup handler + $SIG{HUP} = sub { + # reload qpmstpd plugins + $qpsmtpd->load_plugins; + kill 'HUP' => keys %children; + info("reload daemon requested"); + }; + + # setup qpsmtpd_instance + $qpsmtpd = qpmsptd_instance(); + + # child reaper + $SIG{CHLD} = \&reaper; + spawn_children(); + main_loop(); + exit; +} + +# initialize children (only done at daemon startup) +sub spawn_children { + # block signals while new children are being spawned + my $sigset = block_signal(SIGCHLD); + for (1 .. $chld_pool) { + new_child(); + } + + # reset block signals + unblock_signal($sigset); +} + +# cleanup after child dies +sub reaper { + my $stiff; + my @stiffs; + while (($stiff = waitpid(-1, &WNOHANG)) > 0) { + my $res = WEXITSTATUS($?); + info("child terminated, pid: $stiff (status $?, res: $res)"); + delete $children{$stiff}; # delete pid from children + # add pid to array so it later can be removed from shared memory + push @stiffs, $stiff; + } + + # remove connection info from shared memory and get number + # of busy children (use by main_loop) + $chld_busy = shmem_opt(undef, \@stiffs, undef, undef); + $SIG{CHLD} = \&reaper; +} + +#main_loop: main loop (spawn new children) +#arg0: void +#ret0: void +sub main_loop { + while (1) { + # sleep EXPR seconds or until signal (i.e. child death) is received + my $sleept = sleep $loop_sleep; + + # block CHLD signals to avoid race, anyway does it matter? + my $sigset = block_signal(SIGCHLD); + + # get number of busy children, if sleep wasn't interrupted by signal + $chld_busy = shmem_opt(undef, undef, undef, undef, 1) + if ($sleept == $loop_sleep); + + # calculate children in pool (if valid busy children number) + if (defined($chld_busy)) { + info("busy children: $chld_busy"); + $chld_pool = $chld_busy + $idle_children; + } + + # ensure pool limit is max_children + $chld_pool = $max_children if ($chld_pool > $max_children); + + # spawn children + for (my $i = scalar(keys %children) ; $i < $chld_pool ; $i++) { + new_child(); # add to the child pool + } + info( "children pool: $chld_pool (currently spawned: " + . scalar(keys %children) + . ")"); + + # unblock signals + unblock_signal($sigset); + } +} + +# block_signal: block signals +# arg0..n: int with signal(s) to block +# ret0: ref str with sigset (used to later unblock signal) +sub block_signal { + my @signal = @_; #arg0..n + + my ($sigset, $blockset); + + $sigset = POSIX::SigSet->new(); + $blockset = POSIX::SigSet->new(@signal); + sigprocmask(SIG_BLOCK, $blockset, $sigset) + or die "Could not block @signal signals: $!\n"; + + return ($sigset); +} + +# unblock_signal: unblock/reset and receive pending signals +# arg0: ref str with sigset +# ret0: void +sub unblock_signal { + my $sigset = shift; # arg0 + sigprocmask(SIG_SETMASK, $sigset) + or die "Could not restore signals: $!\n"; +} + +# new_child: initialize new child +# arg0: void +# ret0: void +sub new_child { + # daemonize away from the parent process + my $pid; + die "Cannot fork child: $!\n" unless defined($pid = fork); + if ($pid) { + # in parent + $children{$pid} = 1; + info("new child, pid: $pid"); + return; + } + + # in child + + # reset priority + setpriority 0, 0, getpriority(0, 0) + $re_nice; + + # reset signals + my $sigset = POSIX::SigSet->new(); + my $blockset = POSIX::SigSet->new(SIGCHLD); + sigprocmask(SIG_UNBLOCK, $blockset, $sigset) + or die "Could not unblock SIGHUP signal: $!\n"; + $SIG{CHLD} = $SIG{INT} = $SIG{TERM} = $SIG{ALRM} = 'DEFAULT'; + + # child should exit if it receives HUP signal (note: blocked while child + # is busy, but restored once done) + $SIG{HUP} = sub { + info("signal HUP received, going to exit"); + exit 1; + }; + + # continue to accept connections until "old age" is reached + for (my $i = 0 ; $i < $child_lifetime ; $i++) { + # accept a connection + if ( $pretty ) { + $ENV{PROCESS} = $0 if not defined $ENV{PROCESS}; # 1st time only + $0 = 'qpsmtpd child'; # set pretty child name in process listing + } + my ($client, $iinfo) = $d->accept() + or die + "failed to create new object - $!"; # wait here until client connects + info("connect from: " . $client->peerhost . ":" . $client->peerport); + + # set STDIN/STDOUT and autoflush + POSIX::dup2(fileno($client), 0) + || die "unable to duplicate filehandle to STDIN - $!"; + POSIX::dup2(fileno($client), 1) + || die "unable to duplicate filehandle to STDOUT - $!"; + $| = 1; + + # connection recieved, block signals + my $sigset = block_signal(SIGHUP); + + # start a session if connection looks valid + qpsmtpd_session($client, $qpsmtpd) if ($iinfo); + + # close connection and cleanup + $client->shutdown(2); + + # unset block and receive pending signals + unblock_signal($sigset); + } + exit; # this child has reached its end-of-life +} + +# respond to client +# arg0: ref to socket object (client) +# arg1: int with SMTP reply code +# arg2: arr with message +# ret0: int 0|1 (0 = failure, 1 = success) +sub respond_client { + my ($client, $code, @message) = @_; + $client->autoflush(1); + while (my $msg = shift @message) { + my $line = $code . (@message ? "-" : " ") . $msg; + info("reply to client: <$line>"); + print $client "$line\r\n" + or (info("Could not print [$line]: $!"), return 0); + } + return 1; +} + +# qpsmtpd_instance: setup qpsmtpd instance +# arg0: void +# ret0: ref to qpsmtpd_instance +sub qpmsptd_instance { + my $qpsmtpd = Qpsmtpd::TcpServer::Prefork->new(); + $qpsmtpd->load_plugins; + $qpsmtpd->spool_dir; + $qpsmtpd->size_threshold; + + return ($qpsmtpd); +} + +# shmem: tie to shared memory hash +# arg0: str with glue +# arg1: int 0|1 (0 = don't create shmem, 1 = create shmem) +# ret0: ref to shared hash +sub shmem { + my $glue = shift; #arg0 + my $create = shift || 0; #arg1 + + my %options = ( + create => $create, + exclusive => 0, + mode => 0640, + destroy => 0, + ); + + my %shmem_hash; + eval { + tie %shmem_hash, 'IPC::Shareable', $glue, {%options} + || die "unable to tie to shared memory - $!"; + }; + if ($@) { + info("$@"); + return; + } + + return (\%shmem_hash); +} + +# shmem_opt: connect to shared memory and perform options +# arg0: ref to hash where shared memory should be copied to +# arg1: ref to arr with pid(s) to delete +# arg2: int with pid to add (key) +# arg3: str with packed iaddr to add (value) +# arg4: int 0|1 check and cleanup shared memory (0 = no, 1 = yes - default 0) +# ret0: int with number of busy children (undef if error) +sub shmem_opt { + my $ref_shmem = shift; #arg0 + my $ref_pid_del = shift; #arg1 + my $pid_add_key = shift; #arg2 + my $pid_add_value = shift; #arg3 + my $check = shift || 0; #arg4 + + # check arguments + if ( (defined($pid_add_key) && !defined($pid_add_value)) + || (!defined($pid_add_key) && defined($pid_add_value))) + { + return; + } + + my ($chld_shmem, $chld_busy); + eval { + $chld_shmem = &shmem("qpsmtpd", 0); #connect to shared memory hash + + if (tied %{$chld_shmem}) { + # perform options + (tied %{$chld_shmem})->shlock(LOCK_EX); + + # delete + if ($ref_pid_del) { + foreach my $pid_del (@{$ref_pid_del}) { + delete $$chld_shmem{$pid_del}; + } + } + # add + $$chld_shmem{$pid_add_key} = $pid_add_value if ($pid_add_key); + # copy + %{$ref_shmem} = %{$chld_shmem} if ($ref_shmem); + if ($check) { + # loop through pid list and delete orphaned processes + foreach my $pid (keys %{$chld_shmem}) { + if (!kill 0, $pid) { + delete $$chld_shmem{$pid}; + warn("orphaned child, pid: $pid removed from memory"); + } + } + } + + # count number of busy children + $chld_busy = scalar(keys %{$chld_shmem}); + (tied %{$chld_shmem})->shunlock; + + # untie from shared memory + untie $chld_shmem || die "unable to untie from shared memory"; + } + }; + + # check for error + if ($@) { + undef($chld_busy); + warn("$@"); + } + + return ($chld_busy); +} + +# info: write info +# arg0: str with debug text +sub info { + my $text = shift; #arg0 + return if (!$debug); + + my ($sec, $min, $hour, $mday, $mon, $year) = localtime(time); + my $nowtime = sprintf "%02d/%02d/%02d %02d:%02d:%02d", $mday, $mon + 1, + $year + 1900, $hour, $min, $sec; + + chomp($text); + print STDERR "$nowtime:$$: $text\n"; +} + +# start qpmstpd session +# arg0: ref to socket object +# arg1: ref to qpsmtpd instance +# ret0: void +sub qpsmtpd_session { + my $client = shift; #arg0 + my $qpsmtpd = shift; #arg1 + + # get local/remote hostname, port and ip address + my ($port, $iaddr) = sockaddr_in(getpeername($client)); #remote + my ($lport, $laddr) = sockaddr_in(getsockname($client)); #local + + # get current connected ip addresses (from shared memory) + my %children; + shmem_opt(\%children, undef, $$, $iaddr); + + my ($rc, @msg) = + $qpsmtpd->run_hooks( + "pre-connection", + remote_ip => inet_ntoa($iaddr), + remote_port => $port, + local_ip => inet_ntoa($laddr), + local_port => $lport, + max_conn_ip => $maxconnip, + child_addrs => [values %children], + ); + if ( $rc == DENYSOFT + || $rc == DENYSOFT_DISCONNECT + || $rc == DENY + || $rc == DENY_DISCONNECT) + { + #smtp return code to reply client with (seed with soft deny) + my $rc_reply = 451; + unless ($msg[0]) { + if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { + @msg = ("Sorry, try again later"); + } + else { + @msg = ("Sorry, service not available to you"); + $rc_reply = 550; + } + } + respond_client($client, $rc_reply, @msg); + + # remove pid from shared memory + shmem_opt(undef, [$$], undef, undef); + + # retur so child can be reused + return; + } + + # all children should have different seeds, to prevent conflicts + srand(time ^ ($$ + ($$ << 15))); + + # ALRM handler + $SIG{ALRM} = sub { + print $client "421 Connection Timed Out\n"; + info("Connection Timed Out"); + + # kill the child + exit 1; + }; + + # set enviroment variables + $ENV{TCPLOCALIP} = inet_ntoa($laddr); + $ENV{TCPREMOTEIP} = inet_ntoa($iaddr); + $ENV{TCPREMOTEHOST} = gethostbyaddr($iaddr, AF_INET) || "Unknown"; + + # run qpmsptd functions + $SIG{__DIE__} = 'DEFAULT'; + eval { + $qpsmtpd->start_connection( + local_ip => $ENV{TCPLOCALIP}, + local_port => $lport, + remote_ip => $ENV{TCPREMOTEIP}, + remote_port => $client->peerport, + ); + $qpsmtpd->run(); + $qpsmtpd->run_hooks("post-connection"); + }; + if ($@ !~ /^(disconnect_tcpserver|died while reading from STDIN)/) { + warn("$@"); + } + + # child is now idle again so remove it's pid from shared mem + shmem_opt(undef, [$$], undef, undef); + + info("remote host: $ENV{TCPREMOTEIP} left..."); +} diff --git a/qpsmtpd-server b/qpsmtpd-server new file mode 100755 index 0000000..248c472 --- /dev/null +++ b/qpsmtpd-server @@ -0,0 +1,28 @@ +#!/usr/bin/perl -Tw +# Copyright (c) 2001 Ask Bjoern Hansen. See the LICENSE file for details. +# The "command dispatch" system is taken from colobus - http://trainedmonkey.com/colobus/ +# +# this is designed to be run under tcpserver (http://cr.yp.to/ucspi-tcp.html) +# or inetd if you're into that sort of thing +# +# +# For more information see http://develooper.com/code/qpsmtpd/ +# +# + +use lib 'lib'; +use Qpsmtpd::SelectServer; +use strict; +$| = 1; + +delete $ENV{ENV}; +$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin'; + +Qpsmtpd::SelectServer->main(); + +__END__ + + + + +1; diff --git a/t/Test/Qpsmtpd.pm b/t/Test/Qpsmtpd.pm index b547d58..80ab6ce 100644 --- a/t/Test/Qpsmtpd.pm +++ b/t/Test/Qpsmtpd.pm @@ -70,8 +70,8 @@ sub config_dir { './config.sample'; } -sub plugin_dir { - './plugins'; +sub plugin_dirs { + ('./plugins'); } sub log { diff --git a/t/addresses.t b/t/addresses.t index 2e261d0..9ce2daa 100644 --- a/t/addresses.t +++ b/t/addresses.t @@ -27,4 +27,11 @@ $command = 'MAIL FROM: SIZE=1230'; is(($smtpd->command($command))[0], 250, $command); is($smtpd->transaction->sender->format, '', 'got the right sender'); +$command = 'MAIL FROM: SIZE=1230 CORRECT-WITHOUT-ARG'; +is(($smtpd->command($command))[0], 250, $command); + +$command = 'MAIL FROM:'; +is(($smtpd->command($command))[0], 250, $command); +is($smtpd->transaction->sender->format, '<>', 'got the right sender'); + diff --git a/t/qpsmtpd-address.t b/t/qpsmtpd-address.t index c08d44b..599a4af 100644 --- a/t/qpsmtpd-address.t +++ b/t/qpsmtpd-address.t @@ -2,7 +2,7 @@ use strict; $^W = 1; -use Test::More tests => 29; +use Test::More qw/no_plan/; BEGIN { use_ok('Qpsmtpd::Address'); @@ -101,3 +101,8 @@ my @test_list = sort @unsorted_list; is_deeply( \@test_list, \@sorted_list, "sort via overloaded 'cmp' operator"); +# RT#38746 - non-RFC compliant address should return undef + +$as=''; +$ao = Qpsmtpd::Address->new($as); +is ($ao, undef, "illegal $as");