From a1324b5ddb0f2c706184937f3dabb133b9ec8ade Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 7 Jul 2005 19:48:19 +0000 Subject: [PATCH 001/134] Version 0.31 branch git-svn-id: https://svn.perl.org/qpsmtpd/branches/v031@480 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Apache/Qpsmtpd.pm | 3 ++- lib/Qpsmtpd.pm | 36 +++++++++++++++++++++++++++++------- 2 files changed, 31 insertions(+), 8 deletions(-) diff --git a/lib/Apache/Qpsmtpd.pm b/lib/Apache/Qpsmtpd.pm index 5161301..6e0a6d9 100644 --- a/lib/Apache/Qpsmtpd.pm +++ b/lib/Apache/Qpsmtpd.pm @@ -16,6 +16,7 @@ use APR::Bucket (); use APR::Socket (); use Apache2::Filter (); use ModPerl::Util (); +use Apache::Scoreboard; our $VERSION = '0.02'; @@ -55,7 +56,7 @@ sub start_connection { my $remote_host = $opts{host} || ( $opts{ip} ? "[$opts{ip}]" : "[noip!]"); my $remote_info = $opts{info} ? "$opts{info}\@$remote_host" : $remote_host; my $remote_ip = $opts{ip}; - + $self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]"); $self->SUPER::connection->start( diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 382aea7..1afcafd 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -4,6 +4,8 @@ use vars qw($VERSION $Logger $TraceLevel $Spool_dir); use Sys::Hostname; use Qpsmtpd::Constants; +use Qpsmtpd::Transaction; +use Qpsmtpd::Connection; $VERSION = "0.31-dev"; @@ -114,17 +116,25 @@ sub config_dir { my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control'; my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); $configdir = "$name/config" if (-e "$name/config/$config"); + if (exists $ENV{QPSMTPD_CONFIG}) { + $configdir = $ENV{QPSMTPD_CONFIG} if (-e "$ENV{QPSMTPD_CONFIG}/$config"); + } return $configdir; } sub plugin_dir { - my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); - my $dir = "$name/plugins"; + my $self = shift; + my $plugin_dir = $self->config('plugin_dir', "NOLOG"); + unless (defined($plugin_dir)) { + my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); + $plugin_dir = "$name/plugins"; + } + return $plugin_dir; } sub get_qmail_config { my ($self, $config, $type) = @_; - $self->log(LOGDEBUG, "trying to get config for $config"); + $self->log(LOGDEBUG, "trying to get config for $config") unless $type and $type eq "NOLOG"; if ($self->{_config_cache}->{$config}) { return wantarray ? @{$self->{_config_cache}->{$config}} : $self->{_config_cache}->{$config}->[0]; } @@ -246,10 +256,6 @@ sub _load_plugins { return @ret; } -sub transaction { - return {}; # base class implements empty transaction -} - sub run_hooks { my ($self, $hook) = (shift, shift); my $hooks = $self->{hooks}; @@ -347,6 +353,22 @@ sub spool_dir { return $Spool_dir; } +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; + return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new()); +} + # For unique filenames. We write to a local tmp dir so we don't need # to make them unpredictable. my $transaction_counter = 0; From c78dad0a3b7d58cdbc776ea98975a75c7a7c0b91 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 7 Jul 2005 20:10:03 +0000 Subject: [PATCH 002/134] Revert to proper versions git-svn-id: https://svn.perl.org/qpsmtpd/branches/v031@481 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Apache/Qpsmtpd.pm | 3 +-- lib/Qpsmtpd.pm | 36 +++++++----------------------------- 2 files changed, 8 insertions(+), 31 deletions(-) diff --git a/lib/Apache/Qpsmtpd.pm b/lib/Apache/Qpsmtpd.pm index 6e0a6d9..5161301 100644 --- a/lib/Apache/Qpsmtpd.pm +++ b/lib/Apache/Qpsmtpd.pm @@ -16,7 +16,6 @@ use APR::Bucket (); use APR::Socket (); use Apache2::Filter (); use ModPerl::Util (); -use Apache::Scoreboard; our $VERSION = '0.02'; @@ -56,7 +55,7 @@ sub start_connection { my $remote_host = $opts{host} || ( $opts{ip} ? "[$opts{ip}]" : "[noip!]"); my $remote_info = $opts{info} ? "$opts{info}\@$remote_host" : $remote_host; my $remote_ip = $opts{ip}; - + $self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]"); $self->SUPER::connection->start( diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 1afcafd..382aea7 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -4,8 +4,6 @@ use vars qw($VERSION $Logger $TraceLevel $Spool_dir); use Sys::Hostname; use Qpsmtpd::Constants; -use Qpsmtpd::Transaction; -use Qpsmtpd::Connection; $VERSION = "0.31-dev"; @@ -116,25 +114,17 @@ sub config_dir { my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control'; my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); $configdir = "$name/config" if (-e "$name/config/$config"); - if (exists $ENV{QPSMTPD_CONFIG}) { - $configdir = $ENV{QPSMTPD_CONFIG} if (-e "$ENV{QPSMTPD_CONFIG}/$config"); - } return $configdir; } sub plugin_dir { - my $self = shift; - my $plugin_dir = $self->config('plugin_dir', "NOLOG"); - unless (defined($plugin_dir)) { - my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); - $plugin_dir = "$name/plugins"; - } - return $plugin_dir; + my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); + my $dir = "$name/plugins"; } sub get_qmail_config { my ($self, $config, $type) = @_; - $self->log(LOGDEBUG, "trying to get config for $config") unless $type and $type eq "NOLOG"; + $self->log(LOGDEBUG, "trying to get config for $config"); if ($self->{_config_cache}->{$config}) { return wantarray ? @{$self->{_config_cache}->{$config}} : $self->{_config_cache}->{$config}->[0]; } @@ -256,6 +246,10 @@ sub _load_plugins { return @ret; } +sub transaction { + return {}; # base class implements empty transaction +} + sub run_hooks { my ($self, $hook) = (shift, shift); my $hooks = $self->{hooks}; @@ -353,22 +347,6 @@ sub spool_dir { return $Spool_dir; } -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; - return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new()); -} - # For unique filenames. We write to a local tmp dir so we don't need # to make them unpredictable. my $transaction_counter = 0; From ae83f011ac810933f6a40cc996f6d94b73666bba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Thu, 7 Jul 2005 20:41:37 +0000 Subject: [PATCH 003/134] rename 0.31 branch git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@482 958fd67b-6ff1-0310-b445-bb7760255be9 From 8a3c3c40b09ce78592dd2973ce0f0b0e513c7ece Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 8 Jul 2005 16:50:24 +0000 Subject: [PATCH 004/134] tls support git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@489 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 1 + plugins/tls | 135 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 136 insertions(+) create mode 100644 plugins/tls diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index df6ac69..b352f9e 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -124,6 +124,7 @@ sub reset_transaction { sub connection { my $self = shift; + @_ and $self->{_connection} = shift; return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new()); } diff --git a/plugins/tls b/plugins/tls new file mode 100644 index 0000000..8406f76 --- /dev/null +++ b/plugins/tls @@ -0,0 +1,135 @@ +#!perl -w + +=head1 NAME + +tls - plugin to support STARTTLS + +=head1 SYNOPSIS + +# in config/plugins + + tls ssl/cert.pem ssl/privkey.pem + +=head1 DESCRIPTION + +This plugin implements basic TLS support. + +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. + +=cut + +use IO::Socket::SSL qw(debug1 debug2 debug3 debug4); + +sub init { + my ($self, $qp, $cert, $key) = @_; + $cert ||= 'ssl/cert.pem'; + $key ||= 'ssl/privkey.pem'; + $self->tls_cert($cert); + $self->tls_key($key); + + 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_server => 1 + ) or die "Could not create SSL context: $!"; + # now extract the password... + + $self->ssl_context($ssl_ctx); +} + +sub hook_ehlo { + my ($self, $transaction) = @_; + return DECLINED unless $self->can_do_tls; + 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; +} + +sub hook_unrecognized_command { + my ($self, $transaction, $cmd, @args) = @_; + return DECLINED unless $cmd eq 'starttls'; + return DECLINED unless $transaction->notes('tls_enabled'); + return DENY, "Syntax error (no parameters allowed)" if @args; + + # OK, now we setup TLS + $self->qp->respond (220, "Go ahead with TLS"); + + 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_cipher_list => 'HIGH', + SSL_server => 1, + SSL_reuse_ctx => $self->ssl_context, + ) or die "Could not create SSL socket: $!"; + + my $conn = $self->connection; + # Create a new connection object with subset of information collected thus far + $self->qp->connection(Qpsmtpd::Connection->new( + map { $_ => $conn->$_ } + qw( + local_ip + local_port + remote_ip + remote_port + remote_host + remote_info + ), + )); + $self->qp->reset_transaction; + *STDIN = *STDOUT = $self->connection->notes('tls_socket', $tlssocket); + $self->connection->notes('tls_enabled', 1); + }; + if ($@) { + # SSL setup failed. Now we must respond to every command with 5XX + warn("TLS failed: $@\n"); + $transaction->notes('ssl_failed', 1); + return DENY, "TLS Negotiation Failed"; + } + + warn("TLS setup returning\n"); + return DONE; +} + +sub can_do_tls { + my ($self) = @_; + $self->tls_cert && -r $self->tls_cert; +} + +sub tls_cert { + my $self = shift; + @_ and $self->{_tls_cert} = shift; + $self->{_tls_cert}; +} + +sub tls_key { + my $self = shift; + @_ and $self->{_tls_key} = shift; + $self->{_tls_key}; +} + +sub ssl_context { + my $self = shift; + @_ and $self->{_ssl_ctx} = shift; + $self->{_ssl_ctx}; +} + +# Fulfill RFC 2487 secn 5.1 +sub bad_ssl_hook { + my ($self, $transaction) = @_; + return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed'); +} +*hook_helo = *hook_data = *hook_rcpt = *hook_mail = *hook_auth = \&bad_ssl_hook; From 8c018d75ac735a22e04dca50d0816a4852116565 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 11 Jul 2005 12:24:26 +0000 Subject: [PATCH 005/134] Pass args to unrecognized_command git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@494 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index b352f9e..6af0251 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -51,7 +51,7 @@ sub dispatch { $self->{_counter}++; if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { - my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd); + my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd, @_); if ($rc == DENY_DISCONNECT) { $self->respond(521, $msg); $self->disconnect; From 11da7e2778da86298a60652ba53d63f77a982863 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 11 Jul 2005 16:00:03 +0000 Subject: [PATCH 006/134] Work around race condition (not fixed, but mostly fixed) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@495 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/queue/qmail-queue | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/plugins/queue/qmail-queue b/plugins/queue/qmail-queue index 6bc4a9d..9d592e6 100644 --- a/plugins/queue/qmail-queue +++ b/plugins/queue/qmail-queue @@ -39,12 +39,12 @@ sub hook_queue { my ($self, $transaction) = @_; # these bits inspired by Peter Samuels "qmail-queue wrapper" - pipe(MESSAGE_READER, MESSAGE_WRITER) or fault("Could not create message pipe"), exit; - pipe(ENVELOPE_READER, ENVELOPE_WRITER) or fault("Could not create envelope pipe"), exit; + pipe(MESSAGE_READER, MESSAGE_WRITER) or die("Could not create message pipe"); + pipe(ENVELOPE_READER, ENVELOPE_WRITER) or die("Could not create envelope pipe"); my $child = fork(); - not defined $child and fault(451, "Could not fork"), exit; + not defined $child and die("Could not fork"); if ($child) { # Parent @@ -52,9 +52,13 @@ sub hook_queue { select(ENVELOPE_WRITER); $| = 1; select($oldfh); - close MESSAGE_READER or fault("close msg reader fault"),exit; - close ENVELOPE_READER or fault("close envelope reader fault"), exit; + close MESSAGE_READER or die("close msg reader fault"); + close ENVELOPE_READER or die("close envelope reader fault"); + # Note - technically there's a race here because if the exec() below + # fails and the writes to MESSAGE_WRITER block we get a deadlocked process. + # This check to see if(eof(PIPE)) will catch "most" of these problems. + die "Message pipe has been closed" if eof(MESSAGE_WRITER); $transaction->header->print(\*MESSAGE_WRITER); $transaction->body_resetpos; while (my $line = $transaction->body_getline) { @@ -64,6 +68,7 @@ sub hook_queue { my @rcpt = map { "T" . $_->address } $transaction->recipients; my $from = "F".($transaction->sender->address|| "" ); + die "Envelope pipe has been closed" if eof(ENVELOPE_WRITER); print ENVELOPE_WRITER "$from\0", join("\0",@rcpt), "\0\0" or return(DECLINED,"Could not print addresses to queue"); @@ -104,6 +109,10 @@ sub hook_queue { my $rc = exec $queue_exec; + # close the pipe + close(MESSAGE_READER); + close(MESSAGE_WRITER); + exit 6; # we'll only get here if the exec fails } } From f0b31cbb9be44f8a9a9fcb9df8816b3cf6ddbfb5 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 12 Jul 2005 22:14:48 +0000 Subject: [PATCH 007/134] MERGE 498:499 FROM https://svn.perl.org/qpsmtpd/trunk Better fix for pipe being closed bug git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@500 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/queue/qmail-queue | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/plugins/queue/qmail-queue b/plugins/queue/qmail-queue index 9d592e6..b228c19 100644 --- a/plugins/queue/qmail-queue +++ b/plugins/queue/qmail-queue @@ -41,7 +41,8 @@ sub hook_queue { # these bits inspired by Peter Samuels "qmail-queue wrapper" pipe(MESSAGE_READER, MESSAGE_WRITER) or die("Could not create message pipe"); pipe(ENVELOPE_READER, ENVELOPE_WRITER) or die("Could not create envelope pipe"); - + + local $SIG{PIPE} = sub { die "SIGPIPE" }; my $child = fork(); not defined $child and die("Could not fork"); @@ -55,10 +56,6 @@ sub hook_queue { close MESSAGE_READER or die("close msg reader fault"); close ENVELOPE_READER or die("close envelope reader fault"); - # Note - technically there's a race here because if the exec() below - # fails and the writes to MESSAGE_WRITER block we get a deadlocked process. - # This check to see if(eof(PIPE)) will catch "most" of these problems. - die "Message pipe has been closed" if eof(MESSAGE_WRITER); $transaction->header->print(\*MESSAGE_WRITER); $transaction->body_resetpos; while (my $line = $transaction->body_getline) { @@ -68,7 +65,6 @@ sub hook_queue { my @rcpt = map { "T" . $_->address } $transaction->recipients; my $from = "F".($transaction->sender->address|| "" ); - die "Envelope pipe has been closed" if eof(ENVELOPE_WRITER); print ENVELOPE_WRITER "$from\0", join("\0",@rcpt), "\0\0" or return(DECLINED,"Could not print addresses to queue"); From 35f45f208b9ba243120c5323b437104169271c9f Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 14 Jul 2005 02:31:01 +0000 Subject: [PATCH 008/134] These changes to trunk were missed when 0.31 was branched. r588@jpeacock (orig r490): jpeacock | 2005-07-09 07:03:53 -0400 r547@jpeacock: jpeacock | 2005-07-02 07:20:17 -0400 Replace pithy comment with something more neutral. Thanks Gordon Rowell r548@jpeacock: jpeacock | 2005-07-02 07:24:21 -0400 Example patterns for badrcptto plugin - Gordon Rowell r586@jpeacock: jpeacock | 2005-07-09 06:54:47 -0400 Don't use varlog() directly unless you are passing all parameters. Don't try to log() anything during loading of logging plugins. r587@jpeacock: jpeacock | 2005-07-09 06:59:57 -0400 Cannot use new-style hooking with logging plugins (yet). r590@jpeacock (orig r491): jpeacock | 2005-07-10 06:56:55 -0400 r589@jpeacock: jpeacock | 2005-07-10 06:54:32 -0400 Track hooks as array and hash. Re-revert changes to logging plugins to use new-style hooking. logging/adaptive assumed that register() has been called before hook_logging. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@503 958fd67b-6ff1-0310-b445-bb7760255be9 --- config.sample/badrcptto_patterns | 5 +++++ lib/Qpsmtpd/Plugin.pm | 12 +++++++----- plugins/check_spamhelo | 2 +- plugins/logging/adaptive | 6 +++--- 4 files changed, 16 insertions(+), 9 deletions(-) create mode 100644 config.sample/badrcptto_patterns diff --git a/config.sample/badrcptto_patterns b/config.sample/badrcptto_patterns new file mode 100644 index 0000000..e3bdca9 --- /dev/null +++ b/config.sample/badrcptto_patterns @@ -0,0 +1,5 @@ +# Format is pattern\s+Response +# Don't forget to anchor the pattern if required +! Sorry, bang paths not accepted here +@.*@ Sorry, multiple at signs not accepted here +% Sorry, percent hack not accepted here diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index d3200ff..48f3a43 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -2,12 +2,13 @@ package Qpsmtpd::Plugin; use Qpsmtpd::Constants; use strict; -our %hooks = map { $_ => 1 } qw( - config queue data data_post quit rcpt mail ehlo helo +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 logging ok pre-connection post-connection + deny ok pre-connection post-connection ); +our %hooks = map { $_ => 1 } @hooks; sub new { my $proto = shift; @@ -20,7 +21,8 @@ sub register_hook { die $plugin->plugin_name . " : Invalid hook: $hook" unless $hooks{$hook}; - $plugin->{_qp}->varlog(LOGDEBUG, $plugin->plugin_name, " hooking ", $hook); + $plugin->{_qp}->log(LOGDEBUG, $plugin->plugin_name, "hooking", $hook) + unless $hook =~ /logging/; # can't log during load_logging() # I can't quite decide if it's better to parse this code ref or if # we should pass the plugin object and method name ... hmn. @@ -154,7 +156,7 @@ sub compile { sub _register_standard_hooks { my ($plugin, $qp) = @_; - for my $hook (keys %hooks) { + for my $hook (@hooks) { my $hooksub = "hook_$hook"; $hooksub =~ s/\W/_/g; $plugin->register_hook( $hook, $hooksub ) diff --git a/plugins/check_spamhelo b/plugins/check_spamhelo index 2461460..fb90b72 100644 --- a/plugins/check_spamhelo +++ b/plugins/check_spamhelo @@ -23,7 +23,7 @@ sub hook_helo { for my $bad ($self->qp->config('badhelo')) { if ($host eq lc $bad) { $self->log(LOGDEBUG, "Denying HELO from host claiming to be $bad"); - return (DENY, "Uh-huh. You're $host, and I'm a boil on the bottom of the Marquess of Queensbury's great-aunt."); + return (DENY, "Sorry, I don't believe that you are $host."); } } return DECLINED; diff --git a/plugins/logging/adaptive b/plugins/logging/adaptive index 4e57801..27d0eba 100644 --- a/plugins/logging/adaptive +++ b/plugins/logging/adaptive @@ -1,4 +1,4 @@ -#!/usr/bin/perl +#!perl # Adaptive logging plugin - logs at one level for successful messages and # one level for DENY'd messages @@ -43,7 +43,7 @@ sub hook_logging { # wlog # out this line and it will not cause an infinite loop. return DECLINED if defined $plugin and $plugin eq $self->plugin_name; - if ( $trace <= $self->{_maxlevel} ) { + if ( defined $self->{_maxlevel} && $trace <= $self->{_maxlevel} ) { warn join( " ", $$. ( @@ -56,7 +56,7 @@ sub hook_logging { # wlog "\n" unless $log[0] =~ /logging::adaptive/; push @{ $transaction->{_log} }, [ $trace, $hook, $plugin, @log ] - if ( $trace <= $self->{_minlevel} ); + if ( defined $self->{_minlevel} && $trace <= $self->{_minlevel} ); } return DECLINED; From bfd72e8adec2cfc1feb741d45c50db7093d6ae1e Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 14 Jul 2005 10:38:11 +0000 Subject: [PATCH 009/134] Fix test failures due to hook renames git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@504 958fd67b-6ff1-0310-b445-bb7760255be9 --- t/plugin_tests/dnsbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/t/plugin_tests/dnsbl b/t/plugin_tests/dnsbl index 6538de6..d36651d 100644 --- a/t/plugin_tests/dnsbl +++ b/t/plugin_tests/dnsbl @@ -11,7 +11,7 @@ sub test_local { my $connection = $self->qp->connection; $connection->remote_ip('127.0.0.2'); # standard dnsbl test value - $self->connect_handler($self->qp->transaction); + $self->hook_connect($self->qp->transaction); ok($self->qp->connection->notes('dnsbl_sockets')); } @@ -20,7 +20,7 @@ sub test_returnval { my $self = shift; my $address = Qpsmtpd::Address->parse(''); - my ($ret, $note) = $self->rcpt_handler($self->qp->transaction, + my ($ret, $note) = $self->hook_rcpt($self->qp->transaction, $address); is($ret, DENY, "Check we got a DENY"); print("# dnsbl result: $note\n"); From 3707751b424c38da6985d17c02bc7ff4d0fee7dd Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 14 Jul 2005 11:05:11 +0000 Subject: [PATCH 010/134] This fixes the redefined warnings. All plugins don't have register() any more, but they all have plugin_name(). git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@505 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 2 +- lib/Qpsmtpd/Plugin.pm | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 382aea7..b5b7169 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -230,7 +230,7 @@ sub _load_plugins { my $package = "Qpsmtpd::Plugin::$plugin_name"; # don't reload plugins if they are already loaded - unless ( defined &{"${package}::register"} ) { + unless ( defined &{"${package}::plugin_name"} ) { Qpsmtpd::Plugin->compile($plugin_name, $package, "$dir/$plugin", $self->{_test_mode}); $self->log(LOGDEBUG, "Loading $plugin_line") diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 48f3a43..6f8b124 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -94,8 +94,8 @@ sub isa_plugin { $cleanParent =~ s/\W/_/g; my $newPackage = $currentPackage."::_isa_$cleanParent"; - - return if defined &{"${newPackage}::register"}; + # don't reload plugins if they are already loaded + return if defined &{"${newPackage}::plugin_name"}; $self->compile($self->plugin_name . "_isa_$cleanParent", $newPackage, From bcbe2ac25fa64c0e228fdb690fa21724d7c50e77 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 14 Jul 2005 13:25:48 +0000 Subject: [PATCH 011/134] Don't do exists() on a method call git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@506 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/greylisting | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/greylisting b/plugins/greylisting index 2c9c412..89df1bc 100644 --- a/plugins/greylisting +++ b/plugins/greylisting @@ -184,7 +184,7 @@ sub denysoft_greylist { $self->log(LOGDEBUG, "config: " . join(',',map { $_ . '=' . $config->{$_} } sort keys %$config)); # Always allow relayclients and whitelisted hosts/senders - return DECLINED if exists $self->qp->connection->relay_client(); + return DECLINED if $self->qp->connection->relay_client(); return DECLINED if $self->qp->connection->notes('whitelisthost'); return DECLINED if $transaction->notes('whitelistsender'); From 162cf7d132f63b20f7d368156453fa6f561bfee6 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 15 Jul 2005 21:13:49 +0000 Subject: [PATCH 012/134] Notice /var/qmail/control dir (Joe Schaefer) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@509 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Apache/Qpsmtpd.pm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/Apache/Qpsmtpd.pm b/lib/Apache/Qpsmtpd.pm index 5161301..4808241 100644 --- a/lib/Apache/Qpsmtpd.pm +++ b/lib/Apache/Qpsmtpd.pm @@ -90,10 +90,13 @@ sub run { } sub config_dir { - my $self = shift; - return "$self->{qpdir}/config"; + my ($self, $config) = @_; + -e "$_/$config" and return $_ + for "$self->{qpdir}/config"; + return "/var/qmail/control"; } + sub plugin_dir { my $self = shift; return "$self->{qpdir}/plugins"; From a69b2e1526cfa2ee7a831bef52fada20ff110a29 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Mon, 18 Jul 2005 11:13:17 +0000 Subject: [PATCH 013/134] [merge from trunk] Missed hook to data_post to add headers git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@514 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/milter | 2 +- plugins/sender_permitted_from | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/milter b/plugins/milter index a577683..ff0e122 100644 --- a/plugins/milter +++ b/plugins/milter @@ -161,7 +161,7 @@ sub hook_rcpt { return DECLINED; } -sub hook_data { +sub hook_data_post { my ($self, $transaction) = @_; my $milter = $self->qp->connection->notes('milter'); diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index 4297e6c..a0c678d 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -106,7 +106,7 @@ sub _uri_escape { return $str; } -sub hook_data { +sub hook_data_post { my ($self, $transaction) = @_; my $query = $transaction->notes('spfquery'); From 820a3bcb2bc11d470194d1ab0a50af1213ca6c2e Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 18 Jul 2005 12:51:57 +0000 Subject: [PATCH 014/134] return DECLINED for bad_ssl git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@516 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/tls | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/tls b/plugins/tls index 8406f76..0e3a789 100644 --- a/plugins/tls +++ b/plugins/tls @@ -131,5 +131,6 @@ sub ssl_context { sub bad_ssl_hook { my ($self, $transaction) = @_; return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed'); + return DECLINED; } *hook_helo = *hook_data = *hook_rcpt = *hook_mail = *hook_auth = \&bad_ssl_hook; From 58f7129adadddc908c999367b7ec7cd9e9eb8b59 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Tue, 19 Jul 2005 14:20:05 +0000 Subject: [PATCH 015/134] [merge from trunk] Use qmail/control/smtpdgreeting if it exists, otherwise show the original qpsmtpd greeting (with version information). git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@518 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 6af0251..7400b66 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -104,8 +104,18 @@ sub start_conversation { return $rc; } elsif ($rc != DONE) { - $self->respond(220, $self->config('me') ." ESMTP qpsmtpd " - . $self->version ." ready; send us your mail, but not your spam."); + my $greets = $self->config('smtpgreeting'); + if ( $greets ) { + $greets .= " ESMTP"; + } + else { + $greets = $self->config('me') + . " ESMTP qpsmtpd " + . $self->version + . " ready; send us your mail, but not your spam."; + } + + $self->respond(220, $greets); return DONE; } } @@ -347,7 +357,8 @@ sub rcpt { sub help { my $self = shift; $self->respond(214, - "This is qpsmtpd " . $self->version, + "This is qpsmtpd " . + $self->config('smtpgreeting') ? '' : $self->version, "See http://smtpd.develooper.com/", 'To report bugs or send comments, mail to .'); } From 37fb26af819b6c45de6ee3cff3ccca632337b09b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Sat, 23 Jul 2005 11:11:32 +0000 Subject: [PATCH 016/134] my suggestion for a .perltidyrc. I tried it on a few files and it cleaned up more than it changed. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@520 958fd67b-6ff1-0310-b445-bb7760255be9 --- .perltidyrc | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 .perltidyrc diff --git a/.perltidyrc b/.perltidyrc new file mode 100644 index 0000000..534d52e --- /dev/null +++ b/.perltidyrc @@ -0,0 +1,16 @@ + +-i=2 # 2 space indentation (considering changing this to 4) +-ci=2 # continuation indention + +-pt=2 # tight parens +-sbt=2 # tight square parens +-bt=2 # tight curly braces +-bbt=0 # open code block curly braces + +-lp # line up with parentheses +-cti=1 # align closing parens with opening parens ("closing token placement") + +# -nolq # don't outdent long quotes (not sure if we should enable this) + + + From ea28e88fa687cf77b22a284b9a27ca82fe5165d4 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 28 Jul 2005 20:25:54 +0000 Subject: [PATCH 017/134] Extend require_resolvable_fromhost to include a configurable list of "impossible" addresses to combat spammer forging. (Hanno Hecker) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@522 958fd67b-6ff1-0310-b445-bb7760255be9 --- config.sample/invalid_resolvable_fromhost | 6 +++ plugins/require_resolvable_fromhost | 58 +++++++++++++++++++++-- 2 files changed, 61 insertions(+), 3 deletions(-) create mode 100644 config.sample/invalid_resolvable_fromhost diff --git a/config.sample/invalid_resolvable_fromhost b/config.sample/invalid_resolvable_fromhost new file mode 100644 index 0000000..db90eb8 --- /dev/null +++ b/config.sample/invalid_resolvable_fromhost @@ -0,0 +1,6 @@ +# include full network block including mask +127.0.0.0/8 +0.0.0.0/8 +224.0.0.0/4 +169.254.0.0/16 +10.0.0.0/8 diff --git a/plugins/require_resolvable_fromhost b/plugins/require_resolvable_fromhost index 1ce0f17..d056460 100644 --- a/plugins/require_resolvable_fromhost +++ b/plugins/require_resolvable_fromhost @@ -1,4 +1,7 @@ use Net::DNS qw(mx); +use Socket; + +my %invalid = (); sub hook_mail { my ($self, $transaction, $sender) = @_; @@ -6,6 +9,14 @@ sub hook_mail { 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; + } + } + $sender->format ne "<>" and $self->qp->config("require_resolvable_fromhost") and !$self->check_dns($sender->host) @@ -18,7 +29,6 @@ sub hook_mail { } - sub check_dns { my ($self, $host) = @_; @@ -30,11 +40,52 @@ sub check_dns { my $res = new Net::DNS::Resolver; $res->tcp_timeout(30); $res->udp_timeout(30); - return 1 if mx($res, $host); + 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 $rr ($query->answer) { - return 1 if $rr->type eq "A" or $rr->type eq "MX"; + if ($rr->type eq "A") { + return is_valid($rr->address); + } + elsif ($rr->type eq "MX") { + return mx_valid($self, $rr->exchange, $host); + } + } + } + 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 $query = $res->search($name); + if ($query) { + foreach my $rr ($query->answer) { + next unless $rr->type eq "A"; + return is_valid($rr->address); } } else { @@ -44,3 +95,4 @@ sub check_dns { return 0; } +# vim: ts=2 sw=2 expandtab syn=perl From a3ff03fec96f726b0efb5035189ea4810bf42d2f Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Fri, 29 Jul 2005 06:21:02 +0000 Subject: [PATCH 018/134] Merge r493 from trunk to truncate PID file before re-use git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@523 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 2 ++ 1 file changed, 2 insertions(+) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 5971e52..5db808a 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -113,6 +113,8 @@ if ($PID_FILE) { } seek PID, 0, 0 or die "Could not seek back to beginning of $PID_FILE: $!\n"; + truncate PID, 0 + or die "Could not truncate $PID_FILE at 0: $!"; } else { open PID, ">$PID_FILE" or die "open pid_file: $!\n"; From a2064bc22e9a1ff1b43f7eb25359f597710e984b Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Fri, 29 Jul 2005 06:42:00 +0000 Subject: [PATCH 019/134] Add --detach commandline option to forkserver; if supplied, daemonize just prior to entering the main accept loop. Split handling of --pid-file so that preexisting pid files are dealt with and the file is opened before priveleges are dropped, but the writing out of the new file happens after dropping privs and (if applicable) forking the daemonized process, so the correct PID is recorded. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@524 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 5db808a..d50b283 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -24,6 +24,7 @@ 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 = ''; +my $DETACH; # daemonize on startup sub usage { print <<"EOT"; @@ -36,6 +37,7 @@ usage: qpsmtpd-forkserver [ options ] -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 + -d, --detach : detach from controlling terminal (daemonize) EOT exit 0; } @@ -47,6 +49,7 @@ GetOptions('h|help' => \&usage, 'p|port=i' => \$PORT, 'u|user=s' => \$USER, 'pid-file=s' => \$PID_FILE, + 'd|detach' => \$DETACH, ) || &usage; # detaint the commandline @@ -119,8 +122,6 @@ if ($PID_FILE) { open PID, ">$PID_FILE" or die "open pid_file: $!\n"; } - print PID $$,"\n"; - close PID; } # Load plugins here @@ -151,6 +152,20 @@ $> = $quid; ', group '. (getgrgid($)) || $))); +if ($DETACH) { + open STDIN, '/dev/null' or die "/dev/null: $!"; + open STDOUT, '>/dev/null' or die "/dev/null: $!"; + open STDERR, '>&STDOUT' or die "open(stderr): $!"; + defined (my $pid = fork) or die "fork: $!"; + exit 0 if $pid; + POSIX::setsid or die "setsid: $!"; +} + +if ($PID_FILE) { + print PID $$,"\n"; + close PID; +} + while (1) { REAPER(); my $running = scalar keys %childstatus; From 00e06cc6129c204a0055f947815f875622efed6c Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Fri, 29 Jul 2005 07:22:36 +0000 Subject: [PATCH 020/134] Remove PID file on exit, if we were told to create one with --pid-file git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@525 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 3 +++ 1 file changed, 3 insertions(+) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index d50b283..ad0f701 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -81,6 +81,9 @@ sub REAPER { sub HUNTSMAN { $SIG{CHLD} = 'DEFAULT'; kill 'INT' => keys %childstatus; + if ($PID_FILE && -e $PID_FILE) { + unlink $PID_FILE or ::log(LOGERROR, "unlink: $PID_FILE: $!"); + } exit(0); } From a4e4c5217c3b9c5dc8ed1b41f9ee6c83f126811e Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Fri, 29 Jul 2005 07:24:04 +0000 Subject: [PATCH 021/134] Fix whitespace (spaces for a tab) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@526 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index ad0f701..20e5200 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -82,7 +82,7 @@ sub HUNTSMAN { $SIG{CHLD} = 'DEFAULT'; kill 'INT' => keys %childstatus; if ($PID_FILE && -e $PID_FILE) { - unlink $PID_FILE or ::log(LOGERROR, "unlink: $PID_FILE: $!"); + unlink $PID_FILE or ::log(LOGERROR, "unlink: $PID_FILE: $!"); } exit(0); } From 26bc3e25b82b4e36d4a5f87410fdeb6e2247bbfb Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Fri, 29 Jul 2005 07:41:10 +0000 Subject: [PATCH 022/134] Import Exim BSMTP queue plugin, updated to 0.31 API git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@527 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/queue/exim-bsmtp | 138 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 138 insertions(+) create mode 100644 plugins/queue/exim-bsmtp diff --git a/plugins/queue/exim-bsmtp b/plugins/queue/exim-bsmtp new file mode 100644 index 0000000..827c4eb --- /dev/null +++ b/plugins/queue/exim-bsmtp @@ -0,0 +1,138 @@ +=head1 NAME + +exim-bsmtp + +$Id: exim-bsmtp 486 2005-07-29 07:35:40Z aqua $ + +=head1 DESCRIPTION + +This plugin enqueues mail from qpsmtpd into Exim via BSMTP + +=head1 INSTALLATION + +The qpsmtpd user B be configured in the I setting +in your Exim configuration. If it is not, queueing will still work, +but sender addresses will not be honored by exim, which will make all +mail appear to originate from the smtpd user itself. + +=head1 CONFIGURATION + +The plugin accepts configuration settings in space-delimited name/value +pairs. For example: + + queue/exim-bsmtp exim_path /usr/sbin/exim4 + +=over 4 + +=item exim_path I + +The path to use to execute the Exim BSMTP receiver; by default this is +I. The commandline switch '-bS' will be added (this is +actually redundant with rsmtp, but harmless). + +=cut + +=head1 LICENSE + +Copyright (c) 2004 by Devin Carraway + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +=cut + +use strict; +use warnings; + +use IO::File; +use Sys::Hostname qw(hostname); +use File::Temp qw(tempfile); + +sub register { + my ($self, $qp, %args) = @_; + + $self->{_exim_path} = $args{exim_path} || '/usr/sbin/rsmtp'; + $self->{_exim_path} = $1 if $self->{_exim_path} =~ /(.*)/; + unless (-x $self->{_exim_path}) { + $self->log(LOGERROR, "Could not find exim at $self->{_exim_path};". + " please set exim_path in config/plugins"); + return undef; + } +} + +sub hook_queue { + my ($self, $txn) = @_; + + my $tmp_dir = $self->qp->config('spool_dir') || '/tmp'; + $tmp_dir = $1 if ($tmp_dir =~ /(.*)/); + my ($tmp, $tmpfn) = tempfile("exim-bsmtp.$$.XXXXXX", DIR => $tmp_dir); + unless ($tmp && $tmpfn) { + $self->log(LOGERROR, "Couldn't create tempfile: $!"); + return (DECLINED, 'Internal error enqueueing mail'); + } + + print $tmp "HELO ", hostname(), "\n", + "MAIL FROM:<", ($txn->sender->address || ''), ">\n"; + print $tmp "RCPT TO:<", ($_->address || ''), ">\n" + for $txn->recipients; + print $tmp "DATA\n", + $txn->header->as_string, "\n"; + $txn->body_resetpos; + while (my $line = $txn->body_getline) { + $line =~ s/^\./../; + print $tmp $line; + } + print $tmp ".\nQUIT\n"; + close $tmp; + + my $cmd = "$self->{_exim_path} -bS < $tmpfn"; + $self->log(LOGDEBUG, "executing cmd $cmd"); + my $exim = new IO::File "$cmd|"; + unless ($exim) { + $self->log(LOGERROR, "Could not execute $self->{_exim_path}: $!"); + unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!"); + return (DECLINED, "Internal error enqueuing mail"); + } + # Normally exim produces no output in BSMTP mode; anything that + # does come out is an error worth logging. + my $start = time; + while (<$exim>) { + chomp; + $self->log(LOGERROR, "exim: $_"); + } + $self->log(LOGDEBUG, "BSMTP finished (".(time - $start)." sec)"); + $exim->close; + my $exit = $?; + unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!"); + + $self->log(LOGDEBUG, "Exitcode from exim: $exit"); + if (($exit >> 8) != 0) { + $self->log(LOGERROR, 'BSMTP enqueue failed; exitcode '.($exit >> 8). + " from $self->{_exim_path} -bS"); + return (DECLINED, 'Internal error enqueuing mail'); + } + + $self->log(LOGINFO, "Enqueued to exim via BSMTP"); + return (OK, "Queued!"); +} + + +1; + +# vi: ts=4 sw=4 expandtab syn=perl + From a9bb35d180efc3654ca3a8ead8c0000c3e10cedd Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Fri, 29 Jul 2005 07:41:54 +0000 Subject: [PATCH 023/134] Enable svn:keywords git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@528 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/queue/exim-bsmtp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/queue/exim-bsmtp b/plugins/queue/exim-bsmtp index 827c4eb..1258c40 100644 --- a/plugins/queue/exim-bsmtp +++ b/plugins/queue/exim-bsmtp @@ -2,7 +2,7 @@ exim-bsmtp -$Id: exim-bsmtp 486 2005-07-29 07:35:40Z aqua $ +$Id$ =head1 DESCRIPTION From deb3380d06663c7a98db031431f00c031dad1e09 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Fri, 29 Jul 2005 08:05:42 +0000 Subject: [PATCH 024/134] Apply slight variation on patch from Peter Holzer to allow specification of an explicit $QPSMTPD_CONFIG variable to specify where the config lives, overriding $QMAIL/control and /var/qmail/control if set. The usual "last location with the file wins" rule still applies. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@529 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 4 ++++ lib/Qpsmtpd.pm | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/Changes b/Changes index 4b5a02e..2f0e11d 100644 --- a/Changes +++ b/Changes @@ -17,6 +17,10 @@ The unrecognized_command hook now uses DENY_DISCONNECT return for disconnecting the user. + If the environment variable $QPSMTPD_CONFIG is set, qpsmtpd will look + for its config files in the directory given therein, in addition to (and + in preference to) other locations. (Peter J. Holzer) + Updated documentation diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index b5b7169..6fb2a45 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -114,6 +114,10 @@ sub config_dir { my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control'; my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); $configdir = "$name/config" if (-e "$name/config/$config"); + if (exists $ENV{QPSMTPD_CONFIG}) { + $ENV{QPSMTPD_CONFIG} =~ /^(.*)$/; # detaint + $configdir = $1 if -e "$1/$config"; + } return $configdir; } From 81f71b4a88db618731d3530ae219cd1f2e080511 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Fri, 29 Jul 2005 08:08:51 +0000 Subject: [PATCH 025/134] Mention --detach in changelog git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@530 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Changes b/Changes index 2f0e11d..595bdec 100644 --- a/Changes +++ b/Changes @@ -11,6 +11,10 @@ postfix backend, which expects to have write permission to a fifo which usually belongs to group postdrop). (pjh) + qpsmtpd-forkserver: if -d or --detach is given on the commandline, + forkserver will detach from the controlling terminal and daemonize + itself (Devin Carraway) + when disconncting with a temporary failure, return 421 rather than 450 or 451. (Peter J. Holzer) From 347ce0dd0c42a46c9533d4c04911d9694deddef2 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Fri, 29 Jul 2005 08:10:35 +0000 Subject: [PATCH 026/134] Mention exim-bsmtp plugin in changelog git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@531 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Changes b/Changes index 595bdec..f9413f3 100644 --- a/Changes +++ b/Changes @@ -25,6 +25,9 @@ for its config files in the directory given therein, in addition to (and in preference to) other locations. (Peter J. Holzer) + Added queue/exim-bsmtp plugin to spool accepted mail into an Exim + backend via BSMTP. (Devin Carraway) + Updated documentation From bde5a3fef9d77869755de70f6c577964e0a5d80d Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sat, 30 Jul 2005 07:22:13 +0000 Subject: [PATCH 027/134] Merge r534 from trunk (caution about using large wait times in check_earlytalker) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@535 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/check_earlytalker | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index f21748b..9987675 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -20,7 +20,11 @@ on all mail/rcpt commands in the transaction. =item wait [integer] The number of seconds to delay the initial greeting to see if the connecting -host speaks first. The default is 1. +host speaks first. The default is 1. Do not select a value that is too high, +or you may be unable to receive mail from MTAs with short SMTP connect or +greeting timeouts -- these are known to range as low as 30 seconds, and may +in some cases be configured lower by mailserver admins. Network transit time +must also be allowed for. =item action [string: deny, denysoft, log] From da5c0a74fe0d70997edf3829d7ed60fcaad77639 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sat, 30 Jul 2005 09:32:36 +0000 Subject: [PATCH 028/134] Fix unitialized-value warning if the PID file existed but was zero-length at startup time. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@536 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 20e5200..64f38d7 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -110,7 +110,7 @@ if ($PID_FILE) { if (-e $PID_FILE) { open PID, "+<$PID_FILE" or die "open pid_file: $!\n"; - my $running_pid = ; chomp $running_pid; + my $running_pid = || ''; chomp $running_pid; if ($running_pid =~ /(\d+)/) { $running_pid = $1; if (kill 0, $running_pid) { From 6f23c46e931640d039619dae955d8d2147707e9a Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sun, 31 Jul 2005 05:54:36 +0000 Subject: [PATCH 029/134] Generalize '$include' support from plugin configuration to cover all config calls. Add circular-reference checking. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@537 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 92 +++++++++++++++++++++++++++++++++++++------------- 1 file changed, 68 insertions(+), 24 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 6fb2a45..058a487 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -159,18 +159,84 @@ sub get_qmail_config { } sub _config_from_file { - my ($self, $configfile, $config) = @_; + my ($self, $configfile, $config, $visited) = @_; return unless -e $configfile; + + $visited ||= []; + push @{$visited}, $configfile; + open CF, "<$configfile" or warn "$$ could not open configfile $configfile: $!" and return; my @config = ; chomp @config; @config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/} @config; close CF; - #$self->log(10, "returning get_config for $config ",Data::Dumper->Dump([\@config], [qw(config)])); + + my $pos = 0; + while ($pos < @config) { + # recursively pursue an $include reference, if found. An inclusion which + # begins with a leading slash is interpreted as a path to a file and will + # supercede the usual config path resolution. Otherwise, the normal + # config_dir() lookup is employed (the location in which the inclusion + # appeared receives no special precedence; possibly it should, but it'd + # be complicated beyond justifiability for so simple a config system. + if ($config[$pos] =~ /^\s*\$include\s+(\S+)\s*$/) { + my ($includedir, $inclusion) = ('', $1); + + splice @config, $pos, 1; # remove the $include line + if ($inclusion !~ /^\//) { + $includedir = $self->config_dir($inclusion); + $inclusion = "$includedir/$inclusion"; + } + + if (grep($_ eq $inclusion, @{$visited})) { + $self->log(LOGERROR, "Circular \$include reference in config $config:"); + $self->log(LOGERROR, "From $visited->[0]:"); + $self->log(LOGERROR, " includes $_") + for (@{$visited}[1..$#{$visited}], $inclusion); + return wantarray ? () : undef; + } + push @{$visited}, $inclusion; + + for my $inc ($self->expand_inclusion_($inclusion, $configfile)) { + my @insertion = $self->_config_from_file($inc, $config, $visited); + splice @config, $pos, 0, @insertion; # insert the inclusion + $pos += @insertion; + } + } else { + $pos++; + } + } + $self->{_config_cache}->{$config} = \@config; + return wantarray ? @config : $config[0]; } +sub expand_inclusion_ { + my $self = shift; + my $inclusion = shift; + my $context = shift; + my @includes; + + if (-d $inclusion) { + $self->log(LOGDEBUG, "inclusion of directory $inclusion from $context"); + + if (opendir(INCD, $inclusion)) { + @includes = map { "$inclusion/$_" } + (grep { -f "$inclusion/$_" and !/^\./ } readdir INCD); + closedir INCD; + } else { + $self->log(LOGERROR, "Couldn't open directory $inclusion,". + " referenced from $context ($!)"); + } + } else { + $self->log(LOGDEBUG, "inclusion of file $inclusion from $context"); + @includes = ( $inclusion ); + } + return @includes; +} + + sub load_plugins { my $self = shift; @@ -195,28 +261,6 @@ sub _load_plugins { for my $plugin_line (@plugins) { my ($plugin, @args) = split ' ', $plugin_line; - if (lc($plugin) eq '$include') { - my $inc = shift @args; - my $config_dir = $self->config_dir($inc); - if (-d "$config_dir/$inc") { - $self->log(LOGDEBUG, "Loading include dir: $config_dir/$inc"); - opendir(DIR, "$config_dir/$inc") || die "opendir($config_dir/$inc): $!"; - my @plugconf = sort grep { -f $_ } map { "$config_dir/$inc/$_" } grep { !/^\./ } readdir(DIR); - closedir(DIR); - foreach my $f (@plugconf) { - push @ret, $self->_load_plugins($dir, $self->_config_from_file($f, "plugins")); - } - } - elsif (-f "$config_dir/$inc") { - $self->log(LOGDEBUG, "Loading include file: $config_dir/$inc"); - push @ret, $self->_load_plugins($dir, $self->_config_from_file("$config_dir/$inc", "plugins")); - } - else { - $self->log(LOGCRIT, "CRITICAL PLUGIN CONFIG ERROR: Include $config_dir/$inc not found"); - } - next; - } - my $plugin_name = $plugin; $plugin =~ s/:\d+$//; # after this point, only used for filename From 0d8d9f03b86957bea7dfe1a38361d05ba31ebfca Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 15 Aug 2005 18:43:19 +0000 Subject: [PATCH 030/134] Merge from trunk r540:541 git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@542 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/tls | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/plugins/tls b/plugins/tls index 0e3a789..30dc927 100644 --- a/plugins/tls +++ b/plugins/tls @@ -41,6 +41,21 @@ sub init { # now extract the password... $self->ssl_context($ssl_ctx); + + # Check for possible AUTH mechanisms +HOOK: foreach my $hook ( keys %{$qp->{hooks}} ) { + if ( $hook =~ m/^auth-?(.+)?$/ ) { + if ( defined $1 ) { + my $hooksub = "hook_$hook"; + $hooksub =~ s/\W/_/g; + *$hooksub = \&bad_ssl_hook; + } + else { # at least one polymorphous auth provider + *hook_auth = \&bad_ssl_hook; + } + } + } + } sub hook_ehlo { @@ -133,4 +148,4 @@ sub bad_ssl_hook { return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed'); return DECLINED; } -*hook_helo = *hook_data = *hook_rcpt = *hook_mail = *hook_auth = \&bad_ssl_hook; +*hook_helo = *hook_data = *hook_rcpt = *hook_mail = \&bad_ssl_hook; From 87baf0fbf1ea0c288c9660df1523c129b8153929 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Tue, 16 Aug 2005 04:57:03 +0000 Subject: [PATCH 031/134] yay for 4 space indentation (but let's not run this until post 0.31) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@543 958fd67b-6ff1-0310-b445-bb7760255be9 --- .perltidyrc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.perltidyrc b/.perltidyrc index 534d52e..65b29f2 100644 --- a/.perltidyrc +++ b/.perltidyrc @@ -1,5 +1,5 @@ --i=2 # 2 space indentation (considering changing this to 4) +-i=4 # 4 space indentation (we used to use 2; in the future we'll use 4) -ci=2 # continuation indention -pt=2 # tight parens From 9cbf206a4a3acdb7d431393f4070c4d7209e11b5 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 22 Sep 2005 17:14:20 +0000 Subject: [PATCH 032/134] * lib/Qpsmtpd/TcpServer.pm Don't try to load the plugins if they are already loaded. * lib/Qpsmtpd/Transaction.pm Get the size_threshold by inheritance. Extract the spooling of the body as a new sub. Always spool the body when calling body_filename(). Compare the body_size to the cached size_threshold. * lib/Qpsmtpd.pm Cache the size_threshold and provide an accessor method. * qpsmtpd-forkserver Initialize both the spool_dir and size_threshold caches before forking. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@547 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 11 ++++++++++- lib/Qpsmtpd/TcpServer.pm | 2 +- lib/Qpsmtpd/Transaction.pm | 35 +++++++++++++++++------------------ qpsmtpd-forkserver | 4 ++++ 4 files changed, 32 insertions(+), 20 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 058a487..4e86f6d 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -1,6 +1,6 @@ package Qpsmtpd; use strict; -use vars qw($VERSION $Logger $TraceLevel $Spool_dir); +use vars qw($VERSION $Logger $TraceLevel $Spool_dir $Size_threshold); use Sys::Hostname; use Qpsmtpd::Constants; @@ -415,6 +415,15 @@ sub temp_dir { return $dirname; } +sub size_threshold { + my $self = shift; + unless ( defined $Size_threshold ) { + $Size_threshold = $self->config('memory_threshold') || 10_000; + $self->log(LOGNOTICE, "size_threshold set to $Size_threshold"); + } + return $Size_threshold; +} + 1; __END__ diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index dcac57d..46022d7 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -39,7 +39,7 @@ sub run { my $self = shift; # should be somewhere in Qpsmtpd.pm and not here... - $self->load_plugins; + $self->load_plugins unless $self->{hooks}; my $rc = $self->start_conversation; return if $rc != DONE; diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index a6dc3be..7221ecd 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -15,9 +15,6 @@ sub start { my %args = @_; my $self = { _rcpt => [], started => time }; bless ($self, $class); - my $sz = $self->config('memory_threshold'); - $sz = 10_000 unless defined($sz); - $self->{_size_threshold} = $sz; return $self; } @@ -91,13 +88,27 @@ sub body_current_pos { return $self->{_body_current_pos} || 0; } -# TODO - should we create the file here if we're storing as an array? sub body_filename { my $self = shift; - return unless $self->{_body_file}; + $self->body_spool() unless $self->{_body_file}; return $self->{_filename}; } +sub body_spool { + my $self = shift; + $self->log(LOGWARN, "spooling to disk"); + $self->{_filename} = $self->temp_file(); + $self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600) + or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error; + if ($self->{_body_array}) { + foreach my $line (@{ $self->{_body_array} }) { + $self->{_body_file}->print($line) or die "Cannot print to temp file: $!"; + } + $self->{_body_start} = $self->{_header_size}; + } + $self->{_body_array} = undef; +} + sub body_write { my $self = shift; my $data = shift; @@ -125,19 +136,7 @@ sub body_write { $self->{_body_size} += length($1); ++$self->{_body_current_pos}; } - if ($self->{_body_size} >= $self->{_size_threshold}) { - #warn("spooling to disk\n"); - $self->{_filename} = $self->temp_file(); - $self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600) - or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error; - if ($self->{_body_array}) { - foreach my $line (@{ $self->{_body_array} }) { - $self->{_body_file}->print($line) or die "Cannot print to temp file: $!"; - } - $self->{_body_start} = $self->{_header_size}; - } - $self->{_body_array} = undef; - } + $self->body_spool if ( $self->{_body_size} >= $self->size_threshold() ); } } diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 64f38d7..2d9d35b 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -169,6 +169,10 @@ if ($PID_FILE) { close PID; } +# Populate class cached variables +$qpsmtpd->spool_dir; +$qpsmtpd->size_threshold; + while (1) { REAPER(); my $running = scalar keys %childstatus; From 29ac60322e0c25b318b17e44452fd1a99c845627 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 22 Sep 2005 17:19:47 +0000 Subject: [PATCH 033/134] * lib/Qpsmtpd.pm Rename config file from memory_threshold to size_threshold to track the internal usage. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@548 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 4e86f6d..8064cd4 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -418,7 +418,7 @@ sub temp_dir { sub size_threshold { my $self = shift; unless ( defined $Size_threshold ) { - $Size_threshold = $self->config('memory_threshold') || 10_000; + $Size_threshold = $self->config('size_threshold') || 10_000; $self->log(LOGNOTICE, "size_threshold set to $Size_threshold"); } return $Size_threshold; From 4b3fdf50bd0d71c59328b47297094e4fdd1579c4 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 22 Sep 2005 17:29:13 +0000 Subject: [PATCH 034/134] * lib/Qpsmtpd.pm By default, spool all messages to disk. * config.sample/size_threshold Provide minimal explanation for how to avoid spooling small messages. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@549 958fd67b-6ff1-0310-b445-bb7760255be9 --- config.sample/size_threshold | 3 +++ lib/Qpsmtpd.pm | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) create mode 100644 config.sample/size_threshold diff --git a/config.sample/size_threshold b/config.sample/size_threshold new file mode 100644 index 0000000..a6a1fb4 --- /dev/null +++ b/config.sample/size_threshold @@ -0,0 +1,3 @@ +# Messages below the size below will be stored in memory and not spooled. +# Without this file, the default is 0 bytes, i.e. all messages will be spooled. +10000 diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 8064cd4..9572df7 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -418,7 +418,7 @@ sub temp_dir { sub size_threshold { my $self = shift; unless ( defined $Size_threshold ) { - $Size_threshold = $self->config('size_threshold') || 10_000; + $Size_threshold = $self->config('size_threshold') || 0; $self->log(LOGNOTICE, "size_threshold set to $Size_threshold"); } return $Size_threshold; From b808a139cff925a13b3764ff7346df9d69f30fa9 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Fri, 23 Sep 2005 19:16:37 +0000 Subject: [PATCH 035/134] * lib/Qpsmtpd/Transaction.pm IO::File is buffering the message, so that the AV software doesn't get a a chance to scan anything when size_threshold > 0. * qpsmtpd Apparently no one is running tcpserver any longer, since it wasn't loading the plugins anymore. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@550 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Transaction.pm | 5 +++-- qpsmtpd | 1 + 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index 7221ecd..d8829e1 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -90,13 +90,13 @@ sub body_current_pos { sub body_filename { my $self = shift; - $self->body_spool() unless $self->{_body_file}; + $self->body_spool() unless $self->{_filename}; return $self->{_filename}; } sub body_spool { my $self = shift; - $self->log(LOGWARN, "spooling to disk"); + $self->log(LOGINFO, "spooling message to disk"); $self->{_filename} = $self->temp_file(); $self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600) or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error; @@ -107,6 +107,7 @@ sub body_spool { $self->{_body_start} = $self->{_header_size}; } $self->{_body_array} = undef; + $self->{_body_file}->close(); } sub body_write { diff --git a/qpsmtpd b/qpsmtpd index 254458e..092cd3a 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -19,6 +19,7 @@ delete $ENV{ENV}; $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin'; my $qpsmtpd = Qpsmtpd::TcpServer->new(); +$qpsmtpd->load_plugins(); $qpsmtpd->start_connection(); $qpsmtpd->run(); From 111afb91db62e058703b2079f1ac93c6f0cc968b Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 7 Oct 2005 14:30:10 +0000 Subject: [PATCH 036/134] No strict refs when assigning to a glob git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@551 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/tls | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/tls b/plugins/tls index 30dc927..f25a3d2 100644 --- a/plugins/tls +++ b/plugins/tls @@ -44,6 +44,7 @@ sub init { # 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"; From e6efda626fc67237060c4064085f465e0b49a997 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Mon, 10 Oct 2005 15:49:50 +0000 Subject: [PATCH 037/134] * lib/Qpsmtpd/Address.pm Convert objects to hash. Neuter parse() to wrapper around new(). Add overload stringify to $obj->format(). * t/qpsmtpd-address.t Remove tests specific to parse(). Add test for overloaded "". git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@552 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Address.pm | 68 ++++++++++++++++++++++-------------------- t/qpsmtpd-address.t | 19 ++---------- 2 files changed, 38 insertions(+), 49 deletions(-) diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index 90f7530..a2fad98 100644 --- a/lib/Qpsmtpd/Address.pm +++ b/lib/Qpsmtpd/Address.pm @@ -1,16 +1,23 @@ package Qpsmtpd::Address; use strict; +use overload ( + '""' => \&format, +); + sub new { - my ($class, $address) = @_; - my $self = [ ]; - if ($address =~ /^<(.*)>$/) { - $self->[0] = $1; - } else { - $self->[0] = $address; + my ($class, $user, $host) = @_; + my $self = {}; + if ($user =~ /^<(.*)>$/ ) { + ($user, $host) = $class->canonify($user) } - bless ($self, $class); - return $self; + elsif ( not defined $host ) { + my $address = $user; + ($user, $host) = $address =~ m/(.*)(?:\@(.*))/; + } + $self->{_user} = $user; + $self->{_host} = $host; + return bless $self, $class; } # Definition of an address ("path") from RFC 2821: @@ -133,58 +140,55 @@ sub canonify { # my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/); - return undef unless defined $localpart; + return (undef) unless defined $localpart; if ($localpart =~ /^$atom(\.$atom)*/) { # simple case, we are done - return $path; + return ($localpart, $domainpart); } if ($localpart =~ /^"(($qtext|\\$text)*)"$/) { $localpart = $1; $localpart =~ s/\\($text)/$1/g; - return "$localpart\@$domainpart"; + return ($localpart, $domainpart); } - return undef; + return (undef); } - - -sub parse { - my ($class, $line) = @_; - my $a = $class->canonify($line); - return ($class->new($a)) if (defined $a); - return undef; +sub parse { # retain for compatibility only + return shift->new(shift); } sub address { my ($self, $val) = @_; - my $oldval = $self->[0]; - return $self->[0] = $val if (defined($val)); - return $oldval; + if ( defined($val) ) { + $val = "<$val>" unless $val =~ /^<.+>$/; + my ($user, $host) = $self->canonify($val); + $self->{_user} = $user; + $self->{_host} = $host; + } + return ( defined $self->{_user} ? $self->{_user} : '' ) + . ( defined $self->{_host} ? '@'.$self->{_host} : '' ); } sub format { my ($self) = @_; my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]'; - my $s = $self->[0]; - return '<>' unless $s; - my ($user, $host) = $s =~ m/(.*)\@(.*)/; - if ($user =~ s/($qchar)/\\$1/g) { - return qq{<"$user"\@$host>}; + return '<>' unless defined $self->{_user}; + if ( ( my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) { + return qq(<"$user") + . ( defined $self->{_host} ? '@'.$self->{_host} : '' ). ">"; } - return "<$s>"; + return "<".$self->address().">"; } sub user { my ($self) = @_; - my ($user, $host) = $self->[0] =~ m/(.*)\@(.*)/; - return $user; + return $self->{_user}; } sub host { my ($self) = @_; - my ($user, $host) = $self->[0] =~ m/(.*)\@(.*)/; - return $host; + return $self->{_host}; } 1; diff --git a/t/qpsmtpd-address.t b/t/qpsmtpd-address.t index b041e5a..a38a4c6 100644 --- a/t/qpsmtpd-address.t +++ b/t/qpsmtpd-address.t @@ -2,7 +2,7 @@ use strict; $^W = 1; -use Test::More tests => 28; +use Test::More tests => 25; BEGIN { use_ok('Qpsmtpd::Address'); @@ -38,21 +38,6 @@ $ao = Qpsmtpd::Address->parse($as); ok ($ao, "parse $as"); is ($ao->format, '<"foo\ bar"@example.com>', "format $as"); - -$as = 'foo@example.com'; -$ao = Qpsmtpd::Address->parse($as); -is ($ao, undef, "can't parse $as"); - -$as = '<@example.com>'; -is (Qpsmtpd::Address->parse($as), undef, "can't parse $as"); - -$as = '<@123>'; -is (Qpsmtpd::Address->parse($as), undef, "can't parse $as"); - -$as = ''; -is (Qpsmtpd::Address->parse($as), undef, "can't parse $as"); - - $as = 'foo@example.com'; $ao = Qpsmtpd::Address->new($as); ok ($ao, "new $as"); @@ -79,10 +64,10 @@ $as = ''; $ao = Qpsmtpd::Address->new($as); ok ($ao, "new $as"); is ($ao->format, $as, "format $as"); +is ("$ao", $as, "overloaded stringify $as"); $as = 'foo@foo.x.example.com'; ok ($ao = Qpsmtpd::Address->parse("<$as>"), "parse <$as>"); is ($ao && $ao->address, $as, "address $as"); - From a8b6956d818f51a184a4281963cc64d993792341 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 20 Oct 2005 02:10:32 +0000 Subject: [PATCH 038/134] * lib/Qpsmtpd/Transaction.pm Fix fairly egregious error. If the size_threashold is smaller than the body while writing, the file handle would be closed prematurely. Ouch. I don't like it here from a stylistic point of view, but at least it will actually work now. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@553 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Transaction.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index d8829e1..6fb0f49 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -91,6 +91,7 @@ sub body_current_pos { sub body_filename { my $self = shift; $self->body_spool() unless $self->{_filename}; + $self->{_body_file}->close(); # so contents won't be cached return $self->{_filename}; } @@ -107,7 +108,6 @@ sub body_spool { $self->{_body_start} = $self->{_header_size}; } $self->{_body_array} = undef; - $self->{_body_file}->close(); } sub body_write { From e67bbed2ac59e411547d7a5a00821238e3d6a5f4 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 20 Oct 2005 18:47:28 +0000 Subject: [PATCH 039/134] * lib/Qpsmtpd/Transaction.pm Doh! I should flush() not close(), since other code assume the handle is still active. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@554 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Transaction.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index 6fb0f49..ea1d41c 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -91,7 +91,7 @@ sub body_current_pos { sub body_filename { my $self = shift; $self->body_spool() unless $self->{_filename}; - $self->{_body_file}->close(); # so contents won't be cached + $self->{_body_file}->flush(); # so contents won't be cached return $self->{_filename}; } From 5959cc1c32491267125a9b68d0feda78f0d76a1a Mon Sep 17 00:00:00 2001 From: John Peacock Date: Mon, 31 Oct 2005 17:12:37 +0000 Subject: [PATCH 040/134] * lib/Qpsmtpd/Auth.pm lib/Qpsmtpd/SMTP.pm Take the AUTH method and put it in SMTP.pm where it belongs. * lib/Qpsmtpd.pm lib/Qpsmtpd/Plugin.pm Expose the auth_user/auth_mechanism property to plugin writers. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@556 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 10 ++++++++++ lib/Qpsmtpd/Auth.pm | 13 ------------- lib/Qpsmtpd/Plugin.pm | 8 ++++++++ lib/Qpsmtpd/SMTP.pm | 13 +++++++++++++ 4 files changed, 31 insertions(+), 13 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 9572df7..9ee6514 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -423,6 +423,16 @@ sub size_threshold { } return $Size_threshold; } + +sub auth_user { + my $self = shift; + return (defined $self->{_auth_user} ? $self->{_auth_user} : "" ); +} + +sub auth_mechanism { + my $self = shift; + return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" ); +} 1; diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm index ea28b92..3bb2c86 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/lib/Qpsmtpd/Auth.pm @@ -226,19 +226,6 @@ sub e64 return($res); } -sub Qpsmtpd::SMTP::auth { - my ( $self, $arg, @stuff ) = @_; - - #they AUTH'd once already - return $self->respond( 503, "but you already said AUTH ..." ) - 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->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff ); -} - sub SASL { # $DB::single = 1; diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 6f8b124..f7250f7 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -65,6 +65,14 @@ sub spool_dir { shift->qp->spool_dir; } +sub auth_user { + shift->qp->auth_user; +} + +sub auth_mechanism { + shift->qp->auth_mechanism; +} + sub temp_file { my $self = shift; my $tempfile = $self->qp->temp_file; diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 7400b66..b24eed7 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -225,6 +225,19 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { } } +sub auth { + my ( $self, $arg, @stuff ) = @_; + + #they AUTH'd once already + return $self->respond( 503, "but you already said AUTH ..." ) + 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->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff ); +} + sub mail { my $self = shift; return $self->respond(501, "syntax error in parameters") if !$_[0] or $_[0] !~ m/^from:/i; From 7bc7916bda3750fbf3e6c82bd522c87cc4801010 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Mon, 31 Oct 2005 17:51:11 +0000 Subject: [PATCH 041/134] * lib/Qpsmtpd/Address.pm Since we are already overloading stringify, we might as well overload comparisons as well (this may be too simplistic a test). git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@557 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Address.pm | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index a2fad98..1d0ea77 100644 --- a/lib/Qpsmtpd/Address.pm +++ b/lib/Qpsmtpd/Address.pm @@ -2,7 +2,9 @@ package Qpsmtpd::Address; use strict; use overload ( - '""' => \&format, + '""' => \&format, + 'cmp' => \&spaceship, + '<=>' => \&spaceship, ); sub new { @@ -191,4 +193,20 @@ sub host { return $self->{_host}; } +sub spaceship { + require UNIVERSAL; + my ($left, $right, $swap) = @_; + my $class = ref($left); + + unless ( UNIVERSAL::isa($right, $class) ) { + $right = $class->new($right); + } + + if ( $swap ) { + ($right, $left) = ($left, $right); + } + + return lc($left->format) cmp lc($right->format); +} + 1; From 3b09cc25d782100ab4b416bb3ff79738eff3e873 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Tue, 1 Nov 2005 15:14:48 +0000 Subject: [PATCH 042/134] * lib/Qpsmtpd/Address.pm Don't overload '<=>' operator casually. Swap host/user portion when comparing (makes it easy to sort by domain). git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@558 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Address.pm | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index 1d0ea77..56bf689 100644 --- a/lib/Qpsmtpd/Address.pm +++ b/lib/Qpsmtpd/Address.pm @@ -3,8 +3,7 @@ use strict; use overload ( '""' => \&format, - 'cmp' => \&spaceship, - '<=>' => \&spaceship, + 'cmp' => \&addr_cmp, ); sub new { @@ -193,7 +192,7 @@ sub host { return $self->{_host}; } -sub spaceship { +sub addr_cmp { require UNIVERSAL; my ($left, $right, $swap) = @_; my $class = ref($left); @@ -201,12 +200,16 @@ sub spaceship { unless ( UNIVERSAL::isa($right, $class) ) { $right = $class->new($right); } - + + #invert the address so we can sort by domain then user + $left = lc($left->host.'='.$left->user); + $right = lc($right->host.'='.$right->user); + if ( $swap ) { ($right, $left) = ($left, $right); } - return lc($left->format) cmp lc($right->format); + return ($left cmp $right); } 1; From 37ec3b151eab6fc366a50f1eae147020ba3e09fc Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 2 Nov 2005 18:48:32 +0000 Subject: [PATCH 043/134] * lib/Qpsmtpd/Address.pm Add POD to describe how to use the objects. Make the addr_cmp method private (no need to expose it). * t/qpsmtpd-address.t Include tests of overloaded comparison, including sorting. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@559 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Address.pm | 117 +++++++++++++++++++++++++++++++++++++++-- t/qpsmtpd-address.t | 27 +++++++++- 2 files changed, 140 insertions(+), 4 deletions(-) diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index 56bf689..3b25800 100644 --- a/lib/Qpsmtpd/Address.pm +++ b/lib/Qpsmtpd/Address.pm @@ -1,11 +1,61 @@ +#!/usr/bin/perl -w package Qpsmtpd::Address; use strict; +=head1 NAME + +Qpsmtpd::Address - Lightweight E-Mail address objects + +=head1 DESCRIPTION + +Based originally on cut and paste from Mail::Address and including +every jot and tittle from RFC-2821/2822 on what is a legal e-mail +address for use during the SMTP transaction. + +=head1 USAGE + + my $rcpt = Qpsmtpd::Address->new(''); + +The objects created can be used as is, since they automatically +stringify to a standard form, and they have an overloaded comparison +for easy testing of values. + +=head1 METHODS + +=cut + use overload ( '""' => \&format, - 'cmp' => \&addr_cmp, + 'cmp' => \&_addr_cmp, ); +=head2 new() + +Can be called two ways: + +=over 4 + +=item * Qpsmtpd::Address->new('') + +The normal mode of operation is to pass the entire contents of the +RCPT TO: command from the SMTP transaction. The value will be fully +parsed via the L method, using the full RFC 2821 rules. + +=item * Qpsmtpd::Address->new("user", "host") + +If the caller has already split the address from the domain/host, +this mode will not L the input values. This is not +recommended in cases of user-generated input for that reason. This +can be used to generate Qpsmtpd::Address objects for accounts like +"" or indeed for the bounce address "<>". + +=back + +The resulting objects can be stored in arrays or used in plugins to +test for equality (like in badmailfrom). + +=cut + sub new { my ($class, $user, $host) = @_; my $self = {}; @@ -118,6 +168,15 @@ sub new { # # (We ignore all obs forms) +=head2 canonify() + +Primarily an internal method, it is used only on the path portion of +an e-mail message, as defined in RFC-2821 (this is the part inside the +angle brackets and does not include the "human readable" portion of an +address). It returns a list of (local-part, domain). + +=cut + sub canonify { my ($dummy, $path) = @_; my $atom = '[a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~]+'; @@ -155,10 +214,29 @@ sub canonify { return (undef); } +=head2 parse() + +Retained as a compatibility method, it is completely equivalent +to new() called with a single parameter. + +=cut + sub parse { # retain for compatibility only return shift->new(shift); } +=head2 address() + +Can be used to reset the value of an existing Q::A object, in which +case it takes a parameter with or without the angle brackets. + +Returns the stringified representation of the address. NOTE: does +not escape any of the characters that need escaping, nor does it +include the surrounding angle brackets. For that purpose, see +L. + +=cut + sub address { my ($self, $val) = @_; if ( defined($val) ) { @@ -171,6 +249,18 @@ sub address { . ( defined $self->{_host} ? '@'.$self->{_host} : '' ); } +=head2 format() + +Returns the canonical stringified representation of the address. It +does escape any characters requiring it (per RFC-2821/2822) and it +does include the surrounding angle brackets. It is also the default +stringification operator, so the following are equivalent: + + print $rcpt->format(); + print $rcpt; + +=cut + sub format { my ($self) = @_; my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]'; @@ -182,17 +272,31 @@ sub format { return "<".$self->address().">"; } +=head2 user() + +Returns the "localpart" of the address, per RFC-2821, or the portion +before the '@' sign. + +=cut + sub user { my ($self) = @_; return $self->{_user}; } +=head2 host() + +Returns the "domain" part of the address, per RFC-2821, or the portion +after the '@' sign. + +=cut + sub host { my ($self) = @_; return $self->{_host}; } -sub addr_cmp { +sub _addr_cmp { require UNIVERSAL; my ($left, $right, $swap) = @_; my $class = ref($left); @@ -211,5 +315,12 @@ sub addr_cmp { return ($left cmp $right); } - + +=head1 COPYRIGHT + +Copyright 2004-2005 Peter J. Holzer. See the LICENSE file for more +information. + +=cut + 1; diff --git a/t/qpsmtpd-address.t b/t/qpsmtpd-address.t index a38a4c6..145d775 100644 --- a/t/qpsmtpd-address.t +++ b/t/qpsmtpd-address.t @@ -2,7 +2,7 @@ use strict; $^W = 1; -use Test::More tests => 25; +use Test::More tests => 27; BEGIN { use_ok('Qpsmtpd::Address'); @@ -69,5 +69,30 @@ is ("$ao", $as, "overloaded stringify $as"); $as = 'foo@foo.x.example.com'; ok ($ao = Qpsmtpd::Address->parse("<$as>"), "parse <$as>"); is ($ao && $ao->address, $as, "address $as"); +ok ($ao eq $as, "overloaded 'cmp' operator"); +my @unsorted_list = map { Qpsmtpd::Address->new($_) } + qw( + "musa_ibrah@caramail.comandrea.luger"@wifo.ac.at + foo@example.com + ask@perl.org + foo@foo.x.example.com + jpeacock@cpan.org + test@example.com + ); + +# NOTE that this is sorted by _host_ not by _domain_ +my @sorted_list = map { Qpsmtpd::Address->new($_) } + qw( + jpeacock@cpan.org + foo@example.com + test@example.com + foo@foo.x.example.com + ask@perl.org + "musa_ibrah@caramail.comandrea.luger"@wifo.ac.at + ); + +my @test_list = sort @unsorted_list; + +is_deeply( \@test_list, \@sorted_list, "sort via overloaded 'cmp' operator"); From 8a18bb00a156f08cfda4ad2b1b778cf75155ae50 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Tue, 8 Nov 2005 18:18:02 +0000 Subject: [PATCH 044/134] * lib/Qpsmtpd/Address.pm RFC-2821 Section 4.5.1 specifically requires (without domain name) as a legal RCPT TO: address. * t/qpsmtpd-address.t Test the above. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@560 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Address.pm | 4 +++- t/qpsmtpd-address.t | 7 ++++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index 3b25800..6a8f28a 100644 --- a/lib/Qpsmtpd/Address.pm +++ b/lib/Qpsmtpd/Address.pm @@ -198,7 +198,9 @@ sub canonify { # empty path is ok return "" if $path eq ""; - # + # bare postmaster is permissible, perl RFC-2821 (4.5.1) + return ("postmaster", undef) if $path eq "postmaster"; + my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/); return (undef) unless defined $localpart; diff --git a/t/qpsmtpd-address.t b/t/qpsmtpd-address.t index 145d775..c08d44b 100644 --- a/t/qpsmtpd-address.t +++ b/t/qpsmtpd-address.t @@ -2,7 +2,7 @@ use strict; $^W = 1; -use Test::More tests => 27; +use Test::More tests => 29; BEGIN { use_ok('Qpsmtpd::Address'); @@ -16,6 +16,11 @@ $ao = Qpsmtpd::Address->parse($as); ok ($ao, "parse $as"); is ($ao->format, $as, "format $as"); +$as = ''; +$ao = Qpsmtpd::Address->parse($as); +ok ($ao, "parse $as"); +is ($ao->format, $as, "format $as"); + $as = ''; $ao = Qpsmtpd::Address->parse($as); ok ($ao, "parse $as"); From 440068cf5cfc425462a1dd4c709d40e49bd2d88c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Mon, 14 Nov 2005 09:05:46 +0000 Subject: [PATCH 045/134] Update Changes file Fix typo in README.plugins prepare for 0.31 to be released wednesday git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@564 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 32 ++++++++++++++++++++++++++++---- README.plugins | 2 +- STATUS | 4 +++- lib/Qpsmtpd.pm | 2 +- 4 files changed, 33 insertions(+), 7 deletions(-) diff --git a/Changes b/Changes index f9413f3..c9c409e 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,12 @@ -0.31 - +0.31 - 2005/11/16 + + STARTTLS support (see plugins/tls) + + Added queue/exim-bsmtp plugin to spool accepted mail into an Exim + backend via BSMTP. (Devin Carraway) + + New plugin inheritance system, see the bottom of README.plugins for + more information qpsmtpd-forkserver: --listen-address may now be given more than once, to request listening on multiple local addresses (Devin Carraway) @@ -15,6 +23,23 @@ forkserver will detach from the controlling terminal and daemonize itself (Devin Carraway) + replace some fun smtp comments with boring ones. + + example patterns for badrcptto plugin - Gordon Rowell + + Extend require_resolvable_fromhost to include a configurable list of + "impossible" addresses to combat spammer forging. (Hanno Hecker) + + Use qmail/control/smtpdgreeting if it exists, otherwise + show the original qpsmtpd greeting (with version information). + + Apply slight variation on patch from Peter Holzer to allow specification of + an explicit $QPSMTPD_CONFIG variable to specify where the config lives, + overriding $QMAIL/control and /var/qmail/control if set. The usual + "last location with the file wins" rule still applies. + + Refactor Qpsmtpd::Address + when disconncting with a temporary failure, return 421 rather than 450 or 451. (Peter J. Holzer) @@ -25,11 +50,10 @@ for its config files in the directory given therein, in addition to (and in preference to) other locations. (Peter J. Holzer) - Added queue/exim-bsmtp plugin to spool accepted mail into an Exim - backend via BSMTP. (Devin Carraway) - Updated documentation + Various minor cleanups + 0.30 - 2005/07/05 diff --git a/README.plugins b/README.plugins index 57b7f88..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< plugin_isa > method from the init subroutine. +C< isa_plugin > method from the init subroutine. # rcpt_ok_child sub init { diff --git a/STATUS b/STATUS index 443745f..4616751 100644 --- a/STATUS +++ b/STATUS @@ -10,13 +10,15 @@ pez (or pezmail) Near term roadmap ================= -0.31: +0.32: - Bugfixes - add module requirements to the META.yml file 0.40: - Add user configuration plugin - Add plugin API for checking if a local email address is valid + - use keyword "ESMTPA" in Received header in case of authentication to comply with RFC 3848. + 0.50: Include the popular check_delivery[1] functionality via the 0.30 API diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 9ee6514..1c7cb65 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -5,7 +5,7 @@ use vars qw($VERSION $Logger $TraceLevel $Spool_dir $Size_threshold); use Sys::Hostname; use Qpsmtpd::Constants; -$VERSION = "0.31-dev"; +$VERSION = "0.31"; sub version { $VERSION }; From c3aac1df0f29e58a147889d1d73842e3b4dedbb1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Fri, 18 Nov 2005 09:41:31 +0000 Subject: [PATCH 046/134] r6445@embla: ask | 2005-11-18 01:29:10 -0800 oops, adding missing files to MANIFEST! (thanks Budi Ang) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.31@572 958fd67b-6ff1-0310-b445-bb7760255be9 --- MANIFEST | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/MANIFEST b/MANIFEST index 15ddb19..3b635ef 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,6 +1,8 @@ Changes config.sample/badhelo +config.sample/badrcptto_patterns config.sample/dnsbl_zones +config.sample/invalid_resolvable_fromhost config.sample/IP config.sample/logging config.sample/loglevel @@ -8,6 +10,7 @@ config.sample/plugins config.sample/relayclients config.sample/require_resolvable_fromhost config.sample/rhsbl_zones +config.sample/size_threshold CREDITS lib/Apache/Qpsmtpd.pm lib/Qpsmtpd.pm @@ -56,6 +59,7 @@ plugins/logging/adaptive plugins/logging/devnull plugins/logging/warn plugins/milter +plugins/queue/exim-bsmtp plugins/queue/maildir plugins/queue/postfix-queue plugins/queue/qmail-queue @@ -66,6 +70,7 @@ plugins/require_resolvable_fromhost plugins/rhsbl plugins/sender_permitted_from plugins/spamassassin +plugins/tls plugins/virus/aveclient plugins/virus/bitdefender plugins/virus/check_for_hi_virus From 3197905b4efdb066db10f2e37a632c4f002afc40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Fri, 18 Nov 2005 09:42:45 +0000 Subject: [PATCH 047/134] r6446@embla: ask | 2005-11-18 01:30:05 -0800 rename 0.31 branch to 0.3x git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@573 958fd67b-6ff1-0310-b445-bb7760255be9 From 27975f5cee61ffdc7f8b3e32e7fe934bbce0c0d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Fri, 18 Nov 2005 09:43:01 +0000 Subject: [PATCH 048/134] r6471@embla: ask | 2005-11-18 01:37:48 -0800 version 0.31.1 git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@574 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 6 ++++++ README | 8 ++------ lib/Qpsmtpd.pm | 2 +- 3 files changed, 9 insertions(+), 7 deletions(-) diff --git a/Changes b/Changes index c9c409e..1d9a95d 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,9 @@ +0.31.1 - 2005/11/18 + + Add missing files to the distribution, oops... (Thanks Budi Ang!) + (exim plugin, tls plugin, various sample configuration files) + + 0.31 - 2005/11/16 STARTTLS support (see plugins/tls) diff --git a/README b/README index ae7588d..53c3fc9 100644 --- a/README +++ b/README @@ -57,13 +57,9 @@ run the following command in the /home/smtpd/ directory. svn co http://svn.perl.org/qpsmtpd/trunk . -Or if you want a specific release, use for example +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.30 . - -In the branch L we -have an experimental event based version of qpsmtpd that can handle -thousands of simultaneous connections with very little overhead. + 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. diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 1c7cb65..d16bbfa 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -5,7 +5,7 @@ use vars qw($VERSION $Logger $TraceLevel $Spool_dir $Size_threshold); use Sys::Hostname; use Qpsmtpd::Constants; -$VERSION = "0.31"; +$VERSION = "0.31.1"; sub version { $VERSION }; From c9779a3376e48d6f1cc739d0dbd75889a4f4611a Mon Sep 17 00:00:00 2001 From: John Peacock Date: Sat, 10 Dec 2005 21:11:04 +0000 Subject: [PATCH 049/134] * plugins/virus/clamdscan Use LOGNOTICE instead of LOGERROR when bailing early due to non-multipart message. Test clamd->ping() before scanning, and bail if it doesn't answer (with an appropriate error). Patch submitted by Dave Rolsky . git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@583 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/virus/clamdscan | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 1c35626..f4ee51f 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -118,7 +118,7 @@ sub hook_data_post { unless ( $content_type && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i ) { - $self->log( LOGERROR, "non-multipart mail - skipping" ); + $self->log( LOGNOTICE, "non-multipart mail - skipping" ); return DECLINED; } @@ -153,7 +153,10 @@ sub hook_data_post { $clamd = Clamd->new(); # default unix domain socket } - return (DECLINED) unless $clamd->ping(); + unless ( $clamd->ping() ) { + $self->log( LOGERROR, "Cannot ping clamd server - did you provide the correct clamd port or socket?" ); + return DECLINED; + } if ( my %found = $clamd->scan($filename) ) { my $viruses = join( ",", values(%found) ); From 239daaf55ad2d35c93896ba5bb815193602849ca Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sun, 11 Dec 2005 02:19:43 +0000 Subject: [PATCH 050/134] Drop root privileges before loading plugins, rather than after. This reduces root exposure, and avoids (e.g.) files being created as root which then won't be writable by the normal qpsmtpd user. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@584 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 2d9d35b..3a213a9 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -129,7 +129,6 @@ if ($PID_FILE) { # Load plugins here my $qpsmtpd = Qpsmtpd::TcpServer->new(); -$qpsmtpd->load_plugins; # Drop privileges my (undef, undef, $quid, $qgid) = getpwnam $USER or @@ -138,7 +137,6 @@ my $groups = "$qgid $qgid"; while (my ($name,$passwd,$gid,$members) = getgrent()) { my @m = split(/ /, $members); if (grep {$_ eq $USER} @m) { - ::log(LOGINFO,"$USER is member of group $name($gid)"); $groups .= " $gid"; } } @@ -149,6 +147,8 @@ POSIX::setuid($quid) or die "unable to change uid: $!\n"; $> = $quid; +$qpsmtpd->load_plugins; + ::log(LOGINFO,"Listening on port $PORT"); ::log(LOGINFO, 'Running as user '. (getpwuid($>) || $>) . From bfcd620a83eb9a0f934ee430269abee97e1f77ec Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 5 Jan 2006 02:12:46 +0000 Subject: [PATCH 051/134] Fix problems with tls and relay_client. * lib/Qpsmtpd/Connection.pm Abstract out parameters which can be reused (e.g. TLS) or can be set when creating the Connection object via start(). * plugins/tls Simplify code to use $self->clone() construct and also suppress IO::Socket::SSL debug noise, now that this is working. * plugins/tls_cert New file to automate creating self-signed certificates for TLS. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@597 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Connection.pm | 26 ++++++- plugins/tls | 27 +++----- plugins/tls_cert | 138 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 172 insertions(+), 19 deletions(-) create mode 100755 plugins/tls_cert diff --git a/lib/Qpsmtpd/Connection.pm b/lib/Qpsmtpd/Connection.pm index 8fe3180..8492755 100644 --- a/lib/Qpsmtpd/Connection.pm +++ b/lib/Qpsmtpd/Connection.pm @@ -1,6 +1,20 @@ package Qpsmtpd::Connection; use strict; +# All of these parameters depend only on the physical connection, +# i.e. not on anything sent from the remote machine. Hence, they +# are an appropriate set to use for either start() or clone(). Do +# not add parameters here unless they also meet that criteria. +my @parameters = qw( + remote_host + remote_ip + remote_info + remote_port + local_ip + local_port + relay_client +); + sub new { my $proto = shift; my $class = ref($proto) || $proto; @@ -14,14 +28,22 @@ sub start { my %args = @_; - for my $f (qw(remote_host remote_ip remote_info remote_port - local_ip local_port)) { + foreach my $f ( @parameters ) { $self->$f($args{$f}) if $args{$f}; } return $self; } +sub clone { + my $self = shift; + my $new = $self->new(); + foreach my $f ( @parameters ) { + $new->$f($self->$f()) if $self->$f(); + } + return $new; +} + sub remote_host { my $self = shift; @_ and $self->{_remote_host} = shift; diff --git a/plugins/tls b/plugins/tls index f25a3d2..1c1c2ba 100644 --- a/plugins/tls +++ b/plugins/tls @@ -21,12 +21,16 @@ MAIL FROM onwards. =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) = @_; - $cert ||= 'ssl/cert.pem'; - $key ||= 'ssl/privkey.pem'; + $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; + } $self->tls_cert($cert); $self->tls_key($key); @@ -92,19 +96,8 @@ sub hook_unrecognized_command { SSL_reuse_ctx => $self->ssl_context, ) or die "Could not create SSL socket: $!"; - my $conn = $self->connection; - # Create a new connection object with subset of information collected thus far - $self->qp->connection(Qpsmtpd::Connection->new( - map { $_ => $conn->$_ } - qw( - local_ip - local_port - remote_ip - remote_port - remote_host - remote_info - ), - )); + # 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); @@ -116,7 +109,7 @@ sub hook_unrecognized_command { return DENY, "TLS Negotiation Failed"; } - warn("TLS setup returning\n"); + $self->log(LOGWARN, "TLS setup returning"); return DONE; } diff --git a/plugins/tls_cert b/plugins/tls_cert new file mode 100755 index 0000000..51c83d2 --- /dev/null +++ b/plugins/tls_cert @@ -0,0 +1,138 @@ +#!/usr/bin/perl -w +# Very basic script to create TLS certificates for qpsmtpd +use File::Temp qw/ tempfile tempdir /; +use Getopt::Long; + +my %opts = (); +chomp (my $hostname = `hostname --fqdn`); +my %defaults = ( + C => 'XY', + ST => 'unknown', + L => 'unknown', + O => 'QSMTPD', + OU => 'Server', + CN => $hostname, +); + +GetOptions(\%opts, + 'C|Country:s', + 'ST|State:s', + 'L|Locality|City:s', + 'O|Organization:s', + 'OU|OrganizationalUnit|U:s', + 'CN|CommonName|N:s', + 'emailAddress|email|E:s', + 'help|H', +); + +usage() if $opts{help}; + +# initialize defaults +foreach my $key ( keys %defaults ) { + $opts{$key} = $defaults{$key} unless $opts{$key} +} +$opts{emailAddress} = 'postmaster@'.$opts{CN}; + +mkdir('ssl') unless -d 'ssl'; + +my $CA_key = 'ssl/qpsmtpd-ca.key'; +my $CA_crt = 'ssl/qpsmtpd-ca.crt'; +my $CA_serial = 'ssl/.cert.serial'; + +my ($CA, $CAfilename) = tempfile( $template, DIR => "ssl", UNLINK => 1); + +print ${CA} return_cfg('CA'); +close ${CA}; + +system('openssl', 'genrsa', '-out', $CA_key, 2048) == 0 + or die "Cannot create CA key: $?"; + +system('openssl', 'req', '-config', $CAfilename, '-new', '-x509', + '-days', (365*6), '-key', $CA_key, + '-out', $CA_crt) == 0 + or die "Cannot create CA cert: $?"; + +my $SERVER_key = 'ssl/qpsmtpd-server.key'; +my $SERVER_csr = 'ssl/qpsmtpd-server.csr'; +my $SERVER_crt = 'ssl/qpsmtpd-server.crt'; + +my ($SERVER, $SERVERfilename) = tempfile( $template, DIR => "ssl", UNLINK => 1); +print ${SERVER} return_cfg($opts{OU}); +close ${SERVER}; + +system('openssl', 'genrsa', '-out', $SERVER_key, 1024) == 0 + or die "Cannot create server key: $?"; + +system('openssl', 'req', '-config', $SERVERfilename, '-new', + '-key', $SERVER_key, '-out', $SERVER_csr) == 0 + or die "Cannot create CA cert: $?"; + +my ($SIGN, $SIGNfilename) = tempfile( $template, DIR => "ssl", UNLINK => 1); +print ${SIGN} <<"EOT"; +extensions = x509v3 +[ x509v3 ] +subjectAltName = email:copy +nsComment = tls certificate +nsCertType = server +EOT +close ${SIGN}; + +open my $SERIAL, '>', $CA_serial; +print ${SERIAL} "01\n"; +close ${SERIAL}; + +system('openssl', 'x509', '-extfile', $SIGNfilename, '-days', (365*2), + '-CAserial', $CA_serial, '-CA', $CA_crt, + '-CAkey', $CA_key, '-in', $SERVER_csr, + '-req', '-out', $SERVER_crt) == 0 + or die "Cannot sign cert: $?"; + +exit(0); + +sub return_cfg { + my $OU = shift; + my $RANDOM = int(rand(1000)).'RAN'.int(rand(1000)).'DOM'; + my $cfg = <<"EOT"; +[ req ] +default_bits = 1024 +default_keyfile = keyfile.pem +distinguished_name = req_distinguished_name +attributes = req_attributes +prompt = no +output_password = mypass + +[ req_distinguished_name ] +C = $opts{C} +ST = $opts{ST} +L = $opts{L} +O = $opts{O} +OU = $OU +CN = $opts{CN} +emailAddress = $opts{emailAddress} + +[ req_attributes ] +challengePassword = $RANDOM challenge password +EOT + return $cfg; +} + +sub usage { + print STDERR <<"EOT"; + + $0 will generate a TLS certificate "the quick way", + i.e. without interaction. You can change some defaults however. + + These options are recognized: Default: + + --C Country (two letters, e.g. DE) $defaults{C} + --ST State (spelled out) $defaults{ST} + --L City $defaults{L} + --O Organization $defaults{O} + --OU Organizational Unit $defaults{OU} + --CN Common name $defaults{CN} + --email Email address of postmaster postmaster\@CN + --help Show usage + +EOT + exit(1); +} From c0920346e5739c004bf7400d2984588b72546c3a Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 11 Jan 2006 16:21:08 +0000 Subject: [PATCH 052/134] the pre-connection and post-connection hooks are not working in qpsmtpd-forkserver. This patch merges Peter's patch (with the possibilty to DENY/DENSOFT the connection) and my first attempt. The --max-from-ip check was moved from core to the hosts_allow plugin. Patch by: Hanno Hecker git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@599 958fd67b-6ff1-0310-b445-bb7760255be9 --- config.sample/plugins | 6 +++++ lib/Qpsmtpd/TcpServer.pm | 1 + qpsmtpd-forkserver | 54 ++++++++++++++++++++++++++++------------ 3 files changed, 45 insertions(+), 16 deletions(-) diff --git a/config.sample/plugins b/config.sample/plugins index 91e8e9b..0c170ec 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -6,6 +6,12 @@ # 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 + quit_fortune check_earlytalker diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index 46022d7..86bc5bd 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -84,6 +84,7 @@ sub disconnect { my $self = shift; $self->log(LOGDEBUG,"click, disconnecting"); $self->SUPER::disconnect(@_); + $self->run_hooks("post-connection"); exit; } diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 3a213a9..8eb2be6 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -192,23 +192,34 @@ while (1) { } 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 $localsockaddr = getsockname($client); + my ($lport, $laddr) = sockaddr_in($localsockaddr); + + 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 %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 @@ -231,8 +242,6 @@ while (1) { ::log(LOGINFO, "Connection Timed Out"); exit; }; - my $localsockaddr = getsockname($client); - my ($lport, $laddr) = sockaddr_in($localsockaddr); $ENV{TCPLOCALIP} = inet_ntoa($laddr); # my ($port, $iaddr) = sockaddr_in($hisaddr); $ENV{TCPREMOTEIP} = inet_ntoa($iaddr); @@ -256,6 +265,7 @@ while (1) { ); $qpsmtpd->run(); + $qpsmtpd->run_hooks("post-connection"); exit; # child leaves } } @@ -265,6 +275,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 { From d228f9c11d58c736c31cd07ab3852b14ccd17b2f Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 11 Jan 2006 16:48:08 +0000 Subject: [PATCH 053/134] this patch enables the configurable flags for the postfix-queue plugin. By default no flags are set (old behaviour). Known flags for cleanup are FLAG_FILTER, FLAG_BCC_OK and FLAG_MAP_OK, see POD for details. Patch by: Hanno Hecker git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@600 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Postfix.pm | 2 +- plugins/queue/postfix-queue | 84 ++++++++++++++++++++++++++++++------- 2 files changed, 69 insertions(+), 17 deletions(-) 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/plugins/queue/postfix-queue b/plugins/queue/postfix-queue index db7259e..03a0244 100644 --- a/plugins/queue/postfix-queue +++ b/plugins/queue/postfix-queue @@ -1,3 +1,4 @@ + =head1 NAME postfix-queue @@ -8,37 +9,88 @@ 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. +Known flags are: + +=over 3 + +=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. + +=back =cut use Qpsmtpd::Postfix; +# +# postfix' cleanup flags: +use constant CLEANUP_FLAG_FILTER => (1 << 1); # /* Enable content filter */ +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 */ + 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->{_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 ($_ eq 'FLAG_FILTER') { + $self->{_queue_flags} |= CLEANUP_FLAG_FILTER; + } + elsif ($_ eq 'FLAG_BCC_OK') { + $self->{_queue_flags} |= CLEANUP_FLAG_BCC_OK; + } + elsif ($_ eq 'FLAG_MAP_OK') { + $self->{_queue_flags} |= CLEANUP_FLAG_MAP_OK; + } + + 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); + $status and return (DECLINED, "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 From 5c2c8455d5ad73573373930abb9e74a9fdcb2b22 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 11 Jan 2006 17:03:45 +0000 Subject: [PATCH 054/134] Oops! Neglected to add this. Should have been part of r599. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@601 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/hosts_allow | 80 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 80 insertions(+) create mode 100644 plugins/hosts_allow 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 From 1d0f889d3c6aef2758446debde6e0d7bb0c838d1 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 25 Jan 2006 02:59:31 +0000 Subject: [PATCH 055/134] Support for RFC 1893 - Enhanced Mail System Status Codes Patch by Hanno Hecker . Adds the RFC 1893 status codes to the messages which are returned to the sending client. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@602 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/DSN.pm | 621 ++++++++++++++++++++++++++++ plugins/check_badrcptto | 5 +- plugins/check_loop | 6 +- plugins/rcpt_ok | 5 +- plugins/require_resolvable_fromhost | 25 +- plugins/spamassassin | 4 +- 6 files changed, 651 insertions(+), 15 deletions(-) create mode 100644 lib/Qpsmtpd/DSN.pm 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/plugins/check_badrcptto b/plugins/check_badrcptto index fb57e9e..b23ff43 100644 --- a/plugins/check_badrcptto +++ b/plugins/check_badrcptto @@ -1,4 +1,5 @@ # this plugin checks the badrcptto config (like badmailfrom for rcpt address) +use Qpsmtpd::DSN; sub hook_rcpt { my ($self, $transaction, $recipient) = @_; @@ -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_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/rcpt_ok b/plugins/rcpt_ok index aa547e7..56b3a61 100644 --- a/plugins/rcpt_ok +++ b/plugins/rcpt_ok @@ -2,6 +2,7 @@ # # It should be configured to be run _LAST_! # +use Qpsmtpd::DSN; sub hook_rcpt { my ($self, $transaction, $recipient) = @_; @@ -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/require_resolvable_fromhost b/plugins/require_resolvable_fromhost index d056460..3f1a82f 100644 --- a/plugins/require_resolvable_fromhost +++ b/plugins/require_resolvable_fromhost @@ -1,3 +1,4 @@ +use Qpsmtpd::DSN; use Net::DNS qw(mx); use Socket; @@ -17,15 +18,21 @@ sub hook_mail { } } - $sender->format ne "<>" - and $self->qp->config("require_resolvable_fromhost") - and !$self->check_dns($sender->host) - and return (DENYSOFT, - ($sender->host - ? "Could not resolve ". $sender->host - : "FQDN required in the envelope sender")); - - return DECLINED; + 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; } diff --git a/plugins/spamassassin b/plugins/spamassassin index 96360c4..09fc796 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -71,6 +71,7 @@ Make the "subject munge string" configurable =cut +use Qpsmtpd::DSN; use Socket qw(:DEFAULT :crlf); use IO::Handle; @@ -225,7 +226,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"); From a67b39e28242b145eec54aca56c3a153f368bc69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Wed, 25 Jan 2006 07:12:34 +0000 Subject: [PATCH 056/134] r4215@g5: ask | 2006-01-24 23:11:01 -0800 From: gordonr@gormand.com.au Subject: Re: Submitting plugins (was Re: New plugin: denybounce) Date: January 24, 2006 9:02:35 PM PST To: ask@develooper.com Cc: gavin@openfusion.com.au, qpsmtpd@perl.org Message-Id: <43D7066B.3050106@gormand.com.au> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Ask Bjørn Hansen wrote: On Jan 24, 2006, at 1:08 PM, Gordon Rowell wrote: - License statement - either as per qpsmtpd or as per Perl or similar open license No, it really should be MIT licensed ("as per qpsmtpd") to go in the distribution. There are a few exceptions (only your plugins at a cursory glance), but those are mistakes. :-) I don't have an issue with my qpsmtpd plugins being changed to state: =head1 AUTHOR Copyright 2005 Gordon Rowell This software is free software and may be distributed under the same terms as qpsmtpd itself. Though as a distro maintainer, we do have a sizeable issue with license proliferation. It really is a bit of a nightmare when two licenses are almost, but not completely, the same. Thanks, Gordon r4216@g5: ask | 2006-01-24 23:12:21 -0800 merge license fix from trunk git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@603 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/auth/auth_cvm_unix_local | 4 ++-- plugins/check_badrcptto_patterns | 4 ++-- plugins/check_norelay | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/auth/auth_cvm_unix_local b/plugins/auth/auth_cvm_unix_local index dc4c7b7..4c9f460 100644 --- a/plugins/auth/auth_cvm_unix_local +++ b/plugins/auth/auth_cvm_unix_local @@ -31,8 +31,8 @@ Credential Validation Module (http://untroubled.org/cvm). Copyright 2005 Gordon Rowell -This software is free software and may be distributed or modified -under the same terms as Perl itself. +This software is free software and may be distributed under the same +terms as qpsmtpd itself. =head1 VERSION diff --git a/plugins/check_badrcptto_patterns b/plugins/check_badrcptto_patterns index 7b82945..c551bab 100644 --- a/plugins/check_badrcptto_patterns +++ b/plugins/check_badrcptto_patterns @@ -21,8 +21,8 @@ to the left and right of the @. Copyright 2005 Gordon Rowell -This software is free software and may be distributed under the same -terms as Perl itself. +This software is free software and may be distributed under the same +terms as qpsmtpd itself. =cut diff --git a/plugins/check_norelay b/plugins/check_norelay index 8c99aa2..08e37c3 100644 --- a/plugins/check_norelay +++ b/plugins/check_norelay @@ -30,7 +30,7 @@ Based on check_relay plugin from the qpsmtpd distribution. Copyright 2005 Gordon Rowell This software is free software and may be distributed under the same -terms as Perl itself. +terms as qpsmtpd itself. =cut From 0f5d72035929daf79b7c5b30eb3bc48b3c013f03 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 25 Jan 2006 14:50:47 +0000 Subject: [PATCH 057/134] Add explicit SSL_ca_file parameter to calls to create the SSL session. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@604 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/tls | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/plugins/tls b/plugins/tls index 1c1c2ba..ca456b8 100644 --- a/plugins/tls +++ b/plugins/tls @@ -8,7 +8,7 @@ tls - plugin to support STARTTLS # in config/plugins - tls ssl/cert.pem ssl/privkey.pem + tls ssl/cert.pem ssl/privkey.pem ssl/ca.pem =head1 DESCRIPTION @@ -19,26 +19,34 @@ 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. + =cut 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); 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_ca_file => $self->tls_ca, SSL_cipher_list => 'HIGH', SSL_server => 1 ) or die "Could not create SSL context: $!"; @@ -91,6 +99,7 @@ sub hook_unrecognized_command { 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 => 'HIGH', SSL_server => 1, SSL_reuse_ctx => $self->ssl_context, @@ -130,6 +139,12 @@ sub tls_key { $self->{_tls_key}; } +sub tls_ca { + my $self = shift; + @_ and $self->{_tls_ca} = shift; + $self->{_tls_ca}; +} + sub ssl_context { my $self = shift; @_ and $self->{_ssl_ctx} = shift; From ffd453d0126b93cad09b52e4793c838d1bf41e79 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Thu, 2 Feb 2006 08:46:49 +0000 Subject: [PATCH 058/134] Import file & syslog log plugins. File plugins include strftime(3) formatting and unique session naming support based roughly on patch from pjh. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@609 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 8 ++ plugins/logging/file | 267 +++++++++++++++++++++++++++++++++++++++++ plugins/logging/syslog | 166 +++++++++++++++++++++++++ 3 files changed, 441 insertions(+) create mode 100644 plugins/logging/file create mode 100644 plugins/logging/syslog diff --git a/Changes b/Changes index 1d9a95d..51a50a8 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,11 @@ +0.32 - + + 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) + 0.31.1 - 2005/11/18 Add missing files to the distribution, oops... (Thanks Budi Ang!) 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..1fb3899 --- /dev/null +++ b/plugins/logging/syslog @@ -0,0 +1,166 @@ +#!/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] + +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. + +=back + +=head1 AUTHOR + +Devin Carraway + +=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; + +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; + } + + 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 From 16b2a9c76669206b546c3c31b8ddb93087cc1e32 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Sun, 5 Feb 2006 01:28:44 +0000 Subject: [PATCH 059/134] Correct minor cut/paste error git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@610 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/tls_cert | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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"; From 6f145149ae2fef8c556890e9dbee94bc264dffe4 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Tue, 7 Feb 2006 02:03:00 +0000 Subject: [PATCH 060/134] Apparently, I never tested TLS and AUTH at the same time. It turns out that you have to explicitely read from in order for IO::Socket::SSL to correctly translate the data (i.e. reading from <> isn't sufficient). git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@612 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Auth.pm | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm index 3bb2c86..0389004 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/lib/Qpsmtpd/Auth.pm @@ -236,7 +236,7 @@ sub SASL { if ( $mechanism eq "plain" ) { if (!$prekey) { $session->respond( 334, "Please continue" ); - $prekey= <>; + $prekey= ; } ( $passHash, $user, $passClear ) = split /\x0/, decode_base64($prekey); @@ -250,7 +250,7 @@ sub SASL { else { $session->respond(334, e64("Username:")); - $user = decode_base64(<>); + $user = decode_base64(); #warn("Debug: User: '$user'"); if ($user eq '*') { $session->respond(501, "Authentification canceled"); @@ -258,7 +258,7 @@ sub SASL { } $session->respond(334, e64("Password:")); - $passClear = <>; + $passClear = ; $passClear = decode_base64($passClear); #warn("Debug: Pass: '$pass'"); if ($passClear eq '*') { @@ -277,9 +277,7 @@ sub SASL { # We send the ticket encoded in Base64 $session->respond( 334, encode_base64( $ticket, "" ) ); - my $line = <>; - chop($line); - chop($line); + my $line = ; if ( $line eq '*' ) { $session->respond( 501, "Authentification canceled" ); @@ -287,7 +285,6 @@ sub SASL { } ( $user, $passHash ) = split( ' ', decode_base64($line) ); - } else { $session->respond( 500, "Unrecognized authentification mechanism" ); From 3361b73e50d50667db2d93c54a1f729b7c5dbaf7 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Tue, 7 Feb 2006 11:14:04 +0000 Subject: [PATCH 061/134] Document changes to branch in preparation for releasing 0.32 git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@613 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/Changes b/Changes index 51a50a8..cd5ce42 100644 --- a/Changes +++ b/Changes @@ -6,6 +6,20 @@ 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 Qpsmtpd::Auth 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). + 0.31.1 - 2005/11/18 Add missing files to the distribution, oops... (Thanks Budi Ang!) From 3574e75cd1de72541f95d04fadf5be2e1673b67a Mon Sep 17 00:00:00 2001 From: John Peacock Date: Tue, 7 Feb 2006 18:42:16 +0000 Subject: [PATCH 062/134] Better handling of <> in address comparisons git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@614 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Address.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index 6a8f28a..9d68c7c 100644 --- a/lib/Qpsmtpd/Address.pm +++ b/lib/Qpsmtpd/Address.pm @@ -308,8 +308,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); From d8d7b7a407d7d9ae84edf22572231cf46160f7a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Fri, 17 Feb 2006 19:02:02 +0000 Subject: [PATCH 063/134] r4445@g5: ask | 2006-02-17 11:00:12 -0800 prepare for 0.32 -- plan release for next thursday r4446@g5: ask | 2006-02-17 11:00:48 -0800 tag 0.32rc1 git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@615 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 11 +++++++++-- lib/Qpsmtpd.pm | 2 +- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/Changes b/Changes index cd5ce42..8f0954b 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,4 @@ -0.32 - +0.32 - 2006/02/23 Add logging/file plugin for simple logging to a file (Devin Carraway and Peter J. Holzer). @@ -11,7 +11,7 @@ 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 Qpsmtpd::Auth to work + 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 @@ -20,6 +20,13 @@ 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 Add missing files to the distribution, oops... (Thanks Budi Ang!) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index d16bbfa..a974458 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -5,7 +5,7 @@ use vars qw($VERSION $Logger $TraceLevel $Spool_dir $Size_threshold); use Sys::Hostname; use Qpsmtpd::Constants; -$VERSION = "0.31.1"; +$VERSION = "0.32"; sub version { $VERSION }; From 3a1ad02b663f12381b9fba31c9f24163dbb4886a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Fri, 17 Feb 2006 19:04:52 +0000 Subject: [PATCH 064/134] r4448@g5: ask | 2006-02-17 11:04:44 -0800 update license year git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@616 958fd67b-6ff1-0310-b445-bb7760255be9 --- LICENSE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/LICENSE b/LICENSE index 7856ad1..cc7a68a 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (C) 2001-2005 Ask Bjoern Hansen, Develooper LLC +Copyright (C) 2001-2006 Ask Bjoern Hansen, Develooper LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in From af79e2ffa2ba809181b20985750ec22b90d281d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Sun, 26 Feb 2006 12:22:16 +0000 Subject: [PATCH 065/134] r4516@g5: ask | 2006-02-26 05:02:30 -0800 change release date to today r4517@g5: ask | 2006-02-26 05:03:34 -0800 tag 0.32 git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@618 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Changes b/Changes index 8f0954b..98d0241 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,4 @@ -0.32 - 2006/02/23 +0.32 - 2006/02/26 Add logging/file plugin for simple logging to a file (Devin Carraway and Peter J. Holzer). From 351f0b7f7f836dd6d92e6bcf66516900b01a0465 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Mon, 27 Feb 2006 21:43:00 +0000 Subject: [PATCH 066/134] r4521@g5: ask | 2006-02-27 13:41:09 -0800 set the version to 0.33-dev git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@620 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index a974458..f294ca3 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -5,7 +5,7 @@ use vars qw($VERSION $Logger $TraceLevel $Spool_dir $Size_threshold); use Sys::Hostname; use Qpsmtpd::Constants; -$VERSION = "0.32"; +$VERSION = "0.33-dev"; sub version { $VERSION }; From 00a73023c8100d3c80aed72c3c6d808228b51411 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Mon, 27 Feb 2006 21:43:04 +0000 Subject: [PATCH 067/134] r4522@g5: ask | 2006-02-27 13:41:42 -0800 Make the clamdscan plugin temporarily deny mail if if can't talk to clamd (Filippo Carletti) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@621 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 6 ++++++ plugins/virus/clamdscan | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/Changes b/Changes index 98d0241..acf5463 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,9 @@ +0.33 + + Make the clamdscan plugin temporarily deny mail if if can't talk to clamd + (Filippo Carletti) + + 0.32 - 2006/02/26 Add logging/file plugin for simple logging to a file (Devin Carraway and diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index f4ee51f..80a49d3 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -155,7 +155,7 @@ 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; + return DENYSOFT; } if ( my %found = $clamd->scan($filename) ) { From 3f8ab06a36f638c7d5b118e07304c58f8722e99b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Mon, 27 Feb 2006 21:43:08 +0000 Subject: [PATCH 068/134] r4523@g5: ask | 2006-02-27 13:42:54 -0800 Improve Qpsmtpd::Transaction documentation (Fred Moyer) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@622 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 2 ++ lib/Qpsmtpd/Connection.pm | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/Changes b/Changes index acf5463..99bab6b 100644 --- a/Changes +++ b/Changes @@ -3,6 +3,8 @@ 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 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 From a07ed2ca77a6d667b84ac7e36c48c02bcb3f4a83 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Tue, 28 Feb 2006 07:04:52 +0000 Subject: [PATCH 069/134] Oops. Don't emit a newline between header and body when queueing over bsmtp, because the body itself already contains one. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@623 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 3 +++ plugins/queue/exim-bsmtp | 3 +-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Changes b/Changes index 99bab6b..74b9deb 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ 0.33 + 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) 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/^\./../; From 2c683f22efdb666097c18ab6f6a27ce8ee675627 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Tue, 28 Feb 2006 21:10:11 +0000 Subject: [PATCH 070/134] Implement multiple IP:PORT listen in forkserver (Devin Carraway). Add support in plugins/tls to use SMTPS (John Peacock). git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@624 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/tls | 38 +++++++++++++++++++++++++++++++------- qpsmtpd-forkserver | 14 ++++++++------ 2 files changed, 39 insertions(+), 13 deletions(-) diff --git a/plugins/tls b/plugins/tls index ca456b8..4a3d00f 100644 --- a/plugins/tls +++ b/plugins/tls @@ -93,6 +93,33 @@ sub hook_unrecognized_command { # OK, now we setup TLS $self->qp->respond (220, "Go ahead with TLS"); + 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); + return DENY, "TLS Negotiation Failed"; + } + + $self->log(LOGWARN, "TLS setup returning"); + 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), '+>', @@ -112,14 +139,11 @@ sub hook_unrecognized_command { $self->connection->notes('tls_enabled', 1); }; if ($@) { - # SSL setup failed. Now we must respond to every command with 5XX - warn("TLS failed: $@\n"); - $transaction->notes('ssl_failed', 1); - return DENY, "TLS Negotiation Failed"; + return 0; + } + else { + return 1; } - - $self->log(LOGWARN, "TLS setup returning"); - return DONE; } sub can_do_tls { diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 8eb2be6..f2cfb4a 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -56,8 +56,8 @@ GetOptions('h|help' => \&usage, if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &usage } @LOCALADDR = ( '0.0.0.0' ) if !@LOCALADDR; for (0..$#LOCALADDR) { - if ($LOCALADDR[$_] =~ /^([\d\w\-.]+)$/) { - $LOCALADDR[$_] = $1; + if ($LOCALADDR[$_] =~ /^([\d\w\-.]+)(?::(\d+))?$/) { + $LOCALADDR[$_] = { 'addr' => $1, 'port' => $2 || $PORT }; } else { &usage; } @@ -94,13 +94,13 @@ my $select = new IO::Select; # establish SERVER socket(s), bind and listen. for my $listen_addr (@LOCALADDR) { - my $server = IO::Socket::INET->new(LocalPort => $PORT, - LocalAddr => $listen_addr, + my $server = IO::Socket::INET->new(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"; + or die "Creating TCP socket $listen_addr->{'addr'}:$listen_addr->{'port'}: $!\n"; IO::Handle::blocking($server, 0); $select->add($server); } @@ -149,7 +149,9 @@ $> = $quid; $qpsmtpd->load_plugins; -::log(LOGINFO,"Listening on port $PORT"); +foreach my $local_addr ( @LOCALADDR ) { + ::log(LOGINFO,"Listening on $local_addr->{'addr'}:$local_addr->{'port'}"); +} ::log(LOGINFO, 'Running as user '. (getpwuid($>) || $>) . ', group '. From 4a824a2e7dc735b1d780f7f62942e0bde5afed21 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 1 Mar 2006 16:44:20 +0000 Subject: [PATCH 071/134] Improve support for listening to multiple ports and/or multiple IP addresses. Document using plugins/tls to handle SMTPS (port 465). git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@625 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/tls | 10 +++++++++- qpsmtpd-forkserver | 47 ++++++++++++++++++++++++++++++---------------- 2 files changed, 40 insertions(+), 17 deletions(-) diff --git a/plugins/tls b/plugins/tls index 4a3d00f..4ff9d55 100644 --- a/plugins/tls +++ b/plugins/tls @@ -12,7 +12,15 @@ tls - plugin to support STARTTLS =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 diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index f2cfb4a..b836255 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -19,7 +19,7 @@ $| = 1; # 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 @@ -31,8 +31,9 @@ sub usage { 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 @@ -46,22 +47,36 @@ GetOptions('h|help' => \&usage, 'l|listen-address=s' => \@LOCALADDR, 'c|limit-connections=i' => \$MAXCONN, 'm|max-from-ip=i' => \$MAXCONNIP, - 'p|port=i' => \$PORT, + 'p|port=s' => \@PORT, 'u|user=s' => \$USER, 'pid-file=s' => \$PID_FILE, 'd|detach' => \$DETACH, - ) || &usage; + ) || &usage; # detaint the commandline -if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &usage } @LOCALADDR = ( '0.0.0.0' ) if !@LOCALADDR; +@PORT = ( 2525 ) if !@PORT; + +my @LISTENADDR; for (0..$#LOCALADDR) { if ($LOCALADDR[$_] =~ /^([\d\w\-.]+)(?::(\d+))?$/) { - $LOCALADDR[$_] = { 'addr' => $1, 'port' => $2 || $PORT }; + 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 } @@ -93,7 +108,7 @@ $SIG{TERM} = \&HUNTSMAN; my $select = new IO::Select; # establish SERVER socket(s), bind and listen. -for my $listen_addr (@LOCALADDR) { +for my $listen_addr (@LISTENADDR) { my $server = IO::Socket::INET->new(LocalPort => $listen_addr->{'port'}, LocalAddr => $listen_addr->{'addr'}, Proto => 'tcp', @@ -137,7 +152,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; @@ -149,13 +164,13 @@ $> = $quid; $qpsmtpd->load_plugins; -foreach my $local_addr ( @LOCALADDR ) { - ::log(LOGINFO,"Listening on $local_addr->{'addr'}:$local_addr->{'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: $!"; @@ -225,8 +240,8 @@ while (1) { 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; From 82a32ed558fb7a4167fe68d6fd079a8d7ced5745 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 1 Mar 2006 16:46:55 +0000 Subject: [PATCH 072/134] Automatically disconnect DENY'd server if it doesn't go willingly. Implement queue_pre and queue_post hooks. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@626 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 8 ++++++++ lib/Qpsmtpd/Plugin.pm | 8 +++++--- lib/Qpsmtpd/SMTP.pm | 37 +++++++++++++++++++++++++++++++++---- 3 files changed, 46 insertions(+), 7 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index f294ca3..fd43bbd 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -433,6 +433,14 @@ sub auth_mechanism { my $self = shift; return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" ); } + +sub denied { + my ($self, $value) = @_; + $self->transaction->{_denied} = $value if defined $value; + return (defined $self->transaction->{_denied} + ? $self->transaction->{_denied} + : "" ); +} 1; diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index f7250f7..3cf810b 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -2,11 +2,13 @@ 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 + logging config pre-connection connect ehlo helo auth auth-plain auth-login auth-cram-md5 - connect reset_transaction unrecognized_command disconnect - deny ok pre-connection post-connection + rcpt mail data data_post queue_pre queue queue_post + quit reset_transaction disconnect post-connection + unrecognized_command deny ok ); our %hooks = map { $_ => 1 } @hooks; diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index b24eed7..c5799b2 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -50,6 +50,12 @@ sub dispatch { $self->{_counter}++; + if ( $cmd !~ /^(rset|quit)$/ and $self->denied ) { # RFC non-compliant + $self->log(LOGWARN, "non-RFC compliant MTA disconnected"); + $self->respond(521, "non-RFC compliant MTA disconnected (#5.7.0)"); + $self->disconnect; + } + if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd, @_); if ($rc == DENY_DISCONNECT) { @@ -150,8 +156,10 @@ sub helo { if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { + $self->denied(1); $self->respond(550, $msg); } elsif ($rc == DENYSOFT) { + $self->denied(1); $self->respond(450, $msg); } elsif ($rc == DENY_DISCONNECT) { $self->respond(550, $msg); @@ -178,8 +186,10 @@ sub ehlo { if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { + $self->denied(1); $self->respond(550, $msg); } elsif ($rc == DENYSOFT) { + $self->denied(1); $self->respond(450, $msg); } elsif ($rc == DENY_DISCONNECT) { $self->respond(550, $msg); @@ -290,11 +300,13 @@ sub mail { return 1; } elsif ($rc == DENY) { + $self->denied(1); $msg ||= $from->format . ', denied'; $self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)"); $self->respond(550, $msg); } elsif ($rc == DENYSOFT) { + $self->denied(1); $msg ||= $from->format . ', temporarily denied'; $self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)"); $self->respond(450, $msg); @@ -336,10 +348,12 @@ sub rcpt { return 1; } elsif ($rc == DENY) { + $self->denied(1); $msg ||= 'relaying denied'; $self->respond(550, $msg); } elsif ($rc == DENYSOFT) { + $self->denied(1); $msg ||= 'relaying denied'; return $self->respond(450, $msg); } @@ -558,7 +572,7 @@ sub data { $self->respond(452, $msg || "Message denied temporarily"); } else { - $self->queue($self->transaction); + $self->queue($self->transaction); } # DATA is always the end of a "transaction" @@ -578,7 +592,18 @@ sub getline { sub queue { my ($self, $transaction) = @_; - my ($rc, $msg) = $self->run_hooks("queue"); + # First fire any queue_pre hooks + my ($rc, $msg) = $self->run_hooks("queue_pre"); + if ($rc == DONE) { + return 1; + } + elsif ($rc != OK and $rc != DECLINED) { + return $self->log(LOGERROR, "pre plugin returned illegal value"); + return 0; + } + + # If we got this far, run the queue hooks + ($rc, $msg) = $self->run_hooks("queue"); if ($rc == DONE) { return 1; } @@ -586,16 +611,20 @@ sub queue { $self->respond(250, ($msg || 'Queued')); } elsif ($rc == DENY) { + $self->denied(1); $self->respond(552, $msg || "Message denied"); } elsif ($rc == DENYSOFT) { + $self->denied(1); $self->respond(452, $msg || "Message denied temporarily"); } else { $self->respond(451, $msg || "Queuing declined or disabled; try again later" ); } - - + + # And finally run any queue_post hooks + ($rc, $msg) = $self->run_hooks("queue_post"); + $self->log(LOGERROR, $msg) unless $rc == OK; } From bd19ded5a2e388c2c505d4bdc76eac1f3afa7f46 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 1 Mar 2006 17:25:51 +0000 Subject: [PATCH 073/134] Need to cover situation where there are *no* hooks. Should we actually return OK from run_hooks() in the case where no hooks are there to fire? git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@627 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index c5799b2..52111ec 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -597,7 +597,7 @@ sub queue { if ($rc == DONE) { return 1; } - elsif ($rc != OK and $rc != DECLINED) { + elsif ($rc != OK and $rc != DECLINED and $rc != 0 ) { return $self->log(LOGERROR, "pre plugin returned illegal value"); return 0; } @@ -624,7 +624,7 @@ sub queue { # And finally run any queue_post hooks ($rc, $msg) = $self->run_hooks("queue_post"); - $self->log(LOGERROR, $msg) unless $rc == OK; + $self->log(LOGERROR, $msg) unless ($rc == OK or $rc == 0); } From 3aa64debd8e5141aee6794874f79325d7cd6b1e2 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Mon, 6 Mar 2006 21:33:46 +0000 Subject: [PATCH 074/134] remove way too agressive blocking of DENY'd servers git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@628 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 8 -------- lib/Qpsmtpd/SMTP.pm | 16 ---------------- 2 files changed, 24 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index fd43bbd..f294ca3 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -433,14 +433,6 @@ sub auth_mechanism { my $self = shift; return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" ); } - -sub denied { - my ($self, $value) = @_; - $self->transaction->{_denied} = $value if defined $value; - return (defined $self->transaction->{_denied} - ? $self->transaction->{_denied} - : "" ); -} 1; diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 52111ec..34cf37a 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -50,12 +50,6 @@ sub dispatch { $self->{_counter}++; - if ( $cmd !~ /^(rset|quit)$/ and $self->denied ) { # RFC non-compliant - $self->log(LOGWARN, "non-RFC compliant MTA disconnected"); - $self->respond(521, "non-RFC compliant MTA disconnected (#5.7.0)"); - $self->disconnect; - } - if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd, @_); if ($rc == DENY_DISCONNECT) { @@ -156,10 +150,8 @@ sub helo { if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { - $self->denied(1); $self->respond(550, $msg); } elsif ($rc == DENYSOFT) { - $self->denied(1); $self->respond(450, $msg); } elsif ($rc == DENY_DISCONNECT) { $self->respond(550, $msg); @@ -186,10 +178,8 @@ sub ehlo { if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { - $self->denied(1); $self->respond(550, $msg); } elsif ($rc == DENYSOFT) { - $self->denied(1); $self->respond(450, $msg); } elsif ($rc == DENY_DISCONNECT) { $self->respond(550, $msg); @@ -300,13 +290,11 @@ sub mail { return 1; } elsif ($rc == DENY) { - $self->denied(1); $msg ||= $from->format . ', denied'; $self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)"); $self->respond(550, $msg); } elsif ($rc == DENYSOFT) { - $self->denied(1); $msg ||= $from->format . ', temporarily denied'; $self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)"); $self->respond(450, $msg); @@ -348,12 +336,10 @@ sub rcpt { return 1; } elsif ($rc == DENY) { - $self->denied(1); $msg ||= 'relaying denied'; $self->respond(550, $msg); } elsif ($rc == DENYSOFT) { - $self->denied(1); $msg ||= 'relaying denied'; return $self->respond(450, $msg); } @@ -611,11 +597,9 @@ sub queue { $self->respond(250, ($msg || 'Queued')); } elsif ($rc == DENY) { - $self->denied(1); $self->respond(552, $msg || "Message denied"); } elsif ($rc == DENYSOFT) { - $self->denied(1); $self->respond(452, $msg || "Message denied temporarily"); } else { From 123346f1f53748cd6fd5e8be35e8e087cb0ef5b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Thu, 9 Mar 2006 12:37:25 +0000 Subject: [PATCH 075/134] r4567@g5: ask | 2006-03-09 04:35:43 -0800 move old branches aside git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@629 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/dnsbl | 18 ++++++++++++++++++ plugins/rhsbl | 11 +++++++++++ 2 files changed, 29 insertions(+) diff --git a/plugins/dnsbl b/plugins/dnsbl index 7bed581..7b82221 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -1,5 +1,23 @@ #!perl -w +=head1 NAME + +spamassassin - SpamAssassin integration for qpsmtpd + +=head1 DESCRIPTION + +Plugin that checks if the mail is spam by using the "spamd" daemon +from the SpamAssassin package. F + +SpamAssassin 2.6 or newer is required. + +=head1 CONFIG + +Configured in the config/dnsbl_zones files. One line per zone name, +for example + +=cut + sub register { my ($self, $qp, $denial ) = @_; if ( defined $denial and $denial =~ /^disconnect$/i ) { diff --git a/plugins/rhsbl b/plugins/rhsbl index 4003630..7c7dd79 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -1,4 +1,5 @@ + sub hook_mail { my ($self, $transaction, $sender) = @_; @@ -18,8 +19,14 @@ sub hook_mail { #push(@hosts, $helo) if $helo && $helo ne $sender->host; for my $host (@hosts) { 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"); $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}; } } @@ -80,6 +87,10 @@ sub process_sockets { $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 { From b89a6d9e4cffbf03fe69026d8ec0ec2041d8d22f Mon Sep 17 00:00:00 2001 From: John Peacock Date: Mon, 20 Mar 2006 16:47:05 +0000 Subject: [PATCH 076/134] * plugins/queue/smtp-forward s/register/init/ to match new plugin style (jpeacock) * lib/Qpsmtpd/Address.pm t/qpsmtpd-address.t Ill-formed addresses should return null not partial garbage. Resolves https://rt.perl.org/rt3/Ticket/Display.html?id=38746 Patch by Hanno Hecker. * plugins/virus/clamav Clamav alternate config file. Resolves https://rt.perl.org/rt3/Ticket/Display.html?id=38736 Patch by Robin Bowes. * lib/Qpsmtpd/SMTP.pm lib/Qpsmtpd.pm Return multiline responses from plugins. Resolves https://rt.perl.org/rt3/Ticket/Display.html?id=38741 Patch by Charlie Brady. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@630 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 1 + lib/Qpsmtpd/Address.pm | 3 +- lib/Qpsmtpd/SMTP.pm | 138 +++++++++++++++++++++---------------- plugins/queue/smtp-forward | 2 +- plugins/virus/clamav | 19 ++++- t/qpsmtpd-address.t | 7 +- 6 files changed, 103 insertions(+), 67 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index f294ca3..a7ae15e 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -348,6 +348,7 @@ sub run_hooks { last unless $r[0] == DECLINED; } $r[0] = DECLINED if not defined $r[0]; + @r = map { split /\n/ } @r; return @r; } return (0, ''); diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index 9d68c7c..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; diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 34cf37a..5b350ac 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -51,13 +51,14 @@ sub dispatch { $self->{_counter}++; if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { - my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd, @_); + my ($rc, @msg) = $self->run_hooks("unrecognized_command", $cmd, @_); + @msg = map { split /\n/ } @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) { 1; @@ -91,13 +92,15 @@ 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"); + my ($rc, @msg) = $self->run_hooks("connect"); if ($rc == DENY) { - $self->respond(550, ($msg || 'Connection from you denied, bye bye.')); + $msg[0] ||= 'Connection from you denied, bye bye.'; + $self->respond(550, @msg); return $rc; } elsif ($rc == DENYSOFT) { - $self->respond(450, ($msg || 'Connection from you temporarily denied, bye bye.')); + $msg[0] ||= 'Connection from you temporarily denied, bye bye.'; + $self->respond(450, @msg); return $rc; } elsif ($rc == DONE) { @@ -146,18 +149,18 @@ sub helo { 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); + my ($rc, @msg) = $self->run_hooks("helo", $hello_host, @stuff); if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { - $self->respond(550, $msg); + $self->respond(550, @msg); } elsif ($rc == DENYSOFT) { - $self->respond(450, $msg); + $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; } else { $conn->hello("helo"); @@ -174,18 +177,18 @@ sub ehlo { 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); + my ($rc, @msg) = $self->run_hooks("ehlo", $hello_host, @stuff); if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { - $self->respond(550, $msg); + $self->respond(550, @msg); } elsif ($rc == DENYSOFT) { - $self->respond(450, $msg); + $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; } else { $conn->hello("ehlo"); @@ -285,30 +288,30 @@ sub mail { } return $self->respond(501, "could not parse your mail from command") unless $from; - my ($rc, $msg) = $self->run_hooks("mail", $from); + my ($rc, @msg) = $self->run_hooks("mail", $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); + $msg[0] ||= $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); + $msg[0] ||= $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); + $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 ||= $from->format . ', temporarily denied'; - $self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)"); - $self->respond(421, $msg); + $msg[0] ||= $from->format . ', temporarily denied'; + $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@msg)"); + $self->respond(421, @msg); $self->disconnect; } else { # includes OK @@ -331,28 +334,28 @@ sub rcpt { return $self->respond(501, "could not parse recipient") unless $rcpt; - my ($rc, $msg) = $self->run_hooks("rcpt", $rcpt); + my ($rc, @msg) = $self->run_hooks("rcpt", $rcpt); 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) { @@ -388,17 +391,19 @@ 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"); + my ($rc, @msg) = $self->run_hooks("vrfy"); 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 @@ -415,9 +420,10 @@ sub rset { sub quit { my $self = shift; - my ($rc, $msg) = $self->run_hooks("quit"); + my ($rc, @msg) = $self->run_hooks("quit"); 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(); } @@ -430,27 +436,31 @@ sub disconnect { sub data { my $self = shift; - my ($rc, $msg) = $self->run_hooks("data"); + my ($rc, @msg) = $self->run_hooks("data"); 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; } @@ -547,15 +557,17 @@ sub data { #$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; - ($rc, $msg) = $self->run_hooks("data_post"); + ($rc, @msg) = $self->run_hooks("data_post"); 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); @@ -579,7 +591,7 @@ sub queue { my ($self, $transaction) = @_; # First fire any queue_pre hooks - my ($rc, $msg) = $self->run_hooks("queue_pre"); + my ($rc, @msg) = $self->run_hooks("queue_pre"); if ($rc == DONE) { return 1; } @@ -589,26 +601,30 @@ sub queue { } # If we got this far, run the queue hooks - ($rc, $msg) = $self->run_hooks("queue"); + ($rc, @msg) = $self->run_hooks("queue"); 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 - ($rc, $msg) = $self->run_hooks("queue_post"); - $self->log(LOGERROR, $msg) unless ($rc == OK or $rc == 0); + ($rc, @msg) = $self->run_hooks("queue_post"); + $self->log(LOGERROR, @msg) unless ($rc == OK or $rc == 0); } 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/virus/clamav b/plugins/virus/clamav index 85a928a..b16d1cb 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. @@ -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"); @@ -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/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"); From 8fcb46177b53dfb33151875e09afb930cf006fb0 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Fri, 7 Apr 2006 18:58:02 +0000 Subject: [PATCH 077/134] Add Qpsmtpd::Command to gather all parsing logic in one place (Hanno Hecker) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@631 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 13 ++- MANIFEST | 1 + config.sample/plugins | 7 ++ lib/Apache/Qpsmtpd.pm | 2 +- lib/Qpsmtpd/Command.pm | 170 ++++++++++++++++++++++++++++ lib/Qpsmtpd/Plugin.pm | 7 +- lib/Qpsmtpd/SMTP.pm | 89 +++++++++++---- lib/Qpsmtpd/SelectServer.pm | 2 +- lib/Qpsmtpd/TcpServer.pm | 2 +- plugins/check_badmailfrom | 4 +- plugins/check_badmailfromto | 4 +- plugins/check_badrcptto | 2 +- plugins/dns_whitelist_soft | 2 +- plugins/dnsbl | 2 +- plugins/dont_require_anglebrackets | 19 ++++ plugins/milter | 4 +- plugins/parse_addr_withhelo | 60 ++++++++++ plugins/rcpt_ok | 2 +- plugins/require_resolvable_fromhost | 2 +- plugins/rhsbl | 6 +- plugins/sender_permitted_from | 4 +- t/addresses.t | 7 ++ 22 files changed, 361 insertions(+), 50 deletions(-) create mode 100644 lib/Qpsmtpd/Command.pm create mode 100644 plugins/dont_require_anglebrackets create mode 100644 plugins/parse_addr_withhelo diff --git a/Changes b/Changes index 74b9deb..37c2a82 100644 --- a/Changes +++ b/Changes @@ -1,12 +1,15 @@ 0.33 - Fix a spurious newline at the start of messages queued via exim (Devin - Carraway) + Add Qpsmtpd::Command to gather all parsing logic in one place (Hanno + Hecker) - Make the clamdscan plugin temporarily deny mail if if can't talk to clamd - (Filippo Carletti) + Fix a spurious newline at the start of messages queued via exim (Devin + Carraway) - Improve Qpsmtpd::Transaction documentation (Fred Moyer) + 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 diff --git a/MANIFEST b/MANIFEST index 3b635ef..e71a6e7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -16,6 +16,7 @@ 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 diff --git a/config.sample/plugins b/config.sample/plugins index 0c170ec..1d6b180 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -12,6 +12,13 @@ # 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/lib/Apache/Qpsmtpd.pm b/lib/Apache/Qpsmtpd.pm index 4808241..f675e2e 100644 --- a/lib/Apache/Qpsmtpd.pm +++ b/lib/Apache/Qpsmtpd.pm @@ -131,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/Qpsmtpd/Command.pm b/lib/Qpsmtpd/Command.pm new file mode 100644 index 0000000..dddb7ae --- /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 $1; + 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/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 3cf810b..5947b77 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -4,9 +4,10 @@ use strict; # more or less in the order they will fire our @hooks = qw( - logging config pre-connection connect ehlo helo - auth auth-plain auth-login auth-cram-md5 - rcpt mail data data_post queue_pre queue queue_post + 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 ); diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 5b350ac..6c794c2 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -12,6 +12,7 @@ use Qpsmtpd::Plugin; use Qpsmtpd::Constants; use Qpsmtpd::Auth; use Qpsmtpd::Address (); +use Qpsmtpd::Command; use Mail::Header (); #use Data::Dumper; @@ -143,13 +144,16 @@ sub connection { 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); + ($rc, @msg) = $self->run_hooks("helo", $hello_host, @stuff); if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { @@ -171,13 +175,15 @@ sub helo { } 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); + ($rc, @msg) = $self->run_hooks("ehlo", $hello_host, @stuff); if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { @@ -229,7 +235,12 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { } sub auth { - my ( $self, $arg, @stuff ) = @_; + my ($self, $line) = @_; + my ($rc, $sub) = $self->run_hooks('auth_parse'); + my ($ok, $arg, @stuff) = Qpsmtpd::Command->parse('auth', $line, $sub); + return $self->respond(501, $arg || "Syntax error in command") + unless ($ok == OK); + #they AUTH'd once already return $self->respond( 503, "but you already said AUTH ..." ) @@ -242,9 +253,7 @@ sub auth { } 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 @@ -269,16 +278,29 @@ sub mail { return $self->respond(503, "please say hello first ..."); } else { - 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(LOGINFO, "full from_parameter: $line"); + my ($rc, @msg) = $self->run_hooks("mail_parse"); + 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() + ($rc, @msg) = $self->run_hooks("mail_pre", $from); + 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("<>"); @@ -288,7 +310,7 @@ sub mail { } return $self->respond(501, "could not parse your mail from command") unless $from; - my ($rc, @msg) = $self->run_hooks("mail", $from); + ($rc, @msg) = $self->run_hooks("mail", $from, %param); if ($rc == DONE) { return 1; } @@ -323,18 +345,39 @@ sub mail { } sub rcpt { - my $self = shift; - return $self->respond(501, "syntax error in parameters") unless $_[0] and $_[0] =~ m/^to:/i; + my ($self, $line) = @_; + my ($rc, @msg) = $self->run_hooks("rcpt_parse"); + 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... + ($rc, @msg) = $self->run_hooks("rcpt_pre", $rcpt); + 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); + ($rc, @msg) = $self->run_hooks("rcpt", $rcpt, %param); if ($rc == DONE) { return 1; } diff --git a/lib/Qpsmtpd/SelectServer.pm b/lib/Qpsmtpd/SelectServer.pm index 07e5c56..9620785 100644 --- a/lib/Qpsmtpd/SelectServer.pm +++ b/lib/Qpsmtpd/SelectServer.pm @@ -121,7 +121,7 @@ sub main { } else { $qp->log(LOGINFO, "dispatching $req"); - defined $qp->dispatch(split / +/, $req) + defined $qp->dispatch(split / +/, $req, 2) or $qp->respond(502, "command unrecognized: '$req'"); } } diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index 86bc5bd..1378fa3 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -63,7 +63,7 @@ sub read_input { $_ =~ s/\r?\n$//s; # advanced chomp $self->log(LOGDEBUG, "dispatching $_"); $self->connection->notes('original_string', $_); - defined $self->dispatch(split / +/, $_) + defined $self->dispatch(split / +/, $_, 2) or $self->respond(502, "command unrecognized: '$_'"); alarm $timeout; } diff --git a/plugins/check_badmailfrom b/plugins/check_badmailfrom index 46a2542..5030412 100644 --- a/plugins/check_badmailfrom +++ b/plugins/check_badmailfrom @@ -21,7 +21,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); @@ -44,7 +44,7 @@ sub hook_mail { } 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 b23ff43..a99fdb1 100644 --- a/plugins/check_badrcptto +++ b/plugins/check_badrcptto @@ -2,7 +2,7 @@ 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; 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 7b82221..ab42eb5 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -167,7 +167,7 @@ sub process_sockets { } 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 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/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/rcpt_ok b/plugins/rcpt_ok index 56b3a61..a27fa67 100644 --- a/plugins/rcpt_ok +++ b/plugins/rcpt_ok @@ -5,7 +5,7 @@ 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")); diff --git a/plugins/require_resolvable_fromhost b/plugins/require_resolvable_fromhost index 3f1a82f..2886b3f 100644 --- a/plugins/require_resolvable_fromhost +++ b/plugins/require_resolvable_fromhost @@ -5,7 +5,7 @@ use Socket; my %invalid = (); sub hook_mail { - my ($self, $transaction, $sender) = @_; + my ($self, $transaction, $sender, %param) = @_; return DECLINED if ($self->qp->connection->notes('whitelistclient')); diff --git a/plugins/rhsbl b/plugins/rhsbl index 7c7dd79..a9b8e56 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -1,14 +1,14 @@ 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->qp->config('rhsbl_zones'); 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/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'); + From 7c6cbdd000c4b286b587510cde8a13d8f65535eb Mon Sep 17 00:00:00 2001 From: John Peacock Date: Fri, 7 Apr 2006 19:06:39 +0000 Subject: [PATCH 078/134] Move the Qpsmtpd::Auth POD to a top-level README to be more obvious. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@632 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 2 + README.authentication | 217 ++++++++++++++++++++++++++++++++++++++++++ lib/Qpsmtpd/Auth.pm | 216 +---------------------------------------- 3 files changed, 220 insertions(+), 215 deletions(-) create mode 100644 README.authentication diff --git a/Changes b/Changes index 37c2a82..8d3c191 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,7 @@ 0.33 + 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) diff --git a/README.authentication b/README.authentication new file mode 100644 index 0000000..d2cf056 --- /dev/null +++ b/README.authentication @@ -0,0 +1,217 @@ +# +# read this with 'perldoc README.authentication' ... +# + +=head1 NAME + +Authentication framework for qpsmtpd + +=head1 DESCRIPTION + +Provides support for SMTP AUTH within qpsmtpd transactions, see + +L +L + +for more details. + +=head1 USAGE + +This code is automatically loaded by Qpsmtpd::SMTP only if a plugin +providing one of the defined L is loaded. The only +time this can happen is if the client process employs the EHLO command to +initiate the SMTP session. If the client uses HELO, the AUTH command is +not available and this module isn't even loaded. + +=head2 Plugin Design + +An authentication plugin can bind to one or more auth hooks or bind to all +of them at once. See L for more details. + +All plugins must provide two functions: + +=over 4 + +=item * init() + +This is the standard function which is called by qpsmtpd for any plugin +listed in config/plugins. Typically, an auth plugin should register at +least one hook, like this: + + + sub init { + my ($self, $qp) = @_; + + $self->register_hook("auth", "authfunction"); + } + +where in this case "auth" means this plugin expects to support any of +the defined authentication methods. + +=item * authfunction() + +The plugin must provide an authentication function which is part of +the register_hook call. That function will receive the following +six parameters when called: + +=over 4 + +=item $self + +A Qpsmtpd::Plugin object, which can be used, for example, to emit log +entries or to send responses to the remote SMTP client. + +=item $transaction + +A Qpsmtpd::Transaction object which can be used to examine information +about the current SMTP session like the remote IP address. + +=item $mechanism + +The lower-case name of the authentication mechanism requested by the +client; either "plain", "login", or "cram-md5". + +=item $user + +Whatever the remote SMTP client sent to identify the user (may be bare +name or fully qualified e-mail address). + +=item $clearPassword + +If the particular authentication method supports unencrypted passwords +(currently PLAIN and LOGIN), which will be the plaintext password sent +by the remote SMTP client. + +=item $hashPassword + +An encrypted form of the remote user's password, using the MD-5 algorithm +(see also the $ticket parameter). + +=item $ticket + +This is the cryptographic challenge which was sent to the client as part +of a CRAM-MD5 transaction. Since the MD-5 algorithm is one-way, the same +$ticket value must be used on the backend to compare with the encrypted +password sent in $hashPassword. + +=back + +=back + +Plugins should perform whatever checking they want and then return one +of the following values (taken from Qpsmtpd::Constants): + +=over 4 + +=item OK + +If the authentication has succeeded, the plugin can return this value and +all subsequently registered hooks will be skipped. + +=item DECLINED + +If the authentication has failed, but any additional plugins should be run, +this value will be returned. If none of the registered plugins succeed, the +overall authentication will fail. Normally an auth plugin should return +this value for all cases which do not succeed (so that another auth plugin +can have a chance to authenticate the user). + +=item DENY + +If the authentication has failed, and the plugin wishes this to short circuit +any further testing, it should return this value. For example, a plugin could +register the L hook and immediately fail any connection which is +not trusted (e.g. not in the same network). + +Another reason to return DENY over DECLINED would be if the user name matched +an existing account but the password failed to match. This would make a +dictionary-based attack much harder to accomplish. See the included +auth_vpopmail_sql plugin for how this might be accomplished. + +By returning DENY, no further authentication attempts will be made using the +current method and data. A remote SMTP client is free to attempt a second +auth method if the first one fails. + +=back + +Plugins may also return an optional message with the return code, e.g. + + return (DENY, "If you forgot your password, contact your admin"); + +and this will be appended to whatever response is sent to the remote SMTP +client. There is no guarantee that the end user will see this information, +though, since some prominent MTA's (produced by M$oft) I +hide this information under the default configuration. This message will +be logged locally, if appropriate, based on the configured log level. + +=head1 Auth Hooks + +The currently defined authentication methods are: + +=over 4 + +=item * auth-plain + +Any plugin which registers an auth-plain hook will engage in a plaintext +prompted negotiation. This is the least secure authentication method since +both the user name and password are visible in plaintext. Most SMTP clients +will preferentially choose a more secure method if it is advertised by the +server. + +=item * auth-login + +A slightly more secure method where the username and password are Base-64 +encoded before sending. This is still an insecure method, since it is +trivial to decode the Base-64 data. Again, it will not normally be chosen +by SMTP clients unless a more secure method is not available (or if it fails). + +=item * auth-cram-md5 + +A cryptographically secure authentication method which employs a one-way +hashing function to transmit the secret information without significant +risk between the client and server. The server provides a challenge key +L<$ticket>, which the client uses to encrypt the user's password. +Then both user name and password are concatenated and Base-64 encoded before +transmission. + +This hook must normally have access to the user's plaintext password, +since there is no way to extract that information from the transmitted data. +Since the CRAM-MD5 scheme requires that the server send the challenge +L<$ticket> before knowing what user is attempting to log in, there is no way +to use any existing MD5-encrypted password (like is frequently used with MySQL). + +=item * auth + +A catch-all hook which requires that the plugin support all three preceeding +authentication methods. Any plugins registering the auth hook will be run +only after all other plugins registered for the specific authentication +method which was requested. This allows you to move from more specific +plugins to more general plugins (e.g. local accounts first vs replicated +accounts with expensive network access later). + +=back + +=head2 Multiple Hook Behavior + +If more than one hook is registered for a given authentication method, then +they will be tried in the order that they appear in the config/plugins file +unless one of the plugins returns DENY, which will immediately cease all +authentication attempts for this transaction. + +In addition, all plugins that are registered for a specific auth hook will +be tried before any plugins which are registered for the general auth hook. + +=head1 AUTHOR + +John Peacock + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2004-2006 John Peacock + +Portions based on original code by Ask Bjoern Hansen and Guillaume Filion + +This plugin is licensed under the same terms as the qpsmtpd package itself. +Please see the LICENSE file included with qpsmtpd for details. + +=cut diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm index 0389004..3ad3fce 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/lib/Qpsmtpd/Auth.pm @@ -1,218 +1,4 @@ -#!/usr/bin/perl -w - -=head1 NAME - -Qpsmtpd::Auth - Authentication framework for qpsmtpd - -=head1 DESCRIPTION - -Provides support for SMTP AUTH within qpsmtpd transactions, see - -L -L - -for more details. - -=head1 USAGE - -This module is automatically loaded by Qpsmtpd::SMTP only if a plugin -providing one of the defined L is loaded. The only -time this can happen is if the client process employs the EHLO command to -initiate the SMTP session. If the client uses HELO, the AUTH command is -not available and this module isn't even loaded. - -=head2 Plugin Design - -An authentication plugin can bind to one or more auth hooks or bind to all -of them at once. See L for more details. - -All plugins must provide two functions: - -=over 4 - -=item * register() - -This is the standard function which is called by qpsmtpd for any plugin -listed in config/plugins. Typically, an auth plugin should register at -least one hook, like this: - - - sub register { - my ($self, $qp) = @_; - - $self->register_hook("auth", "authfunction"); - } - -where in this case "auth" means this plugin expects to support any of -the defined authentication methods. - -=item * authfunction() - -The plugin must provide an authentication function which is part of -the register_hook call. That function will receive the following -six parameters when called: - -=over 4 - -=item $self - -A Qpsmtpd::Plugin object, which can be used, for example, to emit log -entries or to send responses to the remote SMTP client. - -=item $transaction - -A Qpsmtpd::Transaction object which can be used to examine information -about the current SMTP session like the remote IP address. - -=item $mechanism - -The lower-case name of the authentication mechanism requested by the -client; either "plain", "login", or "cram-md5". - -=item $user - -Whatever the remote SMTP client sent to identify the user (may be bare -name or fully qualified e-mail address). - -=item $clearPassword - -If the particular authentication method supports unencrypted passwords -(currently PLAIN and LOGIN), which will be the plaintext password sent -by the remote SMTP client. - -=item $hashPassword - -An encrypted form of the remote user's password, using the MD-5 algorithm -(see also the $ticket parameter). - -=item $ticket - -This is the cryptographic challenge which was sent to the client as part -of a CRAM-MD5 transaction. Since the MD-5 algorithm is one-way, the same -$ticket value must be used on the backend to compare with the encrypted -password sent in $hashPassword. - -=back - -=back - -Plugins should perform whatever checking they want and then return one -of the following values (taken from Qpsmtpd::Constants): - -=over 4 - -=item OK - -If the authentication has succeeded, the plugin can return this value and -all subsequently registered hooks will be skipped. - -=item DECLINED - -If the authentication has failed, but any additional plugins should be run, -this value will be returned. If none of the registered plugins succeed, the -overall authentication will fail. Normally an auth plugin should return -this value for all cases which do not succeed (so that another auth plugin -can have a chance to authenticate the user). - -=item DENY - -If the authentication has failed, and the plugin wishes this to short circuit -any further testing, it should return this value. For example, a plugin could -register the L hook and immediately fail any connection which is -not trusted (e.g. not in the same network). - -Another reason to return DENY over DECLINED would be if the user name matched -an existing account but the password failed to match. This would make a -dictionary-based attack much harder to accomplish. See the included -auth_vpopmail_sql plugin for how this might be accomplished. - -By returning DENY, no further authentication attempts will be made using the -current method and data. A remote SMTP client is free to attempt a second -auth method if the first one fails. - -=back - -Plugins may also return an optional message with the return code, e.g. - - return (DENY, "If you forgot your password, contact your admin"); - -and this will be appended to whatever response is sent to the remote SMTP -client. There is no guarantee that the end user will see this information, -though, since some prominent MTA's (produced by M$oft) I -hide this information under the default configuration. This message will -be logged locally, if appropriate, based on the configured log level. - -=head1 Auth Hooks - -The currently defined authentication methods are: - -=over 4 - -=item * auth-plain - -Any plugin which registers an auth-plain hook will engage in a plaintext -prompted negotiation. This is the least secure authentication method since -both the user name and password are visible in plaintext. Most SMTP clients -will preferentially choose a more secure method if it is advertised by the -server. - -=item * auth-login - -A slightly more secure method where the username and password are Base-64 -encoded before sending. This is still an insecure method, since it is -trivial to decode the Base-64 data. Again, it will not normally be chosen -by SMTP clients unless a more secure method is not available (or if it fails). - -=item * auth-cram-md5 - -A cryptographically secure authentication method which employs a one-way -hashing function to transmit the secret information without significant -risk between the client and server. The server provides a challenge key -L<$ticket>, which the client uses to encrypt the user's password. -Then both user name and password are concatenated and Base-64 encoded before -transmission. - -This hook must normally have access to the user's plaintext password, -since there is no way to extract that information from the transmitted data. -Since the CRAM-MD5 scheme requires that the server send the challenge -L<$ticket> before knowing what user is attempting to log in, there is no way -to use any existing MD5-encrypted password (like is frequently used with MySQL). - -=item * auth - -A catch-all hook which requires that the plugin support all three preceeding -authentication methods. Any plugins registering the auth hook will be run -only after all other plugins registered for the specific authentication -method which was requested. This allows you to move from more specific -plugins to more general plugins (e.g. local accounts first vs replicated -accounts with expensive network access later). - -=back - -=head2 Multiple Hook Behavior - -If more than one hook is registered for a given authentication method, then -they will be tried in the order that they appear in the config/plugins file -unless one of the plugins returns DENY, which will immediately cease all -authentication attempts for this transaction. - -In addition, all plugins that are registered for a specific auth hook will -be tried before any plugins which are registered for the general auth hook. - -=head1 AUTHOR - -John Peacock - -=head1 COPYRIGHT AND LICENSE - -Copyright (c) 2004 John Peacock - -Portions based on original code by Ask Bjoern Hansen and Guillaume Filion - -This plugin is licensed under the same terms as the qpsmtpd package itself. -Please see the LICENSE file included with qpsmtpd for details. - -=cut +# See the documentation in 'perldoc README.authentication' package Qpsmtpd::Auth; use Qpsmtpd::Constants; From ff4e92bb4ec5e3eb36fc33dfad703f5d9bf468b7 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Fri, 7 Apr 2006 19:21:10 +0000 Subject: [PATCH 079/134] Resolve ticket #38806 (Inadequate validation of authentication data) Charlie Brady. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@633 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Auth.pm | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm index 3ad3fce..6274493 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/lib/Qpsmtpd/Auth.pm @@ -27,11 +27,21 @@ sub SASL { ( $passHash, $user, $passClear ) = split /\x0/, decode_base64($prekey); + unless ($user && $passClear) { + $session->respond(504, "Invalid authentification string"); + return DECLINED; + } } elsif ($mechanism eq "login") { if ( $prekey ) { - ($passHash, $user, $passClear) = split /\x0/, decode_base64($prekey); + ( $passHash, $user, $passClear ) = split /\x0/, + decode_base64($prekey); + + unless ($user && $passClear) { + $session->respond(504, "Invalid authentification string"); + return DECLINED; + } } else { From af93447e788f4fa715365fb47524151ac25cdcf3 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Mon, 24 Apr 2006 15:48:24 +0000 Subject: [PATCH 080/134] Redo AUTH PLAIN and AUTH LOGIN correctly(?) this time. (Michael Holzt) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@634 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Auth.pm | 43 +++++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm index 6274493..692f0b3 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/lib/Qpsmtpd/Auth.pm @@ -16,7 +16,7 @@ sub SASL { # $DB::single = 1; my ( $session, $mechanism, $prekey ) = @_; - my ( $user, $passClear, $passHash, $ticket ); + my ( $user, $passClear, $passHash, $ticket, $loginas ); $mechanism = lc($mechanism); if ( $mechanism eq "plain" ) { @@ -24,43 +24,36 @@ sub SASL { $session->respond( 334, "Please continue" ); $prekey= ; } - ( $passHash, $user, $passClear ) = split /\x0/, + ( $loginas, $user, $passClear ) = split /\x0/, decode_base64($prekey); - - unless ($user && $passClear) { - $session->respond(504, "Invalid authentification string"); + + # Authorization ID must not be different from + # Authentication ID + if ( $loginas ne '' && $loginas != $user ) { + $session->respond(535, "Authentication invalid"); return DECLINED; } } elsif ($mechanism eq "login") { if ( $prekey ) { - ( $passHash, $user, $passClear ) = split /\x0/, - decode_base64($prekey); - - unless ($user && $passClear) { - $session->respond(504, "Invalid authentification string"); - return DECLINED; - } + $user = decode_base64($prekey); } else { - $session->respond(334, e64("Username:")); $user = decode_base64(); - #warn("Debug: User: '$user'"); if ($user eq '*') { $session->respond(501, "Authentification canceled"); return DECLINED; } + } - $session->respond(334, e64("Password:")); - $passClear = ; - $passClear = decode_base64($passClear); - #warn("Debug: Pass: '$pass'"); - if ($passClear 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" ) { @@ -87,6 +80,12 @@ sub SASL { 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, From 401ca8ce6e3d06cc41a23262704dc34e28b0d654 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Tue, 25 Apr 2006 00:08:20 +0000 Subject: [PATCH 081/134] More descriptive POD for tls certificate support (Guillaume Filion). git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@635 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/tls | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/plugins/tls b/plugins/tls index 4ff9d55..8b0e082 100644 --- a/plugins/tls +++ b/plugins/tls @@ -8,7 +8,21 @@ tls - plugin to support STARTTLS # in config/plugins - tls ssl/cert.pem ssl/privkey.pem ssl/ca.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 From 508be70d26e570c29b00dbd23891910d86981cb9 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 26 Apr 2006 15:31:03 +0000 Subject: [PATCH 082/134] ne is for strings, != is for numbers (Leonardo Helman) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@636 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Auth.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm index 692f0b3..d000616 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/lib/Qpsmtpd/Auth.pm @@ -29,7 +29,7 @@ sub SASL { # Authorization ID must not be different from # Authentication ID - if ( $loginas ne '' && $loginas != $user ) { + if ( $loginas ne '' && $loginas ne $user ) { $session->respond(535, "Authentication invalid"); return DECLINED; } From 67dc86e255d982226a98cd3357805ad796b6e671 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 31 May 2006 20:54:03 +0000 Subject: [PATCH 083/134] New pre-forking qpsmtpd daemon, courtesy of Lars Roland at SoftScan. Initial load with minor tweaks by John Peacock. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@639 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP/Prefork.pm | 43 ++ lib/Qpsmtpd/TcpServer/Prefork.pm | 56 +++ qpsmtpd-prefork | 669 +++++++++++++++++++++++++++++++ 3 files changed, 768 insertions(+) create mode 100644 lib/Qpsmtpd/SMTP/Prefork.pm create mode 100644 lib/Qpsmtpd/TcpServer/Prefork.pm create mode 100755 qpsmtpd-prefork diff --git a/lib/Qpsmtpd/SMTP/Prefork.pm b/lib/Qpsmtpd/SMTP/Prefork.pm new file mode 100644 index 0000000..336c2e2 --- /dev/null +++ b/lib/Qpsmtpd/SMTP/Prefork.pm @@ -0,0 +1,43 @@ +package Qpsmtpd::SMTP::Prefork; +use Qpsmtpd::SMTP; +@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/TcpServer/Prefork.pm b/lib/Qpsmtpd/TcpServer/Prefork.pm new file mode 100644 index 0000000..67bc7ad --- /dev/null +++ b/lib/Qpsmtpd/TcpServer/Prefork.pm @@ -0,0 +1,56 @@ +package Qpsmtpd::TcpServer::Prefork; +use Qpsmtpd::TcpServer; +use Qpsmtpd::SMTP::Prefork; + +@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 / +/, $_) + 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; +} + +1; diff --git a/qpsmtpd-prefork b/qpsmtpd-prefork new file mode 100755 index 0000000..a63bf59 --- /dev/null +++ b/qpsmtpd-prefork @@ -0,0 +1,669 @@ +#!/usr/bin/perl +# 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/ +# +# Last updated: 05-05-2006 +# Reviewed by: DA, LR + +# 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 memory 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 $user = 'qmailq'; +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 $logFile = '/tmp/qpsmtpd_daemon.log'; +my $maxconnip = 10; +my $child_lifetime = 100; #number of times a child may be reused +my $loop_sleep = 30; #max number of seconds main_loop sleeps before checking for busy children +my $re_nice = 5; #nice process (parent process is reniced with number substracted from current nice level) +my $d_start = 0; +my $quiet = 0; +my $status = 0; +my $signal = ''; + +# help text +sub usage +{ + print <<"EOT"; +Usage: qpsmtpd-highperf [ options ] +--start : Start daemon +--stop : Kill daemon (and spawned children) +--reload : Reload daemon (does not break current connections) +--status : Show daemon status +--quiet : Be quiet (even errors are suppressed) +--version : Show version information +--debug : Enable debug output +--debug-path path : Path to debug file (default: $logFile) +--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) +--user username : User the daemon should run as (default: $user) +--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( + 'start' => \$d_start, + 'stop' => sub { $signal = 'TERM' }, + 'reload' => sub { $signal = 'HUP' }, + 'status' => \$status, + 'quiet' => \$quiet, + 'version' => sub { print "Qpsmtpd Daemon - version $VERSION\n"; exit 0; }, + 'debug' => \$debug, + 'debug-path=s' => \$logFile, + 'interface=s' => \$d_addr, + 'port=i' => \$d_port, + 'max-from-ip=i' => \$maxconnip, + 'children=i' => \$max_children, + 'idle-children=i' => \$idle_children, + 'user=s' => \$user, + 'pid-file=s' => \$PID, + 'renice-parent=i' => \$re_nice, + 'help' => \&usage, +) || &usage; + +# check arguments +if ( !$d_start && !$signal && !$status ) { + print "Wrong aguments!\nSee qpsmtpd-highperf --help for information on options\n"; + exit 1; +} + +# misc checks +$maxconnip = $max_children if ($maxconnip == 0); #set max from ip to max number of children if option is set to disabled +$maxconnip++; #to fix limit counter error in plugin +$idle_children = $max_children if ( !$idle_children || $idle_children > $max_children || $idle_children < -1 ); #ensure that idle_children matches value given to max_children +$chld_pool = $idle_children; + +# show status +if ($status) { + my $p = get_pid($PID); + if ($p) { + print "daemon is running (pid: $p)...\n"; + } else { + print "daemon is stopped...\n"; + } + exit 0; +} + +#start daemon +if ($d_start) { + # check if another instance is running (exit if yes) + my $p = get_pid($PID); + if ($p) { + if (kill 0, $p) { + print "Daemon is already running (pid: $p)\n"; + exit 1; + } else { + info("delete stale PID file <$PID> and cleanup shared memory"); + unlink("$PID") || die "can not delete stale PID file <$PID>"; + #check for muribund shared memory + my $T_shmid = `$ipcs -pm | $xargs`; + if ($T_shmid =~ /(\d+)\s+$user\s+$p\s+\d+$/) { + my $shmid = $1; + my ($semid, $shmid_key); + open(SEMID, "$ipcs -sm |"); + while() { + $shmid_key = $1 if (/^(0x\w+)\s+$shmid/); + $semid = $1 if ($shmid_key && /^$shmid_key\s+(\d+)/); + } + close(SEMID); + system("$ipcrm -m $shmid -s $semid"); + } + } + } + + # get UUID/GUID + my ( $uuid, $ugid, $group ); + 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 ); + + # check directory structure + if ( $PID =~ /$pid_path/ and !-d $pid_path ) { + system("mkdir -p $pid_path"); + system("chown $user.$group $pid_path"); + } + system "chown", "$user.$group", $logFile if ( -f "$logFile" ); + + # 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-highperf 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)"; + } + + # 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 ) ); + + # daemonize + &daemonize; + + #setup shared memory + $chld_shmem = &shmem("qpsmtpd", 1); + untie $chld_shmem; + + #setup qpsmtpd_instance + $qpsmtpd = &qpmsptd_instance(); + + #child reaper + $SIG{CHLD} = \&reaper; + &spawn_children; + &main_loop; + exit; +} + +#stop/reload daemon +if ($signal) { + $SIG{TERM} = $SIG{HUP} = 'IGNORE'; #prevent signals to ourself + my $p = get_pid($PID); + if ($p) { + kill $signal => $p; + } else { + print "Unable to $signal daemon...\nQpsmtpd-highperf isn't running!\n"; + } + exit; +} + +#setup daemon process +sub daemonize { + + #redirect std filehandles to the bit bucket + open STDIN, "/dev/null" || die "Can't write to: /dev/null - $!\n"; + + my $pid = fork; + defined($pid) or die "Can't start daemon: $!"; + + #if this is the shell-called process, let clients know the daemon is now running and detach + if ($pid) { + + #write PID file + open( PID, "> $PID" ) || die "can't write to file <$PID> - $!"; + print PID "$pid\n"; + close PID; + + #exit back to shell + exit; + } + + #now we're a daemonized parent process! + + #detach from shell, by setting session and making process group + POSIX::setsid(); + + #redirect errors (too) + open STDERR, '>&STDOUT' || die "Can't duplicate stdout - $!\n"; + + #set pretty parent name in process listing + #$0 = "$0 " . "@ARGV"; + + # Set up signals that should be catched + $SIG{__WARN__} = sub { + info( "WARN: " . join( " ", @_ ) ) if ( !$quiet ); + }; + + $SIG{__DIE__} = sub { + my $msg = join (" ", @_); + chomp($msg); + info( "FATAL: <$msg>" ) if ( !$quiet ); + die "FATAL: <$msg> - " + }; + + $SIG{INT} = $SIG{TERM} = sub { + # terminate daemon (and children) + my $sig = shift; + $SIG{$sig} = $SIG{CHLD} = $SIG{HUP} = 'IGNORE'; #prevent another signal and disable reaper + unlink("$PID"); + $d->close(); #close socket + my $cnt = kill 'INT' => keys %children; + IPC::Shareable->clean_up; #cleanup shared memory + info("shutdown of daemon (and $cnt children)"); + exit; + }; + + $SIG{HUP} = sub { + # reload qpmstpd plugins + $qpsmtpd->load_plugins; + kill 'HUP' => keys %children; + info("reload daemon requested" ); + }; + +} + +# 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 + push @stiffs, $stiff; #add pid to array so it later can be removed from shared memory + } + #remove connection info from shared memory + $chld_busy = &shmem_opt(undef, \@stiffs, undef, undef); #and get number of busy children (use by main_loop) + $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); + $chld_busy = &shmem_opt(undef, undef, undef, undef, 1) if ($sleept == $loop_sleep); #get number of busy children, if sleep wasn't interrupted by signal + #calculate children in pool (if valid busy children number) + if (defined($chld_busy)) { + info("busy children: $chld_busy"); + $chld_pool = $chld_busy + $idle_children; + } + $chld_pool = $max_children if ($chld_pool > $max_children); #ensure pool limit is 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 + $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 new qpsmtpd session + &qpsmtpd_session($client, $qpsmtpd) if ($iinfo); #only start a session if connection looks valid + + #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; +} + +#get_pid: get pid of running qpsmtpd-highperf process +#arg0: str with path to pid file +#ret0: int with pid (undef if process isn't running or unable to get pid from file) +sub get_pid { + my $pid_path = shift; #arg0 + + open(PID, "<$pid_path") || return; + my $p = ; + close(PID); + $p = $1 if ($p =~ /^(\d+)$/); + + return($p); +} + +#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 + return if ( (defined($pid_add_key) && !defined($pid_add_value)) || (!defined($pid_add_key) && defined($pid_add_value)) ); + + 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}; + } + } + $$chld_shmem{$pid_add_key} = $pid_add_value if ($pid_add_key); #add + %{$ref_shmem} = %{$chld_shmem} if($ref_shmem); #copy + #loop through pid list and delete orphaned processes + if ($check) { + foreach my $pid (keys %{$chld_shmem}) { + if (! kill 0, $pid) { + delete $$chld_shmem{$pid}; + warn("orphaned child, pid: $pid - removed from shared memory"); + } + } + } + #count number of busy children + $chld_busy = scalar(keys %{$chld_shmem}); + (tied %{$chld_shmem})->shunlock; + untie $chld_shmem || die "unable to untie from shared memory"; #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); + system("echo \"$nowtime:$$: $text\" >> $logFile"); +} + +#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 ) { + my $rc_reply = 451; #smtp return code to reply client with (seed with soft deny) + 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); + &shmem_opt(undef, [$$], undef, undef); #remove pid from shared memory + return; #retur so child can be reused + } + + # all children should have different seeds, to prevent conflicts + srand( time ^ ($$ + ($$ << 15)) ); + +# $SIG{$_} = 'DEFAULT' for keys %SIG; + $SIG{ALRM} = sub { + print $client "421 Connection Timed Out\n"; + &info("Connection Timed Out"); + exit 1; #this will kill the child, but who cares? + }; + + #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("$@"); + } + + #done - this child is now idle again + &shmem_opt(undef, [$$], undef, undef); #remove pid from shared memory + + info("remote host: $ENV{TCPREMOTEIP} left..."); + +} From e9e95dd09bba3404f301cdf8e95d650e19570f46 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 31 May 2006 21:06:40 +0000 Subject: [PATCH 084/134] Patch to qpsmtpd-prefork from Matt Sergeant: missing disconnect code, so QUIT never works removes the daemonize stuff git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@640 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-prefork | 309 ++++++++++++++++++------------------------------ 1 file changed, 116 insertions(+), 193 deletions(-) diff --git a/qpsmtpd-prefork b/qpsmtpd-prefork index a63bf59..9080cdd 100755 --- a/qpsmtpd-prefork +++ b/qpsmtpd-prefork @@ -21,6 +21,7 @@ use lib 'lib'; use Qpsmtpd::TcpServer::Prefork; use Qpsmtpd::Constants; use Getopt::Long; + #use Time::HiRes qw(gettimeofday tv_interval); # secure shell @@ -48,41 +49,36 @@ my $d; # socket #default settings my $pid_path = '/var/run/qpsmtpd/'; my $PID = $pid_path . "/qpsmtpd.pid"; -my $user = 'qmailq'; 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 $logFile = '/tmp/qpsmtpd_daemon.log'; my $maxconnip = 10; my $child_lifetime = 100; #number of times a child may be reused -my $loop_sleep = 30; #max number of seconds main_loop sleeps before checking for busy children -my $re_nice = 5; #nice process (parent process is reniced with number substracted from current nice level) +my $loop_sleep = + 30; #max number of seconds main_loop sleeps before checking for busy children +my $re_nice = 5 + ; #nice process (parent process is reniced with number substracted from current nice level) my $d_start = 0; my $quiet = 0; my $status = 0; my $signal = ''; +my $user; # help text -sub usage -{ +sub usage { print <<"EOT"; Usage: qpsmtpd-highperf [ options ] ---start : Start daemon ---stop : Kill daemon (and spawned children) ---reload : Reload daemon (does not break current connections) ---status : Show daemon status --quiet : Be quiet (even errors are suppressed) --version : Show version information --debug : Enable debug output ---debug-path path : Path to debug file (default: $logFile) --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) ---user username : User the daemon should run as (default: $user) +--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 @@ -92,77 +88,38 @@ EOT # get arguments GetOptions( - 'start' => \$d_start, - 'stop' => sub { $signal = 'TERM' }, - 'reload' => sub { $signal = 'HUP' }, - 'status' => \$status, 'quiet' => \$quiet, 'version' => sub { print "Qpsmtpd Daemon - version $VERSION\n"; exit 0; }, 'debug' => \$debug, - 'debug-path=s' => \$logFile, 'interface=s' => \$d_addr, 'port=i' => \$d_port, 'max-from-ip=i' => \$maxconnip, 'children=i' => \$max_children, 'idle-children=i' => \$idle_children, 'user=s' => \$user, - 'pid-file=s' => \$PID, 'renice-parent=i' => \$re_nice, 'help' => \&usage, -) || &usage; - -# check arguments -if ( !$d_start && !$signal && !$status ) { - print "Wrong aguments!\nSee qpsmtpd-highperf --help for information on options\n"; - exit 1; -} + ) + || &usage; # misc checks -$maxconnip = $max_children if ($maxconnip == 0); #set max from ip to max number of children if option is set to disabled +$maxconnip = $max_children + if ($maxconnip == 0) + ; #set max from ip to max number of children if option is set to disabled $maxconnip++; #to fix limit counter error in plugin -$idle_children = $max_children if ( !$idle_children || $idle_children > $max_children || $idle_children < -1 ); #ensure that idle_children matches value given to max_children +$idle_children = $max_children + if (!$idle_children || $idle_children > $max_children || $idle_children < -1) + ; #ensure that idle_children matches value given to max_children $chld_pool = $idle_children; -# show status -if ($status) { - my $p = get_pid($PID); - if ($p) { - print "daemon is running (pid: $p)...\n"; - } else { - print "daemon is stopped...\n"; - } - exit 0; -} +run(); #start daemon -if ($d_start) { - # check if another instance is running (exit if yes) - my $p = get_pid($PID); - if ($p) { - if (kill 0, $p) { - print "Daemon is already running (pid: $p)\n"; - exit 1; - } else { - info("delete stale PID file <$PID> and cleanup shared memory"); - unlink("$PID") || die "can not delete stale PID file <$PID>"; - #check for muribund shared memory - my $T_shmid = `$ipcs -pm | $xargs`; - if ($T_shmid =~ /(\d+)\s+$user\s+$p\s+\d+$/) { - my $shmid = $1; - my ($semid, $shmid_key); - open(SEMID, "$ipcs -sm |"); - while() { - $shmid_key = $1 if (/^(0x\w+)\s+$shmid/); - $semid = $1 if ($shmid_key && /^$shmid_key\s+(\d+)/); - } - close(SEMID); - system("$ipcrm -m $shmid -s $semid"); - } - } - } +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`; @@ -176,26 +133,24 @@ if ($d_start) { $group = $1 if ( $T_group =~ /(\w+)/ ); die("FATAL: unknown user <$user> or missing group information") if ( !$uuid || !$ugid ); - - # check directory structure - if ( $PID =~ /$pid_path/ and !-d $pid_path ) { - system("mkdir -p $pid_path"); - system("chown $user.$group $pid_path"); } - system "chown", "$user.$group", $logFile if ( -f "$logFile" ); # create new socket (used by clients to communicate with daemon) - $d = new IO::Socket::INET( + $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; + 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-highperf daemon, version: $VERSION, staring on host: $d_addr, port: $d_port (user: $user [$<])"); + info( +"qpsmtpd-highperf daemon, version: $VERSION, staring on host: $d_addr, port: $d_port (user: $user [$<])" + ); #reset priority my $old_nice = getpriority(0, 0); @@ -203,10 +158,13 @@ if ($d_start) { 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)"; + } + 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 @@ -214,81 +172,12 @@ if ($d_start) { $< = $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 ) ); - - # daemonize - &daemonize; + } #setup shared memory - $chld_shmem = &shmem("qpsmtpd", 1); + $chld_shmem = shmem("qpsmtpd", 1); untie $chld_shmem; - #setup qpsmtpd_instance - $qpsmtpd = &qpmsptd_instance(); - - #child reaper - $SIG{CHLD} = \&reaper; - &spawn_children; - &main_loop; - exit; -} - -#stop/reload daemon -if ($signal) { - $SIG{TERM} = $SIG{HUP} = 'IGNORE'; #prevent signals to ourself - my $p = get_pid($PID); - if ($p) { - kill $signal => $p; - } else { - print "Unable to $signal daemon...\nQpsmtpd-highperf isn't running!\n"; - } - exit; -} - -#setup daemon process -sub daemonize { - - #redirect std filehandles to the bit bucket - open STDIN, "/dev/null" || die "Can't write to: /dev/null - $!\n"; - - my $pid = fork; - defined($pid) or die "Can't start daemon: $!"; - - #if this is the shell-called process, let clients know the daemon is now running and detach - if ($pid) { - - #write PID file - open( PID, "> $PID" ) || die "can't write to file <$PID> - $!"; - print PID "$pid\n"; - close PID; - - #exit back to shell - exit; - } - - #now we're a daemonized parent process! - - #detach from shell, by setting session and making process group - POSIX::setsid(); - - #redirect errors (too) - open STDERR, '>&STDOUT' || die "Can't duplicate stdout - $!\n"; - - #set pretty parent name in process listing - #$0 = "$0 " . "@ARGV"; - - # Set up signals that should be catched - $SIG{__WARN__} = sub { - info( "WARN: " . join( " ", @_ ) ) if ( !$quiet ); - }; - - $SIG{__DIE__} = sub { - my $msg = join (" ", @_); - chomp($msg); - info( "FATAL: <$msg>" ) if ( !$quiet ); - die "FATAL: <$msg> - " - }; - $SIG{INT} = $SIG{TERM} = sub { # terminate daemon (and children) my $sig = shift; @@ -308,17 +197,27 @@ sub daemonize { 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); + my $sigset = block_signal(SIGCHLD); for ( 1 .. $chld_pool ) { - &new_child(); + new_child(); } + #reset block signals - &unblock_signal($sigset); + unblock_signal($sigset); } # cleanup after child dies @@ -329,10 +228,14 @@ sub reaper { my $res = WEXITSTATUS($?); info("child terminated, pid: $stiff (status $?, res: $res)"); delete $children{$stiff}; #delete pid from children - push @stiffs, $stiff; #add pid to array so it later can be removed from shared memory + push @stiffs, $stiff + ; #add pid to array so it later can be removed from shared memory } + #remove connection info from shared memory - $chld_busy = &shmem_opt(undef, \@stiffs, undef, undef); #and get number of busy children (use by main_loop) + $chld_busy = + shmem_opt(undef, \@stiffs, undef, undef) + ; #and get number of busy children (use by main_loop) $SIG{CHLD} = \&reaper; } @@ -341,24 +244,32 @@ sub reaper { #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); - $chld_busy = &shmem_opt(undef, undef, undef, undef, 1) if ($sleept == $loop_sleep); #get number of busy children, if sleep wasn't interrupted by signal + my $sigset = block_signal(SIGCHLD); + $chld_busy = shmem_opt(undef, undef, undef, undef, 1) + if ($sleept == $loop_sleep) + ; #get number of busy children, if sleep wasn't interrupted by signal #calculate children in pool (if valid busy children number) if (defined($chld_busy)) { info("busy children: $chld_busy"); $chld_pool = $chld_busy + $idle_children; } - $chld_pool = $max_children if ($chld_pool > $max_children); #ensure pool limit is max_children + $chld_pool = $max_children + if ($chld_pool > $max_children); #ensure pool limit is max_children #spawn children for ( my $i = scalar (keys %children); $i < $chld_pool ; $i++ ) { - &new_child(); #add to the child pool + new_child(); #add to the child pool } - info("children pool: $chld_pool (currently spawned: ".scalar (keys %children).")"); + info( "children pool: $chld_pool (currently spawned: " + . scalar(keys %children) + . ")"); + #unblock signals - &unblock_signal($sigset); + unblock_signal($sigset); } } @@ -399,11 +310,13 @@ sub new_child { 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 @@ -417,7 +330,8 @@ sub new_child { $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"); + $SIG{HUP} = sub { + info("signal HUP received, going to exit"); exit 1; }; @@ -426,25 +340,30 @@ sub new_child { # accept a connection $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 + 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 - $!"; + 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); + my $sigset = block_signal(SIGHUP); #start new qpsmtpd session - &qpsmtpd_session($client, $qpsmtpd) if ($iinfo); #only start a session if connection looks valid + qpsmtpd_session($client, $qpsmtpd) + if ($iinfo); #only start a session if connection looks valid #close connection and cleanup $client->shutdown(2); #unset block and receive pending signals - &unblock_signal($sigset); + unblock_signal($sigset); } exit; # this child has reached its end-of-life @@ -462,30 +381,15 @@ sub respond_client { my $line = $code . (@message?"-":" ").$msg; info("reply to client: <$line>"); print $client "$line\r\n" - or (&info("Could not print [$line]: $!"), return 0); + or (info("Could not print [$line]: $!"), return 0); } return 1; } -#get_pid: get pid of running qpsmtpd-highperf process -#arg0: str with path to pid file -#ret0: int with pid (undef if process isn't running or unable to get pid from file) -sub get_pid { - my $pid_path = shift; #arg0 - - open(PID, "<$pid_path") || return; - my $p = ; - close(PID); - $p = $1 if ($p =~ /^(\d+)$/); - - return($p); -} - #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; @@ -511,7 +415,8 @@ sub shmem { my %shmem_hash; eval { - tie %shmem_hash, 'IPC::Shareable', $glue, { %options } || die "unable to tie to shared memory - $!"; + tie %shmem_hash, 'IPC::Shareable', $glue, + {%options} || die "unable to tie to shared memory - $!"; }; if ($@) { info("$@"); @@ -536,15 +441,19 @@ sub shmem_opt { my $check = shift || 0; #arg4 #check arguments - return if ( (defined($pid_add_key) && !defined($pid_add_value)) || (!defined($pid_add_key) && defined($pid_add_value)) ); + return + if ( (defined($pid_add_key) && !defined($pid_add_value)) + || (!defined($pid_add_key) && defined($pid_add_value))); 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}) { @@ -558,16 +467,21 @@ sub shmem_opt { foreach my $pid (keys %{$chld_shmem}) { if (! kill 0, $pid) { delete $$chld_shmem{$pid}; - warn("orphaned child, pid: $pid - removed from shared memory"); + warn( +"orphaned child, pid: $pid - removed from shared memory"); } } } + #count number of busy children $chld_busy = scalar(keys %{$chld_shmem}); (tied %{$chld_shmem})->shunlock; - untie $chld_shmem || die "unable to untie from shared memory"; #untie from shared memory + untie $chld_shmem + || die + "unable to untie from shared memory"; #untie from shared memory } }; + #check for error if ($@) { undef($chld_busy); @@ -588,7 +502,7 @@ sub info { $year + 1900, $hour, $min, $sec; chomp($text); - system("echo \"$nowtime:$$: $text\" >> $logFile"); + print STDERR "$nowtime:$$: $text\n"; } #start qpmstpd session @@ -605,9 +519,11 @@ sub qpsmtpd_session { #get current connected ip addresses (from shared memory) my %children; - &shmem_opt(\%children, undef, $$, $iaddr); + shmem_opt(\%children, undef, $$, $iaddr); - my ($rc, @msg) = $qpsmtpd->run_hooks("pre-connection", + my ($rc, @msg) = + $qpsmtpd->run_hooks( + "pre-connection", remote_ip => inet_ntoa($iaddr), remote_port => $port, local_ip => inet_ntoa($laddr), @@ -615,18 +531,24 @@ sub qpsmtpd_session { max_conn_ip => $maxconnip, child_addrs => [values %children], ); - if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT || $rc == DENY || $rc == DENY_DISCONNECT ) { - my $rc_reply = 451; #smtp return code to reply client with (seed with soft deny) + if ( $rc == DENYSOFT + || $rc == DENYSOFT_DISCONNECT + || $rc == DENY + || $rc == DENY_DISCONNECT) + { + my $rc_reply = + 451; #smtp return code to reply client with (seed with soft deny) unless ($msg[0]) { if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { @msg = ("Sorry, try again later"); - } else { + } + else { @msg = ("Sorry, service not available to you"); $rc_reply = 550; } } - &respond_client($client, $rc_reply, @msg); - &shmem_opt(undef, [$$], undef, undef); #remove pid from shared memory + respond_client($client, $rc_reply, @msg); + shmem_opt(undef, [$$], undef, undef); #remove pid from shared memory return; #retur so child can be reused } @@ -636,7 +558,7 @@ sub qpsmtpd_session { # $SIG{$_} = 'DEFAULT' for keys %SIG; $SIG{ALRM} = sub { print $client "421 Connection Timed Out\n"; - &info("Connection Timed Out"); + info("Connection Timed Out"); exit 1; #this will kill the child, but who cares? }; @@ -662,8 +584,9 @@ sub qpsmtpd_session { } #done - this child is now idle again - &shmem_opt(undef, [$$], undef, undef); #remove pid from shared memory + shmem_opt(undef, [$$], undef, undef); #remove pid from shared memory info("remote host: $ENV{TCPREMOTEIP} left..."); } + From 9bb950d1d06ff731893c2d83a039146646f43977 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 1 Jun 2006 14:13:44 +0000 Subject: [PATCH 085/134] Additional patch to qpsmtpd-prefork from Lars Roland: Patch against current svn which removes references to highperf, and various other cleanups in the code. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@641 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-prefork | 675 ++++++++++++++++++++++++------------------------ 1 file changed, 338 insertions(+), 337 deletions(-) diff --git a/qpsmtpd-prefork b/qpsmtpd-prefork index 9080cdd..5c8fcaa 100755 --- a/qpsmtpd-prefork +++ b/qpsmtpd-prefork @@ -6,9 +6,6 @@ # See the LICENSE file for details. # # For more information see http://develooper.com/code/qpsmtpd/ -# -# Last updated: 05-05-2006 -# Reviewed by: DA, LR # safety guards use strict; @@ -29,47 +26,45 @@ $ENV{'PATH'} = '/bin:/usr/bin'; delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # version -my $VERSION = "1.0"; +my $VERSION = "1.0"; # qpsmtpd instance my $qpsmtpd; -#cmd's needed by IPC +# cmd's needed by IPC my $ipcrm = '/usr/bin/ipcrm'; -my $ipcs = '/usr/bin/ipcs'; +my $ipcs = '/usr/bin/ipcs'; my $xargs = '/usr/bin/xargs'; -#vars we need -my $chld_shmem; #shared memory to keep track of children (and their connections) +# 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 +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; #max number of seconds main_loop sleeps before checking for busy children -my $re_nice = 5 - ; #nice process (parent process is reniced with number substracted from current nice level) -my $d_start = 0; -my $quiet = 0; -my $status = 0; -my $signal = ''; +# 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 $user; # help text sub usage { - print <<"EOT"; -Usage: qpsmtpd-highperf [ options ] + print <<"EOT"; +Usage: qpsmtpd-prefork [ options ] --quiet : Be quiet (even errors are suppressed) --version : Show version information --debug : Enable debug output @@ -83,124 +78,130 @@ Usage: qpsmtpd-highperf [ options ] --renice-parent int : Subtract value from parent process nice level (default: $re_nice) --help : This message EOT - exit 0; + 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, - 'user=s' => \$user, - 'renice-parent=i' => \$re_nice, - 'help' => \&usage, - ) - || &usage; + '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, + 'user=s' => \$user, + 'renice-parent=i' => \$re_nice, + 'help' => \&usage, + ) || &usage; -# misc checks -$maxconnip = $max_children - if ($maxconnip == 0) - ; #set max from ip to max number of children if option is set to disabled -$maxconnip++; #to fix limit counter error in plugin +# 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) - ; #ensure that idle_children matches value given to 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 ); + 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); + 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 ); + # 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, - ); + 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-highperf daemon, version: $VERSION, staring on host: $d_addr, port: $d_port (user: $user [$<])" - ); + info("qpsmtpd-prefork daemon, version: $VERSION, staring on host: " . + "$d_addr, port: $d_port (user: $user [$<])"); - #reset priority + # 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"); + 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 ) ); + die "FATAL: new nice level: $new_nice is not between -19 and 19 " + . "(old level = $old_nice, renice value = $re_nice)"; } - #setup shared memory + 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; - $SIG{$sig} = $SIG{CHLD} = $SIG{HUP} = 'IGNORE'; #prevent another signal and disable reaper + + # prevent another signal and disable reaper + $SIG{$sig} = $SIG{CHLD} = $SIG{HUP} = 'IGNORE'; unlink("$PID"); - $d->close(); #close socket + + # close socket + $d->close(); my $cnt = kill 'INT' => keys %children; - IPC::Shareable->clean_up; #cleanup shared memory + + # 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" ); + # reload qpmstpd plugins + $qpsmtpd->load_plugins; + kill 'HUP' => keys %children; + info("reload daemon requested"); }; - #setup qpsmtpd_instance + # setup qpsmtpd_instance $qpsmtpd = qpmsptd_instance(); - #child reaper + # child reaper $SIG{CHLD} = \&reaper; spawn_children(); main_loop(); @@ -209,14 +210,13 @@ sub run { # initialize children (only done at daemon startup) sub spawn_children { - - #block signals while new children are being spawned + # block signals while new children are being spawned my $sigset = block_signal(SIGCHLD); - for ( 1 .. $chld_pool ) { + for (1 .. $chld_pool) { new_child(); } - #reset block signals + # reset block signals unblock_signal($sigset); } @@ -224,18 +224,17 @@ sub spawn_children { sub reaper { my $stiff; my @stiffs; - while ( ( $stiff = waitpid( -1, &WNOHANG ) ) > 0 ) { + while (($stiff = waitpid(-1, &WNOHANG)) > 0) { my $res = WEXITSTATUS($?); info("child terminated, pid: $stiff (status $?, res: $res)"); - delete $children{$stiff}; #delete pid from children - push @stiffs, $stiff - ; #add pid to array so it later can be removed from shared memory + 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 - $chld_busy = - shmem_opt(undef, \@stiffs, undef, undef) - ; #and get number of busy children (use by main_loop) + # 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; } @@ -244,260 +243,258 @@ sub reaper { #ret0: void sub main_loop { while (1) { - - #sleep EXPR seconds or until signal (i.e. child death) is received + # 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? + # 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) - ; #get number of busy children, if sleep wasn't interrupted by signal - #calculate children in pool (if valid busy children number) + 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; + info("busy children: $chld_busy"); + $chld_pool = $chld_busy + $idle_children; } - $chld_pool = $max_children - if ($chld_pool > $max_children); #ensure pool limit is max_children - #spawn children - for ( my $i = scalar (keys %children); $i < $chld_pool ; $i++ ) { - new_child(); #add to the child pool + + # 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 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) +# 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); + 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 +# 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"; - + my $sigset = shift; # arg0 + sigprocmask(SIG_SETMASK, $sigset) + or die "Could not restore signals: $!\n"; } -#new_child: initialize new child -#arg0: void -#ret0: void +# 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 ); + die "Cannot fork child: $!\n" unless defined($pid = fork); if ($pid) { - - # in parent - $children{$pid} = 1; - info("new child, pid: $pid"); - return; + # in parent + $children{$pid} = 1; + info("new child, pid: $pid"); + return; } # in child - - #reset priority - setpriority 0, 0, getpriority (0, 0) + $re_nice; + + # reset priority + setpriority 0, 0, getpriority(0, 0) + $re_nice; # reset signals - my $sigset = POSIX::SigSet->new(); + my $sigset = POSIX::SigSet->new(); my $blockset = POSIX::SigSet->new(SIGCHLD); - sigprocmask(SIG_UNBLOCK, $blockset, $sigset) - or die "Could not unblock SIGHUP signal: $!\n"; + 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) + # 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; - }; - + exit 1; + }; + # continue to accept connections until "old age" is reached - for ( my $i = 0; $i < $child_lifetime ; $i++ ) { - - # accept a connection - $0 = 'qpsmtpd child'; # set pretty child name in process listing + for (my $i = 0 ; $i < $child_lifetime ; $i++) { + # accept a connection + $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 + 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; + $| = 1; - #connection recieved, block signals + # connection recieved, block signals my $sigset = block_signal(SIGHUP); - - #start new qpsmtpd session - qpsmtpd_session($client, $qpsmtpd) - if ($iinfo); #only start a session if connection looks valid - - #close connection and cleanup - $client->shutdown(2); - - #unset block and receive pending signals - unblock_signal($sigset); + # 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) +# 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" + 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; + } + return 1; } -#qpsmtpd_instance: setup qpsmtpd instance -#arg0: void -#ret0: ref to qpsmtpd_instance +# 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); + 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 +# 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); + 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) +# 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 - return - if ( (defined($pid_add_key) && !defined($pid_add_value)) - || (!defined($pid_add_key) && defined($pid_add_value))); - - my ($chld_shmem, $chld_busy); - eval { - $chld_shmem = &shmem("qpsmtpd", 0); #connect to shared memory hash - - if (tied %{$chld_shmem}) { + 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 - #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}; - } - } - $$chld_shmem{$pid_add_key} = $pid_add_value if ($pid_add_key); #add - %{$ref_shmem} = %{$chld_shmem} if($ref_shmem); #copy - #loop through pid list and delete orphaned processes - if ($check) { - foreach my $pid (keys %{$chld_shmem}) { - if (! kill 0, $pid) { - delete $$chld_shmem{$pid}; - warn( -"orphaned child, pid: $pid - removed from shared memory"); - } - } - } - - #count number of busy children - $chld_busy = scalar(keys %{$chld_shmem}); - (tied %{$chld_shmem})->shunlock; - untie $chld_shmem - || die - "unable to untie from shared memory"; #untie from shared memory + # check arguments + if ( (defined($pid_add_key) && !defined($pid_add_value)) + || (!defined($pid_add_key) && defined($pid_add_value))) + { + return; } - }; - #check for error - if ($@) { - undef($chld_busy); - warn("$@"); - } - - return($chld_busy); + 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 $text = shift; #arg0 + return if (!$debug); - my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime(time); + 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; @@ -505,88 +502,92 @@ sub info { print STDERR "$nowtime:$$: $text\n"; } -#start qpmstpd session +# 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 + my $client = shift; #arg0 + my $qpsmtpd = shift; #arg1 - #get current connected ip addresses (from shared memory) + # 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], - ); + 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) { - my $rc_reply = - 451; #smtp return code to reply client with (seed with soft deny) - unless ($msg[0]) { - if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { - @msg = ("Sorry, try again later"); + #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; + @msg = ("Sorry, service not available to you"); + $rc_reply = 550; + } } - } respond_client($client, $rc_reply, @msg); - shmem_opt(undef, [$$], undef, undef); #remove pid from shared memory - return; #retur so child can be reused + + # 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)) ); - -# $SIG{$_} = 'DEFAULT' for keys %SIG; - $SIG{ALRM} = sub { - print $client "421 Connection Timed Out\n"; + srand(time ^ ($$ + ($$ << 15))); + + # ALRM handler + $SIG{ALRM} = sub { + print $client "421 Connection Timed Out\n"; info("Connection Timed Out"); - exit 1; #this will kill the child, but who cares? - }; - - #set enviroment variables + + # 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 + # 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"); + $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("$@"); + if ($@ !~ /^(disconnect_tcpserver|died while reading from STDIN)/) { + warn("$@"); } - #done - this child is now idle again - shmem_opt(undef, [$$], undef, undef); #remove pid from shared memory - + # child is now idle again so remove it's pid from shared mem + shmem_opt(undef, [$$], undef, undef); + info("remote host: $ENV{TCPREMOTEIP} left..."); - } - From b3bc12e5879b76cc1540374072beb7997a398846 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Fri, 16 Jun 2006 00:15:03 +0000 Subject: [PATCH 086/134] r3599@embla: ask | 2006-06-15 17:15:06 -0700 Fix "help" command when there's no "smtpgreeting" configured (the default) (Thanks to Thomas Ogrisegg) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@642 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 3 +++ lib/Qpsmtpd/SMTP.pm | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/Changes b/Changes index 8d3c191..8247ed4 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ 0.33 + 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 diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 6c794c2..577d7bf 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -417,7 +417,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 .'); } From 25d9fe85a82e689c513e7c80d4ed010d2e00c2cd Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 22 Jun 2006 14:48:48 +0000 Subject: [PATCH 087/134] Two patches from Robin Johnson: Add SSL encryption method to FROM: header line. Add new tls_before_auth configuration to hide AUTH until TLS is established. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@645 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 4 ++++ README | 5 +++++ config.sample/tls_before_auth | 2 ++ lib/Qpsmtpd/SMTP.pm | 11 +++++++++-- 4 files changed, 20 insertions(+), 2 deletions(-) create mode 100644 config.sample/tls_before_auth diff --git a/Changes b/Changes index 8247ed4..250d3a8 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,9 @@ 0.33 + 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) diff --git a/README b/README index 53c3fc9..0e2979d 100644 --- a/README +++ b/README @@ -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/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/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 577d7bf..cdace58 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -219,7 +219,9 @@ 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'} = ""; } @@ -248,6 +250,9 @@ sub 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') ); return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff ); } @@ -584,13 +589,15 @@ sub data { $self->transaction->header($header); my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; + my $sslheader = (defined $self->connection->notes('tls_enabled') and $self->connection->notes('tls_enabled')) ? + "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) " : ""; my $authheader = (defined $self->{_auth} and $self->{_auth} == OK) ? "(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 From bf2419df3354645d3679107d0049dd8aae6372b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Wed, 28 Jun 2006 20:05:04 +0000 Subject: [PATCH 088/134] r3744@embla: ask | 2006-06-28 13:04:50 -0700 Support "module" plugins ("My::Plugin" in the config/plugins file) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@648 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 2 ++ lib/Qpsmtpd.pm | 50 +++++++++++++++++++++++++++++-------------- lib/Qpsmtpd/Plugin.pm | 20 +++++++++++------ 3 files changed, 50 insertions(+), 22 deletions(-) diff --git a/Changes b/Changes index 250d3a8..f1cbf6d 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,7 @@ 0.33 + Support "module" plugins ("My::Plugin" in the config/plugins file) + 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). diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index a7ae15e..417dc85 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -260,31 +260,49 @@ sub _load_plugins { my @ret; for my $plugin_line (@plugins) { my ($plugin, @args) = split ' ', $plugin_line; - - 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; + my $package; - # second pass cares for slashes and words starting with a digit - $plugin_name =~ s{ + 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"; - - # don't reload plugins if they are already loaded - unless ( defined &{"${package}::plugin_name"} ) { - Qpsmtpd::Plugin->compile($plugin_name, + + $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/; + $self->log(LOGDEBUG, "Loading $plugin_line") + unless $plugin_line =~ /logging/; + } } - + my $plug = $package->new(); push @ret, $plug; $plug->_register($self, @args); diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 5947b77..b6357be 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -19,6 +19,10 @@ sub new { bless ({}, $class); } +sub hook_name { + return shift->{_hook}; +} + sub register_hook { my ($plugin, $hook, $method, $unshift) = @_; @@ -29,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 { @@ -149,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? From 17f1617920ba9ba0182c86e68d3cc79358708358 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Sun, 9 Jul 2006 00:58:39 +0000 Subject: [PATCH 089/134] Working but not well testing domainkeys plugin. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@650 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/domainkeys | 107 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 107 insertions(+) create mode 100644 plugins/domainkeys diff --git a/plugins/domainkeys b/plugins/domainkeys new file mode 100644 index 0000000..5b04196 --- /dev/null +++ b/plugins/domainkeys @@ -0,0 +1,107 @@ +sub hook_data_post { + use Mail::DomainKeys::Message; + use Mail::DomainKeys::Policy; + + my $self = shift; + my $tran = shift; + + my @body; + + + $tran->body_resetpos; + + $tran->body_getline; # \r\n seperator is NOT part of the body + + while (my $line = $tran->body_getline) { + push @body, $line; + } + + my $mess = load Mail::DomainKeys::Message( + HeadString => $tran->header->as_string, + BodyReference => \@body) or + $self->log(LOGWARN, "unable to load message"), + return DECLINED; + + # no sender domain means no verification + $mess->senderdomain or + return DECLINED; + + my $status; + + # key testing + if ( $mess->testing ) { + # Don't do anything else + $status = "testing"; + } + elsif ( $mess->signed ) { + if ( $mess->verify ) { + # verified: add good header + $status = $mess->signature->status; + } + else { + # not verified, i.e. forged signature + $status = undef; + } + } + else { # not signed + my $plcy = fetch Mail::DomainKeys::Policy( + Protocol => "dns", + Domain => $mess->senderdomain + ); + if ( $plcy ) { + if ( $plcy->testing ) { + # Don't do anything else + $status = "testing"; + } + elsif ( $plcy->signall ) { + # if policy requires all mail to be signed + $status = undef; + } + else { # $plcy->signsome + # not signed and domain doesn't sign all + $status = "no signature"; + } + } + else { + $status = "no signature"; + } + } + + + if ( defined $status ) { + $tran->header->replace("DomainKey-Status", $status); + return DECLINED; + } + else { + return DENY, "DomainKeys signature failed to verify"; + } +} + +# Leave this in place until Mail::DomainKeys is patched +eval + q/ + *Mail::DomainKeys::Message::header = sub { + my $self = shift; + + $self->signed or + return new Mail::DomainKeys::Header( + Line => "DomainKey-Status: no signature"); + + $self->signature->status and + return new Mail::DomainKeys::Header( + Line => "DomainKey-Status: " . $self->signature->status); + }; + / +unless Mail::DomainKeys::Message->can('header'); + +=cut + +=head1 NAME + +domainkeys: validate a DomainKeys signature on an incoming mail + +Copyright (C) 2005 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. From 84b7363018573043aa6f2e546dafab5eea6cecd8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Sun, 9 Jul 2006 09:34:51 +0000 Subject: [PATCH 090/134] r3826@embla: ask | 2006-07-09 02:34:33 -0700 Enhance the spamassassin plugin to support connecting to a remote spamd process (Kjetil Kjernsmo). git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@651 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 3 +++ plugins/spamassassin | 13 +++++++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/Changes b/Changes index f1cbf6d..3368173 100644 --- a/Changes +++ b/Changes @@ -2,6 +2,9 @@ Support "module" plugins ("My::Plugin" in the config/plugins file) + 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). diff --git a/plugins/spamassassin b/plugins/spamassassin index 09fc796..0f3686a 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] @@ -101,6 +102,10 @@ sub hook_data_post { # check_spam 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 From f654defacb2289ba2b0ae08836970bef249a8592 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Tue, 11 Jul 2006 17:41:48 +0000 Subject: [PATCH 091/134] Add early out for messages that aren't signed at all (ignoring domains which mandate signing by policy for the moment). Change variables to use actual English words as names (instead of disemvoweled or truncated variants). Tweak Copyright notice to be current. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@652 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/domainkeys | 44 +++++++++++++++++++++++--------------------- 1 file changed, 23 insertions(+), 21 deletions(-) diff --git a/plugins/domainkeys b/plugins/domainkeys index 5b04196..ef8f18d 100644 --- a/plugins/domainkeys +++ b/plugins/domainkeys @@ -2,41 +2,43 @@ sub hook_data_post { use Mail::DomainKeys::Message; use Mail::DomainKeys::Policy; - my $self = shift; - my $tran = shift; + my ($self, $transaction) = @_; + # if this isn't signed, just move along + return DECLINED + unless $transaction->header->get('DomainKey-Signature'); + my @body; + $transaction->body_resetpos; - $tran->body_resetpos; + $transaction->body_getline; # \r\n seperator is NOT part of the body - $tran->body_getline; # \r\n seperator is NOT part of the body - - while (my $line = $tran->body_getline) { + while (my $line = $transaction->body_getline) { push @body, $line; } - my $mess = load Mail::DomainKeys::Message( - HeadString => $tran->header->as_string, + 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 - $mess->senderdomain or + $message->senderdomain or return DECLINED; my $status; # key testing - if ( $mess->testing ) { + if ( $message->testing ) { # Don't do anything else $status = "testing"; } - elsif ( $mess->signed ) { - if ( $mess->verify ) { + elsif ( $message->signed ) { + if ( $message->verify ) { # verified: add good header - $status = $mess->signature->status; + $status = $message->signature->status; } else { # not verified, i.e. forged signature @@ -44,20 +46,20 @@ sub hook_data_post { } } else { # not signed - my $plcy = fetch Mail::DomainKeys::Policy( + my $policy = fetch Mail::DomainKeys::Policy( Protocol => "dns", - Domain => $mess->senderdomain + Domain => $message->senderdomain ); - if ( $plcy ) { - if ( $plcy->testing ) { + if ( $policy ) { + if ( $policy->testing ) { # Don't do anything else $status = "testing"; } - elsif ( $plcy->signall ) { + elsif ( $policy->signall ) { # if policy requires all mail to be signed $status = undef; } - else { # $plcy->signsome + else { # $policy->signsome # not signed and domain doesn't sign all $status = "no signature"; } @@ -69,7 +71,7 @@ sub hook_data_post { if ( defined $status ) { - $tran->header->replace("DomainKey-Status", $status); + $transaction->header->replace("DomainKey-Status", $status); return DECLINED; } else { @@ -100,7 +102,7 @@ unless Mail::DomainKeys::Message->can('header'); domainkeys: validate a DomainKeys signature on an incoming mail -Copyright (C) 2005 John Peacock. +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 From 66f2f9354bdf3857473081fe333e5050819e1a71 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Tue, 11 Jul 2006 21:20:44 +0000 Subject: [PATCH 092/134] Temporarily prevent domainkeys from issuing DENY. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@653 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/domainkeys | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/plugins/domainkeys b/plugins/domainkeys index ef8f18d..af1d552 100644 --- a/plugins/domainkeys +++ b/plugins/domainkeys @@ -75,7 +75,8 @@ sub hook_data_post { return DECLINED; } else { - return DENY, "DomainKeys signature failed to verify"; + $self->log(LOGWARN, "DomainKeys signature failed to verify"); + return DECLINED; } } From de620a4c22aab3677b3d2a12a29530aa511171d6 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 12 Jul 2006 18:10:00 +0000 Subject: [PATCH 093/134] Handler corner case better: signed message relayed by listserv which adds Sender: but does not resign message or strip DomainKeys-Signature. Add config option to prevent badly signed message from being DENY'd. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@654 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/domainkeys | 66 +++++++++++++++++++++++++--------------------- 1 file changed, 36 insertions(+), 30 deletions(-) diff --git a/plugins/domainkeys b/plugins/domainkeys index af1d552..597c0c8 100644 --- a/plugins/domainkeys +++ b/plugins/domainkeys @@ -1,3 +1,11 @@ +sub init { + my ($self, %args) = @_; + + foreach my $key ( %args ) { + $self->{$key} = $args{$key}; + } +} + sub hook_data_post { use Mail::DomainKeys::Message; use Mail::DomainKeys::Policy; @@ -35,17 +43,11 @@ sub hook_data_post { # Don't do anything else $status = "testing"; } - elsif ( $message->signed ) { - if ( $message->verify ) { - # verified: add good header - $status = $message->signature->status; - } - else { - # not verified, i.e. forged signature - $status = undef; - } + elsif ( $message->signed and $message->verify ) { + # verified: add good header + $status = $message->signature->status; } - else { # not signed + else { # not signed or not verified my $policy = fetch Mail::DomainKeys::Policy( Protocol => "dns", Domain => $message->senderdomain @@ -65,44 +67,48 @@ sub hook_data_post { } } else { - $status = "no signature"; + $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(LOGWARN, "DomainKeys signature failed to verify"); - return DECLINED; + $self->log(LOGERROR, "DomainKeys signature failed to verify"); + if ( $self->{warn_only} ) { + return DECLINED; + } + else { + return (DENY, "DomainKeys signature failed to verify"); + } } } -# Leave this in place until Mail::DomainKeys is patched -eval - q/ - *Mail::DomainKeys::Message::header = sub { - my $self = shift; - - $self->signed or - return new Mail::DomainKeys::Header( - Line => "DomainKey-Status: no signature"); - - $self->signature->status and - return new Mail::DomainKeys::Header( - Line => "DomainKey-Status: " . $self->signature->status); - }; - / -unless Mail::DomainKeys::Message->can('header'); - =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 From ca30545adc95922b55681b242ab67a99f00864b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Fri, 14 Jul 2006 08:43:55 +0000 Subject: [PATCH 094/134] r3843@embla: ask | 2006-07-14 01:43:40 -0700 take out "local %ENV" from the quit_fortune plugin (Philip M. Gollucci) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@655 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/quit_fortune | 2 -- 1 file changed, 2 deletions(-) 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); From 52f38f945926d2368125527aae0a473575e0ad42 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Mon, 24 Jul 2006 19:10:38 +0000 Subject: [PATCH 095/134] Oops! init() gets $self and $qp before any commandline arguments git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@656 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/domainkeys | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/domainkeys b/plugins/domainkeys index 597c0c8..ccabf59 100644 --- a/plugins/domainkeys +++ b/plugins/domainkeys @@ -1,5 +1,5 @@ sub init { - my ($self, %args) = @_; + my ($self, $qp, %args) = @_; foreach my $key ( %args ) { $self->{$key} = $args{$key}; From 6ef0bf27c739fb95a2b2be1cec3b95d99056215c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Sun, 27 Aug 2006 23:17:33 +0000 Subject: [PATCH 096/134] r4175@embla: ask | 2006-08-28 01:17:10 +0200 Experimental IPv6 support (forkserver only). (Mike Williams) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@657 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 2 + lib/Qpsmtpd/Constants.pm | 18 +++++++++ plugins/check_relay | 2 +- plugins/require_resolvable_fromhost | 43 +++++++++++++++++----- qpsmtpd-forkserver | 57 ++++++++++++++++++++++------- 5 files changed, 99 insertions(+), 23 deletions(-) diff --git a/Changes b/Changes index 3368173..469de24 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,7 @@ 0.33 + Experimental IPv6 support (forkserver only). (Mike Williams) + Support "module" plugins ("My::Plugin" in the config/plugins file) Enhance the spamassassin plugin to support connecting to a remote diff --git a/lib/Qpsmtpd/Constants.pm b/lib/Qpsmtpd/Constants.pm index 68bd8f6..4152131 100644 --- a/lib/Qpsmtpd/Constants.pm +++ b/lib/Qpsmtpd/Constants.pm @@ -27,6 +27,24 @@ my %return_codes = ( DONE => 910, ); +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"); 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/require_resolvable_fromhost b/plugins/require_resolvable_fromhost index 2886b3f..78579e9 100644 --- a/plugins/require_resolvable_fromhost +++ b/plugins/require_resolvable_fromhost @@ -3,6 +3,7 @@ use Net::DNS qw(mx); use Socket; my %invalid = (); +my $has_ipv6 = Qpsmtpd::Constants::has_ipv6; sub hook_mail { my ($self, $transaction, $sender, %param) = @_; @@ -38,6 +39,7 @@ sub hook_mail { sub check_dns { my ($self, $host) = @_; + my @host_answers; # for stuff where we can't even parse a hostname out of the address return 0 unless $host; @@ -53,15 +55,24 @@ sub check_dns { } my $query = $res->search($host); if ($query) { - foreach my $rr ($query->answer) { - if ($rr->type eq "A") { - return is_valid($rr->address); - } - elsif ($rr->type eq "MX") { - return mx_valid($self, $rr->exchange, $host); + foreach my $rrA ($query->answer) { + push(@host_answers, $rrA); + } + } + if ($has_ipv6) { + my $query = $res->search($host, 'AAAA'); + if ($query) { + foreach my $rrAAAA ($query->answer) { + push(@host_answers, $rrAAAA); } } } + 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"; + } + } else { $self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring) unless $res->errorstring eq "NXDOMAIN"; @@ -88,10 +99,24 @@ sub is_valid { sub mx_valid { my ($self, $name, $host) = @_; my $res = new Net::DNS::Resolver; - my $query = $res->search($name); + my @mx_answers; + my $query = $res->search($name, 'A'); if ($query) { - foreach my $rr ($query->answer) { - next unless $rr->type eq "A"; + 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); } } diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index b836255..e9701a5 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -17,6 +17,12 @@ use POSIX qw(:sys_wait_h :errno_h :signal_h); use strict; $| = 1; +my $has_ipv6 = Qpsmtpd::Constants::has_ipv6; + +if ($has_ipv6) { + use Socket6; +} + # Configuration my $MAXCONN = 15; # max simultaneous connections my @PORT; # port number(s) @@ -54,12 +60,17 @@ GetOptions('h|help' => \&usage, ) || &usage; # detaint the commandline -@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\-.]+)(?::(\d+))?$/) { + if ($LOCALADDR[$_] =~ /^(\[.*\]|[\d\w\-.]+)(?::(\d+))?$/) { if ( defined $2 ) { push @LISTENADDR, { 'addr' => $1, 'port' => $2 }; } else { @@ -106,16 +117,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 (@LISTENADDR) { - my $server = IO::Socket::INET->new(LocalPort => $listen_addr->{'port'}, + 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->{'addr'}:$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); } @@ -208,14 +227,19 @@ while (1) { next; } IO::Handle::blocking($client, 1); - my ($port, $iaddr) = sockaddr_in($hisaddr); + my ($port, $iaddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($hisaddr)) : (sockaddr_in6($hisaddr)); my $localsockaddr = getsockname($client); - my ($lport, $laddr) = sockaddr_in($localsockaddr); + my ($lport, $laddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($localsockaddr)) : (sockaddr_in6($localsockaddr)); + my $nto_iaddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($iaddr)) : (inet_ntop(AF_INET6, $iaddr)); + my $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 => inet_ntoa($iaddr), + remote_ip => $nto_iaddr, remote_port => $port, - local_ip => inet_ntoa($laddr), + local_ip => $nto_laddr, local_port => $lport, max_conn_ip => $MAXCONNIP, child_addrs => [values %childstatus], @@ -259,11 +283,18 @@ while (1) { ::log(LOGINFO, "Connection Timed Out"); exit; }; - $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}"; From 3837fabc9fbfa2c583ade30c3c779a8abf6f6c37 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 14 Sep 2006 19:48:37 +0000 Subject: [PATCH 097/134] Ask and ye shall receive git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@659 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 1 + lib/Qpsmtpd/TcpServer/Prefork.pm | 2 +- plugins/auth/auth_vpopmail_sql | 2 +- plugins/count_unrecognized_commands | 7 +++++- plugins/relay_only | 35 +++++++++++++++++++++++++++++ qpsmtpd-prefork | 6 +++-- 6 files changed, 48 insertions(+), 5 deletions(-) create mode 100644 plugins/relay_only diff --git a/Changes b/Changes index 469de24..3838f9c 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,5 @@ 0.33 + relay_only plugin for smart relay host. (John Peacock) Experimental IPv6 support (forkserver only). (Mike Williams) diff --git a/lib/Qpsmtpd/TcpServer/Prefork.pm b/lib/Qpsmtpd/TcpServer/Prefork.pm index 67bc7ad..1351266 100644 --- a/lib/Qpsmtpd/TcpServer/Prefork.pm +++ b/lib/Qpsmtpd/TcpServer/Prefork.pm @@ -30,7 +30,7 @@ sub read_input { $_ =~ s/\r?\n$//s; # advanced chomp $self->log(LOGDEBUG, "dispatching $_"); $self->connection->notes('original_string', $_); - defined $self->dispatch(split / +/, $_) + defined $self->dispatch(split / +/, $_, 2) or $self->respond(502, "command unrecognized: '$_'"); alarm $timeout; } diff --git a/plugins/auth/auth_vpopmail_sql b/plugins/auth/auth_vpopmail_sql index 8f07479..7c8626d 100644 --- a/plugins/auth/auth_vpopmail_sql +++ b/plugins/auth/auth_vpopmail_sql @@ -65,7 +65,7 @@ sub authsql { my $connect = "dbi:mysql:dbname=vpopmail"; my $dbuser = "vpopmailuser"; - my $dbpasswd = "**********"; + my $dbpasswd = "vpoppasswd"; my $dbh = DBI->connect( $connect, $dbuser, $dbpasswd ); $dbh->{ShowErrorStatement} = 1; 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/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/qpsmtpd-prefork b/qpsmtpd-prefork index 5c8fcaa..6814091 100755 --- a/qpsmtpd-prefork +++ b/qpsmtpd-prefork @@ -1,4 +1,4 @@ -#!/usr/bin/perl +#!/usr/bin/perl -Tw # High performance pre-forking qpsmtpd daemon, Copyright (C) 2006 SoftScan # http://www.softscan.co.uk # @@ -96,6 +96,8 @@ GetOptions( '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); @@ -336,7 +338,7 @@ sub new_child { # continue to accept connections until "old age" is reached for (my $i = 0 ; $i < $child_lifetime ; $i++) { # accept a connection - $0 = 'qpsmtpd child'; # set pretty child name in process listing + #$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 From d218bfea82dbcae4c25da01b4540be859d61f2e0 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Fri, 22 Sep 2006 15:31:28 +0000 Subject: [PATCH 098/134] Correctly handle the case where a given AUTH mechanism is requested by a [stupid] MUA, but isn't implemented with existing auth plugins. Based on patch from Brian Szymanski. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@660 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 2 ++ lib/Qpsmtpd/Auth.pm | 4 ++-- lib/Qpsmtpd/SMTP.pm | 17 +++++++++++++---- 3 files changed, 17 insertions(+), 6 deletions(-) diff --git a/Changes b/Changes index 3838f9c..b51a93b 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,6 @@ 0.33 + Do the right thing for unimplemented AUTH mechanisms (Brian Szymanski) + relay_only plugin for smart relay host. (John Peacock) Experimental IPv6 support (forkserver only). (Mike Williams) diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm index d000616..6e9a2a5 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/lib/Qpsmtpd/Auth.pm @@ -17,7 +17,6 @@ sub SASL { # $DB::single = 1; my ( $session, $mechanism, $prekey ) = @_; my ( $user, $passClear, $passHash, $ticket, $loginas ); - $mechanism = lc($mechanism); if ( $mechanism eq "plain" ) { if (!$prekey) { @@ -76,7 +75,8 @@ sub SASL { ( $user, $passHash ) = split( ' ', decode_base64($line) ); } else { - $session->respond( 500, "Unrecognized authentification mechanism" ); + #this error is now caught in SMTP.pm's sub auth + $session->respond( 500, "Internal server error" ); return DECLINED; } diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index cdace58..781c763 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -1,6 +1,7 @@ package Qpsmtpd::SMTP; use Qpsmtpd; @ISA = qw(Qpsmtpd); +my %auth_mechanisms = (); package Qpsmtpd::SMTP; use strict; @@ -206,7 +207,6 @@ sub ehlo { : (); # Check for possible AUTH mechanisms - my %auth_mechanisms; HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { if ( $hook =~ m/^auth-?(.+)?$/ ) { if ( defined $1 ) { @@ -239,9 +239,11 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { sub auth { my ($self, $line) = @_; my ($rc, $sub) = $self->run_hooks('auth_parse'); - my ($ok, $arg, @stuff) = Qpsmtpd::Command->parse('auth', $line, $sub); - return $self->respond(501, $arg || "Syntax error in command") + my ($ok, $mechanism, @stuff) = Qpsmtpd::Command->parse('auth', $line, $sub); + return $self->respond(501, $mechanism || "Syntax error in command") unless ($ok == OK); + + $mechanism = lc($mechanism); #they AUTH'd once already @@ -254,7 +256,14 @@ sub auth { if ( ($self->config('tls_before_auth'))[0] and $self->transaction->notes('tls_enabled') ); - return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff ); + # if we don't have a plugin implementing this auth mechanism, 504 + if( exists $auth_mechanisms{$mechanism} ) { + return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $mechanism, @stuff ); + } else { + $self->respond( 504, "Unimplemented authentification mechanism: $mechanism" ); + return DENY; + } + } sub mail { From 9028958307d301158ef1f39d846593ddaf036db5 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Sun, 24 Sep 2006 00:53:01 +0000 Subject: [PATCH 099/134] Fix careless capitalization error git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@661 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 781c763..eb6849e 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -243,7 +243,7 @@ sub auth { return $self->respond(501, $mechanism || "Syntax error in command") unless ($ok == OK); - $mechanism = lc($mechanism); + $mechanism = uc($mechanism); #they AUTH'd once already @@ -611,10 +611,18 @@ sub data { # 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"); if ($rc == DONE) { From a7a3031440b908cb4be2c513abba000a95364e5f Mon Sep 17 00:00:00 2001 From: John Peacock Date: Sun, 24 Sep 2006 14:55:48 +0000 Subject: [PATCH 100/134] OK, really, this time the capitalization for AUTH mechanisms is correct. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@662 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index eb6849e..e26e569 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -243,7 +243,7 @@ sub auth { return $self->respond(501, $mechanism || "Syntax error in command") unless ($ok == OK); - $mechanism = uc($mechanism); + $mechanism = lc($mechanism); #they AUTH'd once already @@ -257,7 +257,7 @@ sub auth { and $self->transaction->notes('tls_enabled') ); # if we don't have a plugin implementing this auth mechanism, 504 - if( exists $auth_mechanisms{$mechanism} ) { + if( exists $auth_mechanisms{uc($mechanism)} ) { return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $mechanism, @stuff ); } else { $self->respond( 504, "Unimplemented authentification mechanism: $mechanism" ); From 9c39c530b2e4ac5e44375386df722391b73bdfe7 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 4 Oct 2006 13:39:27 +0000 Subject: [PATCH 101/134] Allow override of TLS security methods using CIPHER_STRINGS passed to IO::Socket::SSL. Brian Szymanski git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@663 958fd67b-6ff1-0310-b445-bb7760255be9 --- config.sample/tls_ciphers | 4 ++++ plugins/tls | 22 ++++++++++++++++++++-- 2 files changed, 24 insertions(+), 2 deletions(-) create mode 100644 config.sample/tls_ciphers diff --git a/config.sample/tls_ciphers b/config.sample/tls_ciphers new file mode 100644 index 0000000..4b02935 --- /dev/null +++ b/config.sample/tls_ciphers @@ -0,0 +1,4 @@ +# Override HIGH security using suitable string from available ciphers at +# L +# See plugins/tls for details. +MEDIUM diff --git a/plugins/tls b/plugins/tls index 8b0e082..c21c792 100644 --- a/plugins/tls +++ b/plugins/tls @@ -46,6 +46,15 @@ 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); @@ -62,14 +71,17 @@ sub init { $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_ca_file => $self->tls_ca, - SSL_cipher_list => 'HIGH', + SSL_cipher_list => $self->tls_ciphers, SSL_server => 1 ) or die "Could not create SSL context: $!"; # now extract the password... @@ -149,7 +161,7 @@ sub _convert_to_ssl { SSL_cert_file => $self->tls_cert, SSL_key_file => $self->tls_key, SSL_ca_file => $self->tls_ca, - SSL_cipher_list => 'HIGH', + SSL_cipher_list => $self->tls_ciphers, SSL_server => 1, SSL_reuse_ctx => $self->ssl_context, ) or die "Could not create SSL socket: $!"; @@ -191,6 +203,12 @@ sub tls_ca { $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; From 6c3dc88f375a85b9e820315350522defd353bf59 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 4 Oct 2006 13:49:49 +0000 Subject: [PATCH 102/134] Buffer output of Qpsmtpd::TcpServer::respond() for broken clients who don't follow RFC's for multiline responses. Patch from Brian Szymanski git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@664 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/TcpServer.pm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index 1378fa3..7935477 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -72,11 +72,13 @@ 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); + $buf .= "$line\r\n"; } + print $buf or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0); return 1; } From 413d3c38d318bfd3914bcf51ea4e52736f8d4ab4 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 4 Oct 2006 15:10:23 +0000 Subject: [PATCH 103/134] Sample tls_ciphers configuration should have HIGH as a default. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@665 958fd67b-6ff1-0310-b445-bb7760255be9 --- config.sample/tls_ciphers | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config.sample/tls_ciphers b/config.sample/tls_ciphers index 4b02935..e889731 100644 --- a/config.sample/tls_ciphers +++ b/config.sample/tls_ciphers @@ -1,4 +1,4 @@ -# Override HIGH security using suitable string from available ciphers at +# Override default security using suitable string from available ciphers at # L # See plugins/tls for details. -MEDIUM +HIGH From da93a9ca3b7fe24147ccb2f74febf0231ba035de Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 25 Oct 2006 17:07:27 +0000 Subject: [PATCH 104/134] Add log socket support to syslog plugin. (Peter Eisch) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@666 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 2 ++ plugins/logging/syslog | 25 +++++++++++++++++++++++-- 2 files changed, 25 insertions(+), 2 deletions(-) diff --git a/Changes b/Changes index b51a93b..07dbd3b 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,6 @@ 0.33 + 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) diff --git a/plugins/logging/syslog b/plugins/logging/syslog index 1fb3899..6ea90b6 100644 --- a/plugins/logging/syslog +++ b/plugins/logging/syslog @@ -17,7 +17,7 @@ configuration file: =over -logging/syslog [loglevel l] [priority p] [ident str] [facility f] +logging/syslog [loglevel l] [priority p] [ident str] [facility f] [logsock t] For example: @@ -74,11 +74,27 @@ The default is 'qpsmtpd'. 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 @@ -92,7 +108,7 @@ Please see the LICENSE file included with qpsmtpd for details. use strict; use warnings; -use Sys::Syslog; +use Sys::Syslog qw(:DEFAULT setlogsock); sub register { my ($self, $qp, @args) = @_; @@ -133,6 +149,11 @@ sub register { $facility = $1; } + if ($args{logsock}) { + my @logopt = split(/,/, $args{logsock}); + setlogsock(@logopt); + } + unless (openlog $ident, $logopt, $facility) { warn "Error opening syslog output"; return; From bdf3f983a72d830e3897c2f22c1b880739864071 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 26 Oct 2006 15:50:02 +0000 Subject: [PATCH 105/134] Add hardcoded mapping between postfix's cleanup errors and corresponding Qpsmtpd::DSN value. (David Muir Sharnoff) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@667 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/queue/postfix-queue | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/plugins/queue/postfix-queue b/plugins/queue/postfix-queue index 03a0244..0926d8c 100644 --- a/plugins/queue/postfix-queue +++ b/plugins/queue/postfix-queue @@ -86,6 +86,39 @@ sub hook_queue { # $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags')); my ($status, $qid, $reason) = Qpsmtpd::Postfix->inject_mail($transaction); + if ($status) { + # this section needs to be kept in sync with the cleanup_stat_map + # array found in Postfix source file src/global/cleanup_strerror.c + # which in turn uses constants defined in src/global/cleanup_user.h + if ($status & (1<<8)) { + # CLEANUP_STAT_DEFER + return(DENYSOFT, $reason || "service unavailable (#4.7.1)"); + } elsif ($status & (1<<7)) { + # CLEANUP_STAT_PROXY + return(DENYSOFT, $reason || "proxy reject (#4.3.0)"); + } elsif ($status & (1<<0)) { + # CLEANUP_STAT_BAD + return(DENYSOFT, $reason || "internal prototcal error (#4.3.0)"); + } elsif ($status & (1<<6)) { + # CLEANUP_STAT_RCPT + return Qpsmtpd::DSN->addr_unspecified(DENY, $reason || "no recipients specified"); + } elsif ($status & (1<<4)) { + # CLEANUP_STAT_HOPS + return Qpsmtpd::DSN->too_many_hops(DENY, $reason || "too many hops"); + } elsif ($status & (1<<2)) { + # CLEANUP_STAT_SIZE + return Qpsmtpd::DSN->sys_msg_too_big(DENY, $reason || "message file too big"); + } elsif ($status & (1<<3)) { + # CLEANUP_STAT_CONT + return Qpsmtpd::DSN->media_conv_prohibited(DENY, $reason || "message content rejected"); + } elsif ($status & (1<<1)) { + # CLEANUP_STAT_WRITE + return (DECLINED, $reason || "queue file write error"); + } else { + # we have no idea why we're here. + return (DECLINED, $reason || "unknown error from postfix/cleanup: $status"); + } + } $status and return (DECLINED, "Unable to queue message ($status, $reason)"); my $msg_id = $transaction->header->get('Message-Id') || ''; From 86e202d19e94e5980ca6f7a58b28a5992fc7ed20 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 1 Nov 2006 02:08:30 +0000 Subject: [PATCH 106/134] Add program to extract Postfix constants from source files and generate Qpsmtpd::Postfix::Constants (to be used by postfix-queue). Patch by Hanno Hecker. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@668 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Postfix/Constants.pm | 86 ++++++++++++++++ plugins/queue/postfix-queue | 162 +++++++++++++++++++++---------- 2 files changed, 198 insertions(+), 50 deletions(-) create mode 100644 lib/Qpsmtpd/Postfix/Constants.pm 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/plugins/queue/postfix-queue b/plugins/queue/postfix-queue index 0926d8c..fa471c5 100644 --- a/plugins/queue/postfix-queue +++ b/plugins/queue/postfix-queue @@ -14,9 +14,10 @@ not start with a ``/'', it is treated as a flag for cleanup (see below). If set, the environment variable POSTFIXQUEUE overrides this setting. All other parameters are flags for cleanup, no flags are enabled by default. -Known flags are: +See below in ``POSTFIX COMPATIBILITY'' for flags understood by your postfix +version. Supported by all postfix versions E= 2.1 are: -=over 3 +=over 4 =item FLAG_FILTER @@ -32,21 +33,99 @@ Setting this flag enables (for example) the I parameter 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; - -# -# postfix' cleanup flags: -use constant CLEANUP_FLAG_FILTER => (1 << 1); # /* Enable content filter */ -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 Qpsmtpd::Postfix::Constants; sub register { my ($self, $qp, @args) = @_; + $self->log(LOGDEBUG, "using constants generated from Postfix" + ."v$postfix_version"); $self->{_queue_flags} = 0; if (@args > 0) { if ($args[0] =~ m#^/#) { @@ -57,16 +136,11 @@ sub register { } foreach (@args) { - if ($_ eq 'FLAG_FILTER') { - $self->{_queue_flags} |= CLEANUP_FLAG_FILTER; + if ($self->can("CLEANUP_".$_) and /^(FLAG_[A-Z0-9_]+)$/) { + $_ = $1; + $self->{_queue_flags} |= (eval "CLEANUP_$_;" || 0); + #print STDERR "queue flag: $_: ".$self->{_queue_flags}."\n"; } - elsif ($_ eq 'FLAG_BCC_OK') { - $self->{_queue_flags} |= CLEANUP_FLAG_BCC_OK; - } - elsif ($_ eq 'FLAG_MAP_OK') { - $self->{_queue_flags} |= CLEANUP_FLAG_MAP_OK; - } - else { $self->log(LOGWARN, "Ignoring unkown cleanup flag $_"); } @@ -84,46 +158,34 @@ sub hook_queue { my ($self, $transaction) = @_; $transaction->notes('postfix-queue-flags', $self->{_queue_flags}); -# $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags')); + # $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags')); my ($status, $qid, $reason) = Qpsmtpd::Postfix->inject_mail($transaction); if ($status) { - # this section needs to be kept in sync with the cleanup_stat_map - # array found in Postfix source file src/global/cleanup_strerror.c - # which in turn uses constants defined in src/global/cleanup_user.h - if ($status & (1<<8)) { - # CLEANUP_STAT_DEFER - return(DENYSOFT, $reason || "service unavailable (#4.7.1)"); - } elsif ($status & (1<<7)) { - # CLEANUP_STAT_PROXY - return(DENYSOFT, $reason || "proxy reject (#4.3.0)"); - } elsif ($status & (1<<0)) { - # CLEANUP_STAT_BAD - return(DENYSOFT, $reason || "internal prototcal error (#4.3.0)"); - } elsif ($status & (1<<6)) { - # CLEANUP_STAT_RCPT - return Qpsmtpd::DSN->addr_unspecified(DENY, $reason || "no recipients specified"); - } elsif ($status & (1<<4)) { - # CLEANUP_STAT_HOPS - return Qpsmtpd::DSN->too_many_hops(DENY, $reason || "too many hops"); - } elsif ($status & (1<<2)) { - # CLEANUP_STAT_SIZE - return Qpsmtpd::DSN->sys_msg_too_big(DENY, $reason || "message file too big"); - } elsif ($status & (1<<3)) { - # CLEANUP_STAT_CONT - return Qpsmtpd::DSN->media_conv_prohibited(DENY, $reason || "message content rejected"); - } elsif ($status & (1<<1)) { - # CLEANUP_STAT_WRITE - return (DECLINED, $reason || "queue file write error"); - } else { - # we have no idea why we're here. - return (DECLINED, $reason || "unknown error from postfix/cleanup: $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)"); } - $status and return (DECLINED, "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)"); } -#vim: sw=2 ts=8 +# vim: sw=2 ts=8 syn=perl From 0786b606997818a57452811e8093c062eb79b3fe Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 1 Nov 2006 02:28:41 +0000 Subject: [PATCH 107/134] Script to generate Qpsmtpd::Postfix::Constants from the Postfix source. From Hanno Hecker (tweaks by John Peacock). git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@669 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 3 + lib/Qpsmtpd/Postfix/pf2qp.pl | 115 +++++++++++++++++++++++++++++++++++ 2 files changed, 118 insertions(+) create mode 100755 lib/Qpsmtpd/Postfix/pf2qp.pl diff --git a/Changes b/Changes index 07dbd3b..83c8b98 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,7 @@ 0.33 + New Qpsmtpd::Postfix::Constants to encapsulate all of the current return + codes from Postfix, plus script to generate it. (Hanno Hecker) + Add ability to specific socket for syslog (Peter Eisch) Do the right thing for unimplemented AUTH mechanisms (Brian Szymanski) 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; From 02bf7b80e52d78825a3e2e3e8151e36fb6ca4f13 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sun, 5 Nov 2006 09:47:18 +0000 Subject: [PATCH 108/134] Fix startup of qpsmtpd-forkserver on hosts lacking Socket6 (it's not enough to have 'use Socket6' in a conditional, it must be evalled also) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@670 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index e9701a5..67b0889 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -20,7 +20,7 @@ $| = 1; my $has_ipv6 = Qpsmtpd::Constants::has_ipv6; if ($has_ipv6) { - use Socket6; + eval 'use Socket6'; } # Configuration From af5f025b51e56aa03af7165263796d3c035c9f95 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sun, 5 Nov 2006 09:54:03 +0000 Subject: [PATCH 109/134] (Working) support for multiple plugin directories, with a fix from Nick Leverton . The inner _load_plugins() routine is changed to load only a single plugin given a search path, and the (two) calls to it pass in the configured list of plugin dirs. The non-module case of _load_plugin() simply loops on the plugin dir list until a matching plugin file is found; the first match stops the search for that plugin, regardless of success or failure in loading it. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@671 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 4 ++ lib/Qpsmtpd.pm | 130 +++++++++++++++++++++++++++---------------------- 2 files changed, 76 insertions(+), 58 deletions(-) diff --git a/Changes b/Changes index 83c8b98..b7b10f5 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,7 @@ +0.3x + Add support for multiple plugin directories, whose paths are given by the + 'plugin_dirs' configuration. (Devin Carraway, Nick Leverton) + 0.33 New Qpsmtpd::Postfix::Constants to encapsulate all of the current return codes from Postfix, plus script to generate it. (Hanno Hecker) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 417dc85..36d7f45 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -19,14 +19,20 @@ sub load_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); + $configdir = $self->config_dir('plugin_dirs'); + $configfile = "$configdir/plugin_dirs"; + my @plugin_dirs = $self->_config_from_file($configfile,'plugin_dirs'); + + my @loaded; + for my $logger (@loggers) { + push @loaded, $self->_load_plugin($logger, @plugin_dirs); + } - foreach my $logger (@loggers) { + foreach my $logger (@loaded) { $self->log(LOGINFO, "Loaded $logger"); } - + return @loggers; } @@ -121,9 +127,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 ($name) = ($0 =~ m!(.*?)/([^/]+)$!); + @plugin_dirs = ( "$name/plugins" ); + } + return @plugin_dirs; } sub get_qmail_config { @@ -244,70 +256,72 @@ sub load_plugins { $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) { + push @loaded, $self->_load_plugin($plugin_line, $self->plugin_dirs); + } - @plugins = $self->_load_plugins($dir, @plugins); - - 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; + 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 + 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; - - $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/; + # 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; + + $package = "Qpsmtpd::Plugin::$plugin_name"; + + # don't reload plugins if they are already loaded + unless ( defined &{"${package}::plugin_name"} ) { + PLUGIN_DIR: for my $dir (@plugin_dirs) { + if (-e "$dir/$plugin") { + Qpsmtpd::Plugin->compile($plugin_name, $package, + "$dir/$plugin", $self->{_test_mode}); + $self->log(LOGDEBUG, "Loading $plugin_line from $dir/$plugin") + unless $plugin_line =~ /logging/; + last PLUGIN_DIR; + } } } - - my $plug = $package->new(); - push @ret, $plug; - $plug->_register($self, @args); - } + + my $plug = $package->new(); + $plug->_register($self, @args); + push @ret, $plug; return @ret; } From b52b7b50c22eeee2b40ff9ff4b6b274f188d1083 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sun, 5 Nov 2006 10:38:16 +0000 Subject: [PATCH 110/134] Support configured greylisting db location, and look in the distro-friendly directory /var/lib/qpsmtpd in addition to the previous $QPHOME locations. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@672 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 4 ++++ plugins/greylisting | 24 ++++++++++++++++++++++-- 2 files changed, 26 insertions(+), 2 deletions(-) diff --git a/Changes b/Changes index b7b10f5..6e13ee5 100644 --- a/Changes +++ b/Changes @@ -2,6 +2,10 @@ 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) + 0.33 New Qpsmtpd::Postfix::Constants to encapsulate all of the current return codes from Postfix, plus script to generate it. (Hanno Hecker) 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"); From 839eddc558d53d7f06f9dce95896602b3e957e73 Mon Sep 17 00:00:00 2001 From: "Peter J. Holzer" Date: Mon, 6 Nov 2006 09:06:39 +0000 Subject: [PATCH 111/134] Older perls don't know constant AF_INET6, but don't mind a function which is never called. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@673 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 67b0889..5d8d8b4 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -230,9 +230,9 @@ while (1) { 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)); + 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://; From ecb24ef131e7f454b88d1003dd5d3b262f728d08 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Wed, 8 Nov 2006 10:25:45 +0000 Subject: [PATCH 112/134] Fix use of the default plugin dir path in the logging startup when no plugin_dir is configured. Slightly worsens duplication of code with plugin_dir() to continue avoiding infinite recursion. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@674 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 36d7f45..a1ce3d0 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -23,6 +23,10 @@ sub load_logging { $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) { From b7f468404b1ad9d5d64c5ac08cbd1157a2f06f82 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Wed, 22 Nov 2006 16:30:37 +0000 Subject: [PATCH 113/134] Fixup qpsmtpd-prefork, et al, to correctly load Constants. Make child process pretty name optional for qpsmtpd-prefork. Ignore rather than crash for uninstalled plugins. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@675 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 6 ++++++ lib/Qpsmtpd.pm | 15 ++++++++++----- lib/Qpsmtpd/SMTP/Prefork.pm | 1 + lib/Qpsmtpd/TcpServer/Prefork.pm | 11 ++++++++++- qpsmtpd-prefork | 8 +++++++- 5 files changed, 34 insertions(+), 7 deletions(-) diff --git a/Changes b/Changes index 6e13ee5..ac518db 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,10 @@ 0.3x + 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) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index a1ce3d0..18c0f56 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -122,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"; @@ -136,8 +136,8 @@ sub plugin_dirs { my @plugin_dirs = $self->config('plugin_dirs'); unless (@plugin_dirs) { - my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); - @plugin_dirs = ( "$name/plugins" ); + my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!; + @plugin_dirs = ( "$path/plugins" ); } return @plugin_dirs; } @@ -263,7 +263,8 @@ sub load_plugins { my @loaded; for my $plugin_line (@plugins) { - push @loaded, $self->_load_plugin($plugin_line, $self->plugin_dirs); + my $this_plugin = $self->_load_plugin($plugin_line, $self->plugin_dirs); + push @loaded, $this_plugin if $this_plugin; } return @loaded; @@ -319,6 +320,10 @@ sub _load_plugin { unless $plugin_line =~ /logging/; last PLUGIN_DIR; } + else { + $self->log(LOGDEBUG, "Failed to load plugin - $plugin - ignoring"); + return 0; + } } } } diff --git a/lib/Qpsmtpd/SMTP/Prefork.pm b/lib/Qpsmtpd/SMTP/Prefork.pm index 336c2e2..6c90386 100644 --- a/lib/Qpsmtpd/SMTP/Prefork.pm +++ b/lib/Qpsmtpd/SMTP/Prefork.pm @@ -1,5 +1,6 @@ package Qpsmtpd::SMTP::Prefork; use Qpsmtpd::SMTP; +use Qpsmtpd::Constants; @ISA = qw(Qpsmtpd::SMTP); sub dispatch { diff --git a/lib/Qpsmtpd/TcpServer/Prefork.pm b/lib/Qpsmtpd/TcpServer/Prefork.pm index 1351266..8d34099 100644 --- a/lib/Qpsmtpd/TcpServer/Prefork.pm +++ b/lib/Qpsmtpd/TcpServer/Prefork.pm @@ -1,6 +1,7 @@ package Qpsmtpd::TcpServer::Prefork; use Qpsmtpd::TcpServer; use Qpsmtpd::SMTP::Prefork; +use Qpsmtpd::Constants; @ISA = qw(Qpsmtpd::SMTP::Prefork Qpsmtpd::TcpServer); @@ -12,7 +13,7 @@ sub start_connection { #reset info $self->{_connection} = Qpsmtpd::Connection->new(); #reset connection $self->{_transaction} = Qpsmtpd::Transaction->new(); #reset transaction - $self->SUPER::start_connection(); + $self->SUPER::start_connection(@_); } sub read_input { @@ -53,4 +54,12 @@ sub respond { 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/qpsmtpd-prefork b/qpsmtpd-prefork index 6814091..2874054 100755 --- a/qpsmtpd-prefork +++ b/qpsmtpd-prefork @@ -59,6 +59,7 @@ my $d_start = 0; my $quiet = 0; my $status = 0; my $signal = ''; +my $pretty = 0; my $user; # help text @@ -73,6 +74,7 @@ Usage: qpsmtpd-prefork [ options ] --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) @@ -91,6 +93,7 @@ GetOptions( '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, @@ -338,7 +341,10 @@ sub new_child { # continue to accept connections until "old age" is reached for (my $i = 0 ; $i < $child_lifetime ; $i++) { # accept a connection - #$0 = 'qpsmtpd child'; # set pretty child name in process listing + 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 From e299135526dfdc9e813f93bacee769e5877ed6f3 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 30 Nov 2006 22:10:55 +0000 Subject: [PATCH 114/134] Initial work for continuations (and thus the async server). (intention is to check bits in that don't break anything, so we can always return to a stable base) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@676 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 127 ++++++++++++++++++++++++--------------- lib/Qpsmtpd/Constants.pm | 18 +++--- 2 files changed, 90 insertions(+), 55 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 18c0f56..2574986 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -344,57 +344,90 @@ sub run_hooks { my $hooks = $self->{hooks}; if ($hooks->{$hook}) { my @r; - for my $code (@{$hooks->{$hook}}) { - if ( $hook eq 'logging' ) { # without calling $self->log() - eval { (@r) = $code->{code}->($self, $self->transaction, @_); }; - $@ and warn("FATAL LOGGING PLUGIN ERROR: ", $@) and next; - } - else { - $self->varlog(LOGINFO, $hook, $code->{name}); - eval { (@r) = $code->{code}->($self, $self->transaction, @_); }; - $@ 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"); - } - - # 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 ".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]; - @r = map { split /\n/ } @r; - return @r; + my @local_hooks = @{$hooks->{$hook}}; + $self->{_continuation} = [$hook, [@_], @local_hooks]; + return $self->run_continuation(); } return (0, ''); } +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}; + $self->{_continuation} = undef; + my $hook = shift @$todo || die "No hook in the continuation"; + my $args = shift @$todo || die "No hook args in the continuation"; + my @r; + while (@$todo) { + my $code = shift @$todo; + 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(LOGINFO, $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]; + @r = map { split /\n/ } @r; + return $self->hook_responder($hook, \@r, $args); +} + +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); + } + return $code, @$msg; +} + sub _register_hook { my $self = shift; my ($hook, $code, $unshift) = @_; diff --git a/lib/Qpsmtpd/Constants.pm b/lib/Qpsmtpd/Constants.pm index 4152131..0480d58 100644 --- a/lib/Qpsmtpd/Constants.pm +++ b/lib/Qpsmtpd/Constants.pm @@ -17,14 +17,16 @@ my %log_levels = ( # 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, + 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; From 8b50f9f0ddfea0e0fdf47ca81fae05b877057ec5 Mon Sep 17 00:00:00 2001 From: Hanno Hecker Date: Thu, 7 Dec 2006 10:29:41 +0000 Subject: [PATCH 115/134] removed spamassassin doc from dnsbl git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@677 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/dnsbl | 22 +++------------------- 1 file changed, 3 insertions(+), 19 deletions(-) diff --git a/plugins/dnsbl b/plugins/dnsbl index ab42eb5..6526cbd 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -2,19 +2,12 @@ =head1 NAME -spamassassin - SpamAssassin integration for qpsmtpd +dnsbl - handle DNS BlackList lookups =head1 DESCRIPTION -Plugin that checks if the mail is spam by using the "spamd" daemon -from the SpamAssassin package. F - -SpamAssassin 2.6 or newer is required. - -=head1 CONFIG - -Configured in the config/dnsbl_zones files. One line per zone name, -for example +Plugin that checks the IP address of the incoming connection against +a configurable set of RBL services. =cut @@ -209,15 +202,6 @@ sub hook_disconnect { 1; -=head1 NAME - -dnsbl - handle DNS BlackList lookups - -=head1 DESCRIPTION - -Plugin that checks the IP address of the incoming connection against -a configurable set of RBL services. - =head1 Usage Add the following line to the config/plugins file: From 0449fbfb50404b8ed2cd25f0b8b3bb899dfdb925 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 8 Dec 2006 19:37:47 +0000 Subject: [PATCH 116/134] Fix a showstopper of a bug in Command.pm which meant all commands would be parsed wrong git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@678 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Command.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/Command.pm b/lib/Qpsmtpd/Command.pm index dddb7ae..b06e5ad 100644 --- a/lib/Qpsmtpd/Command.pm +++ b/lib/Qpsmtpd/Command.pm @@ -63,7 +63,7 @@ sub parse { return (OK) unless defined $line; # trivial case my $self = {}; bless $self, $me; - $cmd = lc $1; + $cmd = lc $cmd; if ($sub and (ref($sub) eq 'CODE')) { my @ret = eval { $sub->($self, $cmd, $line); }; if ($@) { @@ -99,6 +99,7 @@ sub parse_rcpt { sub parse_mail { my ($self,$cmd,$line) = @_; return (DENY, "Syntax error in command") unless $line =~ s/^from:\s*//i; + print "parse_mail: $line\n"; return &_get_mail_params($cmd, $line); } ### RFC 1869: From 2b709d664c367886babfe933e80766bd235bab83 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 8 Dec 2006 19:46:18 +0000 Subject: [PATCH 117/134] Async qpsmtpd (still entirely compatible with non-async version) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@679 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 4 +- lib/Qpsmtpd/PollServer.pm | 392 ++++++++++++++++++++++++++++++++++++++ lib/Qpsmtpd/SMTP.pm | 289 +++++++++++++++++----------- qpsmtpd-async | 311 ++++++++++++++++++++++++++++++ 4 files changed, 887 insertions(+), 109 deletions(-) create mode 100644 lib/Qpsmtpd/PollServer.pm create mode 100755 qpsmtpd-async diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 2574986..2338042 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -348,7 +348,7 @@ sub run_hooks { $self->{_continuation} = [$hook, [@_], @local_hooks]; return $self->run_continuation(); } - return (0, ''); + return $self->hook_responder($hook, [0, ''], [@_]); } sub run_continuation { @@ -423,7 +423,7 @@ sub hook_responder { my $responder = $hook . '_respond'; if (my $meth = $self->can($responder)) { - return $meth->($self, $code, $msg, @$args); + return $meth->($self, $code, $msg, $args); } return $code, @$msg; } diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm new file mode 100644 index 0000000..f2de0dc --- /dev/null +++ b/lib/Qpsmtpd/PollServer.pm @@ -0,0 +1,392 @@ +# $Id: Server.pm,v 1.10 2005/02/14 22:04:48 msergeant Exp $ + +package Qpsmtpd::PollServer; + +use base ('Danga::Client', 'Qpsmtpd::SMTP'); +# use fields required to be a subclass of Danga::Client. Have to include +# all fields used by Qpsmtpd.pm here too. +use fields qw( + input_sock + mode + header_lines + in_header + data_size + max_size + hooks + start_time + cmd_timeout + _auth_mechanism + _auth_state + _auth_ticket + _auth_user + _commands + _config_cache + _connection + _transaction + _test_mode + _extras + _continuation +); +use Qpsmtpd::Constants; +use Qpsmtpd::Address; +use ParaDNS; +use Mail::Header; +use POSIX qw(strftime); +use Socket qw(inet_aton AF_INET CRLF); +use Time::HiRes qw(time); +use strict; + +sub max_idle_time { 60 } +sub max_connect_time { 1200 } + +sub input_sock { + my $self = shift; + @_ and $self->{input_sock} = shift; + $self->{input_sock} || $self; +} + +sub new { + my Qpsmtpd::PollServer $self = shift; + + $self = fields::new($self) unless ref $self; + $self->SUPER::new( @_ ); + $self->{cmd_timeout} = 5; + $self->{start_time} = time; + $self->{mode} = 'connect'; + $self->load_plugins; + $self->load_logging; + return $self; +} + +sub uptime { + my Qpsmtpd::PollServer $self = shift; + + return (time() - $self->{start_time}); +} + +sub reset_for_next_message { + my Qpsmtpd::PollServer $self = shift; + $self->SUPER::reset_for_next_message(@_); + + $self->{_commands} = { + ehlo => 1, + helo => 1, + rset => 1, + mail => 1, + rcpt => 1, + data => 1, + help => 1, + vrfy => 1, + noop => 1, + quit => 1, + auth => 0, # disabled by default + }; + $self->{mode} = 'cmd'; + $self->{_extras} = {}; +} + +sub respond { + my Qpsmtpd::PollServer $self = shift; + my ($code, @messages) = @_; + while (my $msg = shift @messages) { + my $line = $code . (@messages ? "-" : " ") . $msg; + $self->write("$line\r\n"); + } + return 1; +} + +sub fault { + my Qpsmtpd::PollServer $self = shift; + $self->SUPER::fault(@_); + return; +} + +sub process_line { + my Qpsmtpd::PollServer $self = shift; + my $line = shift || return; + if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; } + eval { $self->_process_line($line) }; + if ($@) { + print STDERR "Error: $@\n"; + return $self->fault("command failed unexpectedly") if $self->{mode} eq 'cmd'; + return $self->fault("error processing data lines") if $self->{mode} eq 'data'; + return $self->fault("unknown error"); + } + return; +} + +sub _process_line { + my Qpsmtpd::PollServer $self = shift; + my $line = shift; + + if ($self->{mode} eq 'connect') { + $self->{mode} = 'cmd'; + my $rc = $self->start_conversation; + return; + } + elsif ($self->{mode} eq 'cmd') { + $line =~ s/\r?\n//; + return $self->process_cmd($line); + } + elsif ($self->{mode} eq 'data') { + return $self->data_line($line); + } + else { + die "Unknown mode"; + } +} + +sub process_cmd { + my Qpsmtpd::PollServer $self = shift; + my $line = shift; + my ($cmd, @params) = split(/ +/, $line); + my $meth = lc($cmd); + if (my $lookup = $self->{_commands}->{$meth} && $self->can($meth)) { + my $resp = eval { + $lookup->($self, @params); + }; + if ($@) { + my $error = $@; + chomp($error); + $self->log(LOGERROR, "Command Error: $error"); + return $self->fault("command '$cmd' failed unexpectedly"); + } + return $resp; + } + else { + # No such method - i.e. unrecognized command + my ($rc, $msg) = $self->run_hooks("unrecognized_command", $meth, @params); + return 1; + } +} + +sub disconnect { + my Qpsmtpd::PollServer $self = shift; + $self->SUPER::disconnect(@_); + $self->close; +} + +sub start_conversation { + my Qpsmtpd::PollServer $self = shift; + + my $conn = $self->connection; + # set remote_host, remote_ip and remote_port + my ($ip, $port) = split(':', $self->peer_addr_string); + $conn->remote_ip($ip); + $conn->remote_port($port); + $conn->remote_info("[$ip]"); + 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, + ); + + return; +} + +sub data { + my Qpsmtpd::PollServer $self = shift; + + my ($rc, $msg) = $self->run_hooks("data"); + return 1; +} + +sub data_respond { + my Qpsmtpd::PollServer $self = shift; + my ($rc, $msg) = @_; + if ($rc == DONE) { + return; + } + elsif ($rc == DENY) { + $self->respond(554, $msg || "Message denied"); + $self->reset_transaction(); + return; + } + elsif ($rc == DENYSOFT) { + $self->respond(451, $msg || "Message denied temporarily"); + $self->reset_transaction(); + return; + } + elsif ($rc == DENY_DISCONNECT) { + $self->respond(554, $msg || "Message denied"); + $self->disconnect; + return; + } + elsif ($rc == DENYSOFT_DISCONNECT) { + $self->respond(451, $msg || "Message denied temporarily"); + $self->disconnect; + return; + } + return $self->respond(503, "MAIL first") unless $self->transaction->sender; + return $self->respond(503, "RCPT first") unless $self->transaction->recipients; + + $self->{mode} = 'data'; + + $self->{header_lines} = ''; + $self->{data_size} = 0; + $self->{in_header} = 1; + $self->{max_size} = ($self->config('databytes'))[0] || 0; + + $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}"); + + $self->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}); + + 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 Qpsmtpd::PollServer $self = shift; + + print "YIKES\n"; + + my $line = shift; + + if ($line eq ".\r\n") { + # add received etc. + $self->{mode} = 'cmd'; + return $self->end_of_data; + } + + # Reject messages that have either bare LF or CR. rjkaes noticed a + # lot of spam that is malformed in the header. + if ($line eq ".\n" or $line eq ".\r") { + $self->respond(421, "See http://smtpd.develooper.com/barelf.html"); + $self->disconnect; + return; + } + + # 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})) { + $line =~ s/\r\n$/\n/; + $line =~ s/^\.\./\./; + + if ($self->{in_header} and $line =~ m/^\s*$/) { + # 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 = Mail::Header->new($self->{header_lines}, + Modify => 0, MailFrom => "COERCE"); + $self->transaction->header($header); + + #$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}) { + push @{ $self->{header_lines} }, $line; + } + else { + $self->transaction->body_write(\$line); + } + + $self->{data_size} += length $line; + } + + return; +} + +sub end_of_data { + my Qpsmtpd::PollServer $self = shift; + + #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); + + $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}"); + + my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; + + my $header = $self->transaction->header; + if (!$header) { + $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + $self->transaction->header($header); + } + + # only true if client authenticated + if ( $self->authenticated == OK ) { + $header->add("X-Qpsmtpd-Auth","True"); + } + + $header->add("Received", "from ".$self->connection->remote_info + ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip + . ")\n by ".$self->config('me')." (qpsmtpd/".$self->version + .") with $smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)), + 0); + + return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size}; + + my ($rc, $msg) = $self->run_hooks("data_post"); + return 1; +} + +1; + diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index e26e569..b684cce 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -53,21 +53,7 @@ sub dispatch { $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"); - } + $self->run_hooks("unrecognized_command", $cmd, @_); return 1 } $cmd = $1; @@ -82,6 +68,20 @@ sub dispatch { return; } +sub unrecognized_command_respond { + my ($self, $rc, $msg) = @_; + if ($rc == DENY_DISCONNECT) { + $self->respond(521, @$msg); + $self->disconnect; + } + elsif ($rc == DENY) { + $self->respond(500, @$msg); + } + elsif ($rc != DONE) { + $self->respond(500, "Unrecognized command"); + } +} + sub fault { my $self = shift; my ($msg) = shift || "program fault - command not performed"; @@ -94,19 +94,21 @@ 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"); + $self->run_hooks("connect"); + return DONE; +} + +sub connect_respond { + my ($self, $rc, $msg) = @_; if ($rc == DENY) { - $msg[0] ||= 'Connection from you denied, bye bye.'; - $self->respond(550, @msg); - return $rc; + $msg->[0] ||= 'Connection from you denied, bye bye.'; + $self->respond(550, @$msg); + $self->disconnect; } elsif ($rc == DENYSOFT) { - $msg[0] ||= 'Connection from you temporarily denied, bye bye.'; - $self->respond(450, @msg); - return $rc; - } - elsif ($rc == DONE) { - return $rc; + $msg->[0] ||= 'Connection from you temporarily denied, bye bye.'; + $self->respond(450, @$msg); + $self->disconnect; } elsif ($rc != DONE) { my $greets = $self->config('smtpgreeting'); @@ -121,7 +123,6 @@ sub start_conversation { } $self->respond(220, $greets); - return DONE; } } @@ -154,20 +155,26 @@ sub helo { my $conn = $self->connection; return $self->respond (503, "but you already said HELO ...") if $conn->hello; - ($rc, @msg) = $self->run_hooks("helo", $hello_host, @stuff); + $self->run_hooks("helo", $hello_host, @stuff); +} + +sub helo_respond { + my ($self, $rc, $msg, $args) = @_; + my ($hello_host) = @$args; if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { - $self->respond(550, @msg); + $self->respond(550, @$msg); } elsif ($rc == DENYSOFT) { - $self->respond(450, @msg); + $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; } else { + my $conn = $self->connection; $conn->hello("helo"); $conn->hello_host($hello_host); $self->transaction; @@ -184,20 +191,26 @@ sub ehlo { my $conn = $self->connection; return $self->respond (503, "but you already said HELO ...") if $conn->hello; - ($rc, @msg) = $self->run_hooks("ehlo", $hello_host, @stuff); + $self->run_hooks("ehlo", $hello_host, @stuff); +} + +sub ehlo_respond { + my ($self, $rc, $msg, $args) = @_; + my ($hello_host) = @$args; if ($rc == DONE) { # do nothing } elsif ($rc == DENY) { - $self->respond(550, @msg); + $self->respond(550, @$msg); } elsif ($rc == DENYSOFT) { - $self->respond(450, @msg); + $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; } else { + my $conn = $self->connection; $conn->hello("ehlo"); $conn->hello_host($hello_host); $self->transaction; @@ -238,8 +251,14 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { sub auth { my ($self, $line) = @_; - my ($rc, $sub) = $self->run_hooks('auth_parse'); - my ($ok, $mechanism, @stuff) = Qpsmtpd::Command->parse('auth', $line, $sub); + $self->run_hooks('auth_parse', $line); +} + +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); @@ -293,8 +312,14 @@ sub mail { } else { $self->log(LOGINFO, "full from_parameter: $line"); - my ($rc, @msg) = $self->run_hooks("mail_parse"); - my ($ok, $from, @params) = Qpsmtpd::Command->parse('mail', $line, $msg[0]); + $self->run_hooks("mail_parse", $line); + } +} + +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; @@ -307,9 +332,14 @@ sub mail { # return (OK, "<$from>"); # (...or anything else parseable by Qpsmtpd::Address ;-)) # see also comment in sub rcpt() - ($rc, @msg) = $self->run_hooks("mail_pre", $from); + $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; + $from = shift @$msg; } $self->log(LOGALERT, "from email address : [$from]"); @@ -324,30 +354,35 @@ sub mail { } return $self->respond(501, "could not parse your mail from command") unless $from; - ($rc, @msg) = $self->run_hooks("mail", $from, %param); + $self->run_hooks("mail", $from, %$param); +} + +sub mail_respond { + 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); + $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); + $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); + $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); + $msg->[0] ||= $from->format . ', temporarily denied'; + $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)"); + $self->respond(421, @$msg); $self->disconnect; } else { # includes OK @@ -355,13 +390,17 @@ sub mail { $self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!"); $self->transaction->sender($from); } - } } sub rcpt { my ($self, $line) = @_; - my ($rc, @msg) = $self->run_hooks("rcpt_parse"); - my ($ok, $rcpt, @param) = Qpsmtpd::Command->parse("rcpt", $line, $msg[0]); + $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; @@ -378,9 +417,14 @@ sub rcpt { # this means, a plugin can decide to (pre-)accept # addresses like or # by removing the trailing "."/" " from this example... - ($rc, @msg) = $self->run_hooks("rcpt_pre", $rcpt); + $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; + $rcpt = shift @$msg; } $self->log(LOGALERT, "to email address : [$rcpt]"); return $self->respond(501, "could not parse recipient") @@ -391,28 +435,33 @@ sub rcpt { return $self->respond(501, "could not parse recipient") if (!$rcpt or ($rcpt->format eq '<>')); - ($rc, @msg) = $self->run_hooks("rcpt", $rcpt, %param); + $self->run_hooks("rcpt", $rcpt, %$param); +} + +sub rcpt_respond { + my ($self, $rc, $msg, $args) = @_; + my ($rcpt, $param) = @$args; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { - $msg[0] ||= 'relaying denied'; - $self->respond(550, @msg); + $msg->[0] ||= 'relaying denied'; + $self->respond(550, @$msg); } elsif ($rc == DENYSOFT) { - $msg[0] ||= 'relaying denied'; - return $self->respond(450, @msg); + $msg->[0] ||= 'relaying denied'; + return $self->respond(450, @$msg); } elsif ($rc == DENY_DISCONNECT) { - $msg[0] ||= '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[0] ||= '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) { @@ -425,8 +474,6 @@ sub rcpt { return 0; } - - sub help { my $self = shift; $self->respond(214, @@ -448,19 +495,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"); + $self->run_hooks("vrfy"); +} + +sub vrfy_respond { + my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { - $msg[0] ||= "Access Denied"; - $self->respond(554, @msg); + $msg->[0] ||= "Access Denied"; + $self->respond(554, @$msg); $self->reset_transaction(); return 1; } elsif ($rc == OK) { - $msg[0] ||= "User OK"; - $self->respond(250, @msg); + $msg->[0] ||= "User OK"; + $self->respond(250, @$msg); return 1; } else { # $rc == DECLINED or anything else @@ -477,10 +528,14 @@ sub rset { sub quit { my $self = shift; - my ($rc, @msg) = $self->run_hooks("quit"); + $self->run_hooks("quit"); +} + +sub quit_respond { + my ($self, $rc, $msg, $args) = @_; if ($rc != DONE) { - $msg[0] ||= $self->config('me') . " closing connection. Have a wonderful day."; - $self->respond(221, @msg); + $msg->[0] ||= $self->config('me') . " closing connection. Have a wonderful day."; + $self->respond(221, @$msg); } $self->disconnect(); } @@ -493,31 +548,35 @@ sub disconnect { sub data { my $self = shift; - my ($rc, @msg) = $self->run_hooks("data"); + $self->run_hooks("data"); +} + +sub data_respond { + my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { - $msg[0] ||= "Message denied"; - $self->respond(554, @msg); + $msg->[0] ||= "Message denied"; + $self->respond(554, @$msg); $self->reset_transaction(); return 1; } elsif ($rc == DENYSOFT) { - $msg[0] ||= "Message denied temporarily"; - $self->respond(451, @msg); + $msg->[0] ||= "Message denied temporarily"; + $self->respond(451, @$msg); $self->reset_transaction(); return 1; } elsif ($rc == DENY_DISCONNECT) { - $msg[0] ||= "Message denied"; - $self->respond(554, @msg); + $msg->[0] ||= "Message denied"; + $self->respond(554, @$msg); $self->disconnect; return 1; } elsif ($rc == DENYSOFT_DISCONNECT) { - $msg[0] ||= "Message denied temporarily"; - $self->respond(421, @msg); + $msg->[0] ||= "Message denied temporarily"; + $self->respond(421, @$msg); $self->disconnect; return 1; } @@ -624,17 +683,21 @@ sub data { return 1; } - ($rc, @msg) = $self->run_hooks("data_post"); + $self->run_hooks("data_post"); +} + +sub data_post_respond { + my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc == DENY) { - $msg[0] ||= "Message denied"; - $self->respond(552, @msg); + $msg->[0] ||= "Message denied"; + $self->respond(552, @$msg); } elsif ($rc == DENYSOFT) { - $msg[0] ||= "Message denied temporarily"; - $self->respond(452, @msg); + $msg->[0] ||= "Message denied temporarily"; + $self->respond(452, @$msg); } else { $self->queue($self->transaction); @@ -658,7 +721,11 @@ sub queue { my ($self, $transaction) = @_; # First fire any queue_pre hooks - my ($rc, @msg) = $self->run_hooks("queue_pre"); + $self->run_hooks("queue_pre"); +} + +sub queue_pre_respond { + my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } @@ -668,30 +735,38 @@ sub queue { } # If we got this far, run the queue hooks - ($rc, @msg) = $self->run_hooks("queue"); + $self->run_hooks("queue"); +} + +sub queue_respond { + my ($self, $rc, $msg, $args) = @_; if ($rc == DONE) { return 1; } elsif ($rc == OK) { - $msg[0] ||= 'Queued'; - $self->respond(250, @msg); + $msg->[0] ||= 'Queued'; + $self->respond(250, @$msg); } elsif ($rc == DENY) { - $msg[0] ||= 'Message denied'; - $self->respond(552, @msg); + $msg->[0] ||= 'Message denied'; + $self->respond(552, @$msg); } elsif ($rc == DENYSOFT) { - $msg[0] ||= 'Message denied temporarily'; - $self->respond(452, @msg); + $msg->[0] ||= 'Message denied temporarily'; + $self->respond(452, @$msg); } else { - $msg[0] ||= 'Queuing declined or disabled; try again later'; - $self->respond(451, @msg); + $msg->[0] ||= 'Queuing declined or disabled; try again later'; + $self->respond(451, @$msg); } # And finally run any queue_post hooks - ($rc, @msg) = $self->run_hooks("queue_post"); - $self->log(LOGERROR, @msg) unless ($rc == OK or $rc == 0); + $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/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; +} From 5fea527ba4e028e0489cbec7135d4b874228d7ca Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 8 Dec 2006 20:55:47 +0000 Subject: [PATCH 118/134] Remove debug print git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@680 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Command.pm | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/Qpsmtpd/Command.pm b/lib/Qpsmtpd/Command.pm index b06e5ad..a6c02c8 100644 --- a/lib/Qpsmtpd/Command.pm +++ b/lib/Qpsmtpd/Command.pm @@ -99,7 +99,6 @@ sub parse_rcpt { sub parse_mail { my ($self,$cmd,$line) = @_; return (DENY, "Syntax error in command") unless $line =~ s/^from:\s*//i; - print "parse_mail: $line\n"; return &_get_mail_params($cmd, $line); } ### RFC 1869: From d2c79e9736dffb9f339cda1462f3447e5e2c2498 Mon Sep 17 00:00:00 2001 From: "Peter J. Holzer" Date: Sat, 16 Dec 2006 09:30:32 +0000 Subject: [PATCH 119/134] Added support for (x)inetd. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@681 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/TcpServer.pm | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index 7935477..4841614 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 From 72da8793651ef79fc94c5acbda301e141858e639 Mon Sep 17 00:00:00 2001 From: "Peter J. Holzer" Date: Sat, 16 Dec 2006 09:42:52 +0000 Subject: [PATCH 120/134] Ensure that each child process in qpsmtpd-forkserver will use a differenct sequence of ids in DNS requests. See the thread "dnsbl or spamhaus occassionally blocks wrong IP" starting at 14 Mar 2006 for details. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@682 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 5d8d8b4..6504367 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -14,6 +14,7 @@ use IO::Select; use Socket; use Getopt::Long; use POSIX qw(:sys_wait_h :errno_h :signal_h); +use Net::DNS::Header; use strict; $| = 1; @@ -273,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); From d6c428716f702787c50695a6770f1afcaa1cdbc8 Mon Sep 17 00:00:00 2001 From: "Peter J. Holzer" Date: Sat, 16 Dec 2006 09:46:12 +0000 Subject: [PATCH 121/134] Check if the domain name in a DNS response packet matches one of the domain names we queried. See the thread "dnsbl or spamhaus occassionally blocks wrong IP" starting at 14 Mar 2006 for details. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@683 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/dnsbl | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/plugins/dnsbl b/plugins/dnsbl index 6526cbd..48df98f 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -57,8 +57,10 @@ sub hook_connect { 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"); $sel->add($res->bgsend("$reversed_ip.$dnsbl")); @@ -69,6 +71,7 @@ sub hook_connect { } $self->qp->connection->notes('dnsbl_sockets', $sel); + $self->qp->connection->notes('dnsbl_domains', $dom); return DECLINED; } @@ -88,6 +91,7 @@ sub process_sockets { $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; @@ -110,11 +114,13 @@ sub process_sockets { if ($query) { my $a_record = 0; foreach my $rr ($query->answer) { - $a_record = 1 if $rr->type eq "A"; 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; - $self->log(LOGDEBUG, "name ", $rr->name); next unless $rr->type eq "TXT"; $self->log(LOGDEBUG, "got txt record"); $result = $rr->txtdata and last; From c581b1062807e7fc869249bac503c9033b9e821f Mon Sep 17 00:00:00 2001 From: "Peter J. Holzer" Date: Sat, 16 Dec 2006 09:56:09 +0000 Subject: [PATCH 122/134] Reduce the log level of the "running plugin" message to LOGDEBUG. The mere fact that a plugin was called is only useful for debugging. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@684 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 2338042..d262518 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -367,7 +367,7 @@ sub run_continuation { $@ and warn("FATAL LOGGING PLUGIN ERROR: ", $@) and next; } else { - $self->varlog(LOGINFO, $hook, $code->{name}); + $self->varlog(LOGDEBUG, $hook, $code->{name}); eval { (@r) = $code->{code}->($self, $self->transaction, @$args); }; $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and next; From 469c01a1f4eda536d28a2e2fd5e525d853d734be Mon Sep 17 00:00:00 2001 From: "Peter J. Holzer" Date: Sat, 16 Dec 2006 10:01:50 +0000 Subject: [PATCH 123/134] Increased log level of SMTP commands and responses to LOGINFO. These may be useful during normal operations. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@685 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/TcpServer.pm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index 4841614..d79423f 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -75,7 +75,7 @@ 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 / +/, $_, 2) or $self->respond(502, "command unrecognized: '$_'"); @@ -89,7 +89,7 @@ sub respond { my $buf = ''; while (my $msg = shift @messages) { my $line = $code . (@messages?"-":" ").$msg; - $self->log(LOGDEBUG, $line); + $self->log(LOGINFO, $line); $buf .= "$line\r\n"; } print $buf or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0); @@ -98,7 +98,7 @@ sub respond { sub disconnect { my $self = shift; - $self->log(LOGDEBUG,"click, disconnecting"); + $self->log(LOGINFO,"click, disconnecting"); $self->SUPER::disconnect(@_); $self->run_hooks("post-connection"); exit; From ad541f6207c38731cfe439bb954ed773f7782647 Mon Sep 17 00:00:00 2001 From: Hanno Hecker Date: Sat, 16 Dec 2006 11:56:48 +0000 Subject: [PATCH 124/134] Qpsmtpd::Transaction: add body_fh(), body_length() and data_size(), depreceated body_size() git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@689 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 4 +++ lib/Qpsmtpd/Transaction.pm | 51 ++++++++++++++++++++++++++++++++++++-- plugins/check_basicheaders | 2 +- plugins/spamassassin | 2 +- plugins/virus/bitdefender | 4 +-- plugins/virus/clamav | 4 +-- plugins/virus/clamdscan | 4 +-- plugins/virus/klez_filter | 4 +-- plugins/virus/sophie | 4 +-- plugins/virus/uvscan | 2 +- 10 files changed, 66 insertions(+), 15 deletions(-) diff --git a/Changes b/Changes index ac518db..f46cf49 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,8 @@ 0.3x + 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) diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index ea1d41c..6cfaed4 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -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/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/spamassassin b/plugins/spamassassin index 0f3686a..5b62153 100644 --- a/plugins/spamassassin +++ b/plugins/spamassassin @@ -96,7 +96,7 @@ 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'; 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 b16d1cb..24ad7b0 100644 --- a/plugins/virus/clamav +++ b/plugins/virus/clamav @@ -164,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); } diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 80a49d3..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); } 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'); From e31d3e3e4b15317d7873cbe0119e802e28b980f8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Mon, 18 Dec 2006 10:45:22 +0000 Subject: [PATCH 125/134] documentation typo in clamav, update changes file a bit git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@696 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 13 +++++++------ plugins/virus/clamav | 2 +- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/Changes b/Changes index f46cf49..142b01f 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,7 @@ -0.3x +0.33 (to be) + + Support "module" plugins ("My::Plugin" in the config/plugins file) + 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) @@ -16,20 +19,17 @@ looked for by default in /var/lib/qpsmtpd/greylisting in addition to the previous locations relative to the qpsmtpd binary. (Devin Carraway) -0.33 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) - Experimental IPv6 support (forkserver only). (Mike Williams) - - Support "module" plugins ("My::Plugin" in the config/plugins file) - Enhance the spamassassin plugin to support connecting to a remote spamd process (Kjetil Kjernsmo). @@ -199,6 +199,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/plugins/virus/clamav b/plugins/virus/clamav index 24ad7b0..a74e0f1 100644 --- a/plugins/virus/clamav +++ b/plugins/virus/clamav @@ -49,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, From cab7466c08fec71c48cba5a77beee08ec3b190a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Mon, 18 Dec 2006 10:45:25 +0000 Subject: [PATCH 126/134] Make the badmailfrom plugin support (optional) rejection messages after the rejection pattern (Robin Hugh Johnson) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@697 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 3 +++ plugins/check_badmailfrom | 10 ++++++++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/Changes b/Changes index 142b01f..b9434ca 100644 --- a/Changes +++ b/Changes @@ -2,6 +2,9 @@ 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) diff --git a/plugins/check_badmailfrom b/plugins/check_badmailfrom index 5030412..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 @@ -33,11 +36,14 @@ 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); From dcb86d5a72e10288d02e06d452df7837d92be02a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Mon, 18 Dec 2006 19:46:26 +0000 Subject: [PATCH 127/134] take out ordb.org from the sample dnsbl config; s/sbl/sbl-xbl/ git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@698 958fd67b-6ff1-0310-b445-bb7760255be9 --- config.sample/dnsbl_zones | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/config.sample/dnsbl_zones b/config.sample/dnsbl_zones index aef5e63..517dc77 100644 --- a/config.sample/dnsbl_zones +++ b/config.sample/dnsbl_zones @@ -1,4 +1,3 @@ rbl.mail-abuse.org spamsources.fabel.dk -relays.ordb.org -sbl.spamhaus.org +sbl-xbl.spamhaus.org From 6eefa970166db31538477cecf697b7c13c62d9ff Mon Sep 17 00:00:00 2001 From: Hanno Hecker Date: Mon, 25 Dec 2006 10:12:54 +0000 Subject: [PATCH 128/134] some fixes from Michael C. Toren: - Treat DENY(|SOFT)_DISCONNECT from connect hooks the same as DENY(|SOFT) - only append ESMTP to smtpgreeting if it's not already in there - Qpsmtpd::SMTP::fault(): parsing now unambigous and just first "word" of $0 see also http://www.nntp.perl.org/group/perl.qpsmtpd/5905 git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@699 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index b684cce..8b47e90 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -85,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); } @@ -100,12 +101,12 @@ sub start_conversation { sub connect_respond { my ($self, $rc, $msg) = @_; - if ($rc == DENY) { + if ($rc == DENY || $rc == DENY_DISCONNECT) { $msg->[0] ||= 'Connection from you denied, bye bye.'; $self->respond(550, @$msg); $self->disconnect; } - elsif ($rc == DENYSOFT) { + elsif ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) { $msg->[0] ||= 'Connection from you temporarily denied, bye bye.'; $self->respond(450, @$msg); $self->disconnect; @@ -113,7 +114,7 @@ sub connect_respond { elsif ($rc != DONE) { my $greets = $self->config('smtpgreeting'); if ( $greets ) { - $greets .= " ESMTP"; + $greets .= " ESMTP" unless $greets =~ /(^|\W)ESMTP(\W|$)/; } else { $greets = $self->config('me') From 39a927121303427fc36e67b39bb8e0ccc78804a8 Mon Sep 17 00:00:00 2001 From: Hanno Hecker Date: Sun, 31 Dec 2006 11:07:32 +0000 Subject: [PATCH 129/134] New "skip plugin API" + example plugin skip_plugins, see perldoc Qpsmtpd::Plugins for more info. This can be used to disable (and re- enable) loaded plugins for the current connection. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@700 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 4 + config.sample/plugins | 3 + lib/Qpsmtpd.pm | 5 + lib/Qpsmtpd/Plugin.pm | 209 ++++++++++++++++++++++++++++++++++++++++++ plugins/skip_plugins | 97 ++++++++++++++++++++ 5 files changed, 318 insertions(+) create mode 100644 plugins/skip_plugins diff --git a/Changes b/Changes index b9434ca..76ca3f3 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,9 @@ 0.33 (to be) + New "skip plugin API" + example plugin skip_plugins, see perldoc + Qpsmtpd::Plugins for more info. This can be used to disable (and re- + enable) loaded plugins for the current connection (Hanno Hecker) + Support "module" plugins ("My::Plugin" in the config/plugins file) Make the badmailfrom plugin support (optional) rejection messages after the diff --git a/config.sample/plugins b/config.sample/plugins index 1d6b180..cfaf677 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -12,6 +12,9 @@ # from one IP! hosts_allow +# skip selected plugins for some hosts: +skip_plugins + # enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <> dont_require_anglebrackets diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index d262518..cbab667 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -367,6 +367,11 @@ sub run_continuation { $@ and warn("FATAL LOGGING PLUGIN ERROR: ", $@) and next; } else { + my $skip = $self->connection->notes('_skip_plugins'); + if (exists $skip->{$code->{name}} and $skip->{$code->{name}}) { + $self->log(LOGDEBUG, "skipping plugin ".$code->{name}); + next; + } $self->varlog(LOGDEBUG, $hook, $code->{name}); eval { (@r) = $code->{code}->($self, $self->transaction, @$args); }; $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and next; diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index b6357be..c1370bf 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -1,6 +1,7 @@ package Qpsmtpd::Plugin; use Qpsmtpd::Constants; use strict; +use vars qw(%symbols); # more or less in the order they will fire our @hooks = qw( @@ -116,6 +117,8 @@ sub isa_plugin { # don't reload plugins if they are already loaded return if defined &{"${newPackage}::plugin_name"}; + ### someone test this please: + # return if $self->plugin_is_loaded($newPackage); $self->compile($self->plugin_name . "_isa_$cleanParent", $newPackage, @@ -183,5 +186,211 @@ sub _register_standard_hooks { } } +=head1 SKIP PLUGINS API + +These functions allow to disable and re-enable loaded plugins. Loading +plugins after the initial loading phase is not possible. The earliest +place to disable a plugin is in C. + +If you want to run a plugin just for some clients, load it like a usual +plugin and either hook it to the C (or any later hook) +and disable it there, use the C plugin or write your own +disabling plugin. + +These modifications of disabling/re-enabling a plugin are valid for the +full connection, not transaction! For transaction based disabling of plugins, +use the C hook to reset the list of disabled plugins. + +A small warning: the C hook is called at least three +times: after the client sent the C<(HE|EH)LO>, every time the client +issues a C and after the mail was queued (or rejected by a +C hook). Don't forget it is also called after C and +connection closing (e.g. after C). + +=over 7 + +=item plugin_is_loaded( $plugin ) + +Returns true, if the given (escaped) plugin name is a loaded plugin + +=cut + +sub plugin_is_loaded { + my ($self, $plugin) = @_; + $plugin =~ s/^Qpsmtpd::Plugin:://; # for _loaded(); + # each plugin has a sub called "plugin_name()", see compile() above... + # ... this restricts qpsmtpd a bit: No module named + # Qpsmtpd::Plugin(|::Something) must have a sub "plugin_name()", or + # it will be returned as a loaded plugin... + return defined &{"Qpsmtpd::Plugin::${plugin}::plugin_name"}; +} + +=item plugin_status( $plugin ) + +Shows the status of the given plugin. It returns undef if no plugin name +given or the plugin is not loaded, "0" if plugin is loaded, but disabled +and "1" if the plugin is loaded and active. The plugin name must be escaped +by B. + +=cut + +sub plugin_status { + my ($self, $plugin) = @_; + return undef unless $plugin; + return undef unless $self->plugin_is_loaded($plugin); + my $skip = $self->qp->connection->notes('_skip_plugins') || {}; + return 0 if (exists $skip->{$plugin} and $skip->{$plugin}); + return 1; +} + +=item loaded_plugins( ) + +This returns a hash. Keys are (escaped, see below) plugin names of loaded +plugins. The value tells you if the plugin is currently active (1) or +disabled (0). + +=cut + +sub loaded_plugins { + my $self = shift; + # all plugins are in their own class "below" Qpsmtpd::Plugin, + # so we start searching the symbol table at this point + my %plugins = map { + s/^Qpsmtpd::Plugin:://; + ($_, 1) + } $self->_loaded("Qpsmtpd::Plugin"); + foreach ($self->disabled_plugins) { + $plugins{$_} = 0; + } + return %plugins; +} + +sub _loaded { + my $self = shift; + my $base = shift; + my @loaded = (); + my (@sub, $symbol); + # let's see what's in this name space + no strict 'refs'; + local (*symbols) = *{"${base}::"}; + use strict 'refs'; + foreach my $name (values %symbols) { + # $name is read only while walking the stash + + # not a class name? ok, next + ($symbol = $name) =~ s/^\*(.*)::$/$1/ || next; + next if $symbol eq "Qpsmtpd::Plugin"; + + # in qpsmtpd we have no way of loading a plugin with the same + # name as a sub directory inside the ./plugins dir, so we can safely + # use either the list of sub classes or the class itself we're + # looking at (unlike perl, e.g. Qpsmtpd.pm <-> Qpsmtpd/Plugin.pm). + @sub = $self->_loaded($symbol); + + if (@sub) { + push @loaded, @sub; + } + else { + # is this really a plugin? + next unless $self->plugin_is_loaded($symbol); + push @loaded, $symbol; + } + } + return @loaded; +} + +=item escape_plugin( $plugin_name ) + +Turns a plugin filename into the way it is used inside qpsmtpd. This needs to +be done before you B or B a plugin. To +see if a plugin is loaded, use something like + + my %loaded = $self->loaded_plugins; + my $wanted = $self->escape_plugin("virus/clamav"); + if (exists $loaded{$wanted}) { + ... + } +... or shorter: + + if ($self->plugin_is_loaded($self->escape_plugin("virus/clamav"))) { + ... + } + +=cut + +sub escape_plugin { + my $self = shift; + my $plugin_name = shift; + # "stolen" from Qpsmtpd.pm + # 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; + return $plugin_name; +} + +=item disabled_plugins( ) + +This returns a list of all plugins which are disabled for the current +connection. + +=cut + +sub disabled_plugins { + my $self = shift; + my @skipped = (); + my $skip = $self->qp->connection->notes('_skip_plugins') || {}; + foreach my $s (keys %{$skip}) { + push @skipped, $s if $skip->{$s}; + } + return @skipped; +} + +=item plugin_disable( $plugin ) + +B disables a (loaded) plugin, it requires the plugin name +to be escaped by B. It returns true, if the given plugin +name is a loaded plugin (and disables it of course). + +=cut + +sub plugin_disable { + my ($self, $plugin) = @_; + # do a basic check if the supplied plugin name is really a plugin + return 0 unless $self->plugin_is_loaded($plugin); + + my $skip = $self->qp->connection->notes('_skip_plugins') || {}; + $skip->{$plugin} = 1; + $self->qp->connection->notes('_skip_plugins', $skip); + return 1; +} + +=item plugin_enable( $plugin ) + +B re-enables a (loaded) plugin, it requires the plugin name +to be escaped by B. It returns "0", if the given plugin +name is not a loaded plugin. Else it returns "1" after enabling. + +=cut + +sub plugin_enable { + my ($self, $plugin) = @_; + return 0 unless $self->plugin_is_loaded($plugin); + + my $skip = $self->qp->connection->notes('_skip_plugins') || {}; + $skip->{$plugin} = 0; + $self->qp->connection->notes('_skip_plugins', $skip); + return 1; +} + +=back + +=cut 1; diff --git a/plugins/skip_plugins b/plugins/skip_plugins new file mode 100644 index 0000000..e296e4b --- /dev/null +++ b/plugins/skip_plugins @@ -0,0 +1,97 @@ + +=head1 NAME + +skip_plugins - don't run selected plugins for some hosts + +=head1 DESCRIPTION + +The B plugin allows you to skip selected plugins for some +clients. This is similar to some whitelist plugins, without the need to +modify any plugin. + +This plugin should be run before any other plugins hooking to the +I. The config allows to run all plugins for one host in a +subnet and skip some for all other hosts in this network. + +=head1 CONFIG + +The config file I contains lines with two or three items per +line. The first field is a network/mask pair (or just a single IP address). +An action is set in the second field: currently B or B are +valid actions. + +If a host matches a B line, the parsing is stopped and all +plugins are run for this host. A B action tells qpsmtpd to skip +the plugins listed in the third field for this connection. + +The plugin list in the third field must be separated by "," without any spaces. + +=head1 EXAMPLE + + 10.7.7.2 continue + 10.7.7.0/24 skip spamassassin,check_earlytalker + +To disable a plugin for all clients except for one subnet: + + 10.1.0.0/16 continue + 0.0.0.0/0 skip virus/clamdscan + +=head1 NOTES + +See perldoc Qpsmtpd::Plugin for more about disabling / re-enabling plugins +for the current connection. + +=head1 BUGS + +This plugin does not have IPv6 support. + +=cut + +use Socket; + +sub hook_connect { + my ($self,$transaction) = @_; + + my %skip = (); + #my %l = $self->loaded_plugins; + #foreach my $p (keys %l) { + # $self->log(LOGDEBUG, "LOADED: $p"); + #} + my $remote = $self->qp->connection->remote_ip; + foreach ($self->qp->config("skip_plugins")) { + chomp; + s/^\s*//; + s/\s*$//; + my ($ipmask, $action, $plugins) = split /\s+/, $_, 3; + next unless defined $action; + $action = lc $action; + $plugins = "" unless defined $plugins; + + 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) { + if ($action eq 'skip') { + foreach my $plugin (split /,/, $plugins) { + $self->plugin_disable($self->escape_plugin($plugin)) + or $self->log(LOGWARN, "tried to disable a plugin " + ."which was not loaded: $plugin"); + } + $self->log(LOGDEBUG, "skipping plugins " + .join(",", $self->disabled_plugins)); + } + elsif ($action eq 'continue') { + $self->log(LOGDEBUG, "ok, doing nothing with the plugins"); + } + else { + $self->log(LOGWARN, "unknown action '$action' for $ipmask"); + } + last; + } + } + return (DECLINED); +} + +# vim: sw=4 ts=4 expandtab syn=perl From d54a960f9a9b831610b13f4e7aabed567fd56bf0 Mon Sep 17 00:00:00 2001 From: Hanno Hecker Date: Mon, 1 Jan 2007 12:47:46 +0000 Subject: [PATCH 130/134] undo r700 (skip plugin) git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@701 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 4 - config.sample/plugins | 3 - lib/Qpsmtpd.pm | 5 - lib/Qpsmtpd/Plugin.pm | 209 ------------------------------------------ plugins/skip_plugins | 97 -------------------- 5 files changed, 318 deletions(-) delete mode 100644 plugins/skip_plugins diff --git a/Changes b/Changes index 76ca3f3..b9434ca 100644 --- a/Changes +++ b/Changes @@ -1,9 +1,5 @@ 0.33 (to be) - New "skip plugin API" + example plugin skip_plugins, see perldoc - Qpsmtpd::Plugins for more info. This can be used to disable (and re- - enable) loaded plugins for the current connection (Hanno Hecker) - Support "module" plugins ("My::Plugin" in the config/plugins file) Make the badmailfrom plugin support (optional) rejection messages after the diff --git a/config.sample/plugins b/config.sample/plugins index cfaf677..1d6b180 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -12,9 +12,6 @@ # from one IP! hosts_allow -# skip selected plugins for some hosts: -skip_plugins - # enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <> dont_require_anglebrackets diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index cbab667..d262518 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -367,11 +367,6 @@ sub run_continuation { $@ and warn("FATAL LOGGING PLUGIN ERROR: ", $@) and next; } else { - my $skip = $self->connection->notes('_skip_plugins'); - if (exists $skip->{$code->{name}} and $skip->{$code->{name}}) { - $self->log(LOGDEBUG, "skipping plugin ".$code->{name}); - next; - } $self->varlog(LOGDEBUG, $hook, $code->{name}); eval { (@r) = $code->{code}->($self, $self->transaction, @$args); }; $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and next; diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index c1370bf..b6357be 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -1,7 +1,6 @@ package Qpsmtpd::Plugin; use Qpsmtpd::Constants; use strict; -use vars qw(%symbols); # more or less in the order they will fire our @hooks = qw( @@ -117,8 +116,6 @@ sub isa_plugin { # don't reload plugins if they are already loaded return if defined &{"${newPackage}::plugin_name"}; - ### someone test this please: - # return if $self->plugin_is_loaded($newPackage); $self->compile($self->plugin_name . "_isa_$cleanParent", $newPackage, @@ -186,211 +183,5 @@ sub _register_standard_hooks { } } -=head1 SKIP PLUGINS API - -These functions allow to disable and re-enable loaded plugins. Loading -plugins after the initial loading phase is not possible. The earliest -place to disable a plugin is in C. - -If you want to run a plugin just for some clients, load it like a usual -plugin and either hook it to the C (or any later hook) -and disable it there, use the C plugin or write your own -disabling plugin. - -These modifications of disabling/re-enabling a plugin are valid for the -full connection, not transaction! For transaction based disabling of plugins, -use the C hook to reset the list of disabled plugins. - -A small warning: the C hook is called at least three -times: after the client sent the C<(HE|EH)LO>, every time the client -issues a C and after the mail was queued (or rejected by a -C hook). Don't forget it is also called after C and -connection closing (e.g. after C). - -=over 7 - -=item plugin_is_loaded( $plugin ) - -Returns true, if the given (escaped) plugin name is a loaded plugin - -=cut - -sub plugin_is_loaded { - my ($self, $plugin) = @_; - $plugin =~ s/^Qpsmtpd::Plugin:://; # for _loaded(); - # each plugin has a sub called "plugin_name()", see compile() above... - # ... this restricts qpsmtpd a bit: No module named - # Qpsmtpd::Plugin(|::Something) must have a sub "plugin_name()", or - # it will be returned as a loaded plugin... - return defined &{"Qpsmtpd::Plugin::${plugin}::plugin_name"}; -} - -=item plugin_status( $plugin ) - -Shows the status of the given plugin. It returns undef if no plugin name -given or the plugin is not loaded, "0" if plugin is loaded, but disabled -and "1" if the plugin is loaded and active. The plugin name must be escaped -by B. - -=cut - -sub plugin_status { - my ($self, $plugin) = @_; - return undef unless $plugin; - return undef unless $self->plugin_is_loaded($plugin); - my $skip = $self->qp->connection->notes('_skip_plugins') || {}; - return 0 if (exists $skip->{$plugin} and $skip->{$plugin}); - return 1; -} - -=item loaded_plugins( ) - -This returns a hash. Keys are (escaped, see below) plugin names of loaded -plugins. The value tells you if the plugin is currently active (1) or -disabled (0). - -=cut - -sub loaded_plugins { - my $self = shift; - # all plugins are in their own class "below" Qpsmtpd::Plugin, - # so we start searching the symbol table at this point - my %plugins = map { - s/^Qpsmtpd::Plugin:://; - ($_, 1) - } $self->_loaded("Qpsmtpd::Plugin"); - foreach ($self->disabled_plugins) { - $plugins{$_} = 0; - } - return %plugins; -} - -sub _loaded { - my $self = shift; - my $base = shift; - my @loaded = (); - my (@sub, $symbol); - # let's see what's in this name space - no strict 'refs'; - local (*symbols) = *{"${base}::"}; - use strict 'refs'; - foreach my $name (values %symbols) { - # $name is read only while walking the stash - - # not a class name? ok, next - ($symbol = $name) =~ s/^\*(.*)::$/$1/ || next; - next if $symbol eq "Qpsmtpd::Plugin"; - - # in qpsmtpd we have no way of loading a plugin with the same - # name as a sub directory inside the ./plugins dir, so we can safely - # use either the list of sub classes or the class itself we're - # looking at (unlike perl, e.g. Qpsmtpd.pm <-> Qpsmtpd/Plugin.pm). - @sub = $self->_loaded($symbol); - - if (@sub) { - push @loaded, @sub; - } - else { - # is this really a plugin? - next unless $self->plugin_is_loaded($symbol); - push @loaded, $symbol; - } - } - return @loaded; -} - -=item escape_plugin( $plugin_name ) - -Turns a plugin filename into the way it is used inside qpsmtpd. This needs to -be done before you B or B a plugin. To -see if a plugin is loaded, use something like - - my %loaded = $self->loaded_plugins; - my $wanted = $self->escape_plugin("virus/clamav"); - if (exists $loaded{$wanted}) { - ... - } -... or shorter: - - if ($self->plugin_is_loaded($self->escape_plugin("virus/clamav"))) { - ... - } - -=cut - -sub escape_plugin { - my $self = shift; - my $plugin_name = shift; - # "stolen" from Qpsmtpd.pm - # 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; - return $plugin_name; -} - -=item disabled_plugins( ) - -This returns a list of all plugins which are disabled for the current -connection. - -=cut - -sub disabled_plugins { - my $self = shift; - my @skipped = (); - my $skip = $self->qp->connection->notes('_skip_plugins') || {}; - foreach my $s (keys %{$skip}) { - push @skipped, $s if $skip->{$s}; - } - return @skipped; -} - -=item plugin_disable( $plugin ) - -B disables a (loaded) plugin, it requires the plugin name -to be escaped by B. It returns true, if the given plugin -name is a loaded plugin (and disables it of course). - -=cut - -sub plugin_disable { - my ($self, $plugin) = @_; - # do a basic check if the supplied plugin name is really a plugin - return 0 unless $self->plugin_is_loaded($plugin); - - my $skip = $self->qp->connection->notes('_skip_plugins') || {}; - $skip->{$plugin} = 1; - $self->qp->connection->notes('_skip_plugins', $skip); - return 1; -} - -=item plugin_enable( $plugin ) - -B re-enables a (loaded) plugin, it requires the plugin name -to be escaped by B. It returns "0", if the given plugin -name is not a loaded plugin. Else it returns "1" after enabling. - -=cut - -sub plugin_enable { - my ($self, $plugin) = @_; - return 0 unless $self->plugin_is_loaded($plugin); - - my $skip = $self->qp->connection->notes('_skip_plugins') || {}; - $skip->{$plugin} = 0; - $self->qp->connection->notes('_skip_plugins', $skip); - return 1; -} - -=back - -=cut 1; diff --git a/plugins/skip_plugins b/plugins/skip_plugins deleted file mode 100644 index e296e4b..0000000 --- a/plugins/skip_plugins +++ /dev/null @@ -1,97 +0,0 @@ - -=head1 NAME - -skip_plugins - don't run selected plugins for some hosts - -=head1 DESCRIPTION - -The B plugin allows you to skip selected plugins for some -clients. This is similar to some whitelist plugins, without the need to -modify any plugin. - -This plugin should be run before any other plugins hooking to the -I. The config allows to run all plugins for one host in a -subnet and skip some for all other hosts in this network. - -=head1 CONFIG - -The config file I contains lines with two or three items per -line. The first field is a network/mask pair (or just a single IP address). -An action is set in the second field: currently B or B are -valid actions. - -If a host matches a B line, the parsing is stopped and all -plugins are run for this host. A B action tells qpsmtpd to skip -the plugins listed in the third field for this connection. - -The plugin list in the third field must be separated by "," without any spaces. - -=head1 EXAMPLE - - 10.7.7.2 continue - 10.7.7.0/24 skip spamassassin,check_earlytalker - -To disable a plugin for all clients except for one subnet: - - 10.1.0.0/16 continue - 0.0.0.0/0 skip virus/clamdscan - -=head1 NOTES - -See perldoc Qpsmtpd::Plugin for more about disabling / re-enabling plugins -for the current connection. - -=head1 BUGS - -This plugin does not have IPv6 support. - -=cut - -use Socket; - -sub hook_connect { - my ($self,$transaction) = @_; - - my %skip = (); - #my %l = $self->loaded_plugins; - #foreach my $p (keys %l) { - # $self->log(LOGDEBUG, "LOADED: $p"); - #} - my $remote = $self->qp->connection->remote_ip; - foreach ($self->qp->config("skip_plugins")) { - chomp; - s/^\s*//; - s/\s*$//; - my ($ipmask, $action, $plugins) = split /\s+/, $_, 3; - next unless defined $action; - $action = lc $action; - $plugins = "" unless defined $plugins; - - 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) { - if ($action eq 'skip') { - foreach my $plugin (split /,/, $plugins) { - $self->plugin_disable($self->escape_plugin($plugin)) - or $self->log(LOGWARN, "tried to disable a plugin " - ."which was not loaded: $plugin"); - } - $self->log(LOGDEBUG, "skipping plugins " - .join(",", $self->disabled_plugins)); - } - elsif ($action eq 'continue') { - $self->log(LOGDEBUG, "ok, doing nothing with the plugins"); - } - else { - $self->log(LOGWARN, "unknown action '$action' for $ipmask"); - } - last; - } - } - return (DECLINED); -} - -# vim: sw=4 ts=4 expandtab syn=perl From e7d64268e0b68f6e4e9b57343e664760f09b8a40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Sat, 6 Jan 2007 02:25:45 +0000 Subject: [PATCH 131/134] Update the sample configuration to use zen.spamhaus.org take out ordb and mail-abuse references from sample config and the website git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@702 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 2 ++ config.sample/dnsbl_zones | 3 +-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/Changes b/Changes index b9434ca..be68d4e 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,7 @@ 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 diff --git a/config.sample/dnsbl_zones b/config.sample/dnsbl_zones index 517dc77..15c4425 100644 --- a/config.sample/dnsbl_zones +++ b/config.sample/dnsbl_zones @@ -1,3 +1,2 @@ -rbl.mail-abuse.org spamsources.fabel.dk -sbl-xbl.spamhaus.org +zen.spamhaus.org From a30506e9b67f6703534912c40e23ae69031f424f Mon Sep 17 00:00:00 2001 From: Robert Spier Date: Sat, 6 Jan 2007 06:58:08 +0000 Subject: [PATCH 132/134] RFC3848 support for ESMTP. Heavily based on: From: Nick Leverton To: qpsmtpd@perl.org Subject: SMTPA Date: Thu, 4 Jan 2007 12:08:16 +0000 Message-Id: <200701041208.17018@leverton.icritical.com> git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@703 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 8b47e90..01fd184 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -658,10 +658,19 @@ sub data_respond { $self->transaction->header($header); my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; - my $sslheader = (defined $self->connection->notes('tls_enabled') and $self->connection->notes('tls_enabled')) ? - "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) " : ""; - my $authheader = (defined $self->{_auth} and $self->{_auth} == OK) ? - "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n" : ""; + my $authheader; + my $sslheader; + + if (defined $self->connection->notes('tls_enabled') + and $self->connection->notes('tls_enabled')) { + $smtp eq "ESMTP" and $smtp .= "S"; # RFC3848 + $sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) "; + } + + if (defined $self->{_auth} and $self->{_auth} == OK) { + $smtp eq "ESMTP" and $smtp .= "A"; # 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 From 02edd1a32a3883b5e31291f8df16a955e4792062 Mon Sep 17 00:00:00 2001 From: Robert Spier Date: Sat, 6 Jan 2007 20:22:01 +0000 Subject: [PATCH 133/134] mct noticed that we weren't properly testing for ESMTP. git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@704 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 01fd184..bc69fc5 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -658,17 +658,18 @@ sub data_respond { $self->transaction->header($header); my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; + 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 eq "ESMTP" and $smtp .= "S"; # RFC3848 + $smtp .= "S" if $esmtp; # RFC3848 $sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) "; } if (defined $self->{_auth} and $self->{_auth} == OK) { - $smtp eq "ESMTP" and $smtp .= "A"; # RFC3848 + $smtp .= "A" if $esmtp; # RFC3848 $authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n"; } From be67f02dd8ffca881d19a656491bb81e07223f42 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 11 Jan 2007 23:52:51 +0000 Subject: [PATCH 134/134] Fix tests (idea from Guy Hulbert, with tweak from me). git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@706 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 4 +--- t/Test/Qpsmtpd.pm | 4 ++-- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index d262518..ac6c70c 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -274,7 +274,6 @@ sub _load_plugin { my $self = shift; my ($plugin_line, @plugin_dirs) = @_; - my @ret; my ($plugin, @args) = split ' ', $plugin_line; my $package; @@ -330,9 +329,8 @@ sub _load_plugin { my $plug = $package->new(); $plug->_register($self, @args); - push @ret, $plug; - return @ret; + return $plug; } sub transaction { 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 {