diff --git a/README.plugins b/README.plugins new file mode 100644 index 0000000..986ee15 --- /dev/null +++ b/README.plugins @@ -0,0 +1,87 @@ +# +# read this with 'perldoc README.plugins' ... +# + +=head1 qpsmtpd plugin system; developer documentation + +See the examples in plugins/ and ask questions on the qpsmtpd +mailinglist; subscribe by sending mail to qpsmtpd-subscribe@perl.org. + +=head1 General return codes + +Each plugin must return an allowed constant for the hook and (usually) +optionally a "message". + +Generally all plugins for a hook are processed until one returns +something other than "DECLINED". + +Plugins are run in the order they are listed in the "plugins" +configuration. + +=over 4 + +=item OK + +Action allowed + +=item DENY + +Action denied + +=item DENYSOFT + +Action denied; return a temporary rejection code (say 450 instead of 550). + +=item DECLINED + +Plugin declined work; proceed as usual. This return code is always +allowed unless noted otherwise. + +=item DONE + +Finishing processing of the request. Usually used when the plugin +sent the response to the client. + +=back + +See more detailed description for each hook below. + +=head1 Hooks + +=head2 mail + +Called right after the envelope sender address is passed. The plugin +gets passed a Mail::Address object. Default is to allow the +recipient. + +Allowed return codes + + OK - sender allowed + DENY - Return a hard failure code + DENYSOFT - Return a soft failure code + DONE - skip further processing + + +=head2 rcpt + +Hook for the "rcpt" command. Defaults to deny the mail with a soft +error code. + +Allowed return codes + + OK - recipient allowed + DENY - Return a hard failure code + DENYSOFT - Return a soft failure code + DONE - skip further processing + + +=head2 quit + +Called on the "quit" command. + +Allowed return codes: + + DONE + +All other codes will qpsmtpd do the default response. + diff --git a/STATUS b/STATUS index de4808b..75fb4b7 100644 --- a/STATUS +++ b/STATUS @@ -2,29 +2,40 @@ things to do for v0.10 ---------------------- -transaction should probably be a part of the connection object instead +transaction should maybe be a part of the connection object instead of off the main object -get timeouts to work in "tcpserver" mode (or generally...) +get timeouts to work in "tcpserver" mode (or generally; not sure where +it fits best) plugin support; - load plugins in a funny namespace - let them register the "hooks" they want to run in + support plugins for the rest of the commands. + + specify a priority in register_hook. ("LAST", "FIRST", "MIDDLE", or + maybe a number) + + proper access to the message body through the transaction data command - how to spool the file? + how to spool message to a file when it grows large and still give + reasonable easy access to the data from plugins? ... - -TRACE in Constants.pm is not actually being used. +TRACE in Constants.pm is not actually being used. Should it? -Plugin Documentation! +Future Ideas +============ +Methods to create a bounce message easily; partly so we can accept a +mail for one user but bounce it right away for another RCPT'er. + +David Carraway has some thoughts for "user filters" +http://nntp.perl.org/group/perl.qpsmtpd/2 diff --git a/config.sample/IP b/config.sample/IP index 360c58e..04d03ac 100644 --- a/config.sample/IP +++ b/config.sample/IP @@ -1,4 +1,4 @@ -0 +64.81.84.165 # the first line of this file is being used as the IP # address tcpserver will bind to. Use 0 to bind to all # interfaces. diff --git a/config.sample/plugins b/config.sample/plugins index d415efc..1577a09 100644 --- a/config.sample/plugins +++ b/config.sample/plugins @@ -1,3 +1,7 @@ quit_fortune +require_resolvable_fromhost +rhsbl # dnsbl +# this plugin needs to run after all other "rcpt" plugins +check_relay diff --git a/config.sample/rhsbl_zones b/config.sample/rhsbl_zones index 649a8b3..5c5c73d 100644 --- a/config.sample/rhsbl_zones +++ b/config.sample/rhsbl_zones @@ -2,3 +2,4 @@ dsn.rfc-ignorant.org does not accept bounces. This violates RFC 821/2505/2821 ht + diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 22363da..89980f5 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -72,8 +72,6 @@ sub dispatch { my $self = shift; my ($cmd) = lc shift; - warn "command: $cmd"; - #$self->respond(553, $state{dnsbl_blocked}), return 1 # if $state{dnsbl_blocked} and ($cmd eq "rcpt"); @@ -164,16 +162,25 @@ sub mail { } return $self->respond(501, "could not parse your mail from command") unless $from; - # this needs to be moved to a plugin --- FIXME - 0 and $from->format ne "<>" - and $self->config("require_resolvable_fromhost") - and !check_dns($from->host) - and return $self->respond(450, $from->host ? "Could not resolve ". $from->host : "FQDN required in the envelope sender"); - - $self->log(2, "getting mail from ".$from->format); - $self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!"); - - $self->transaction->sender($from); + my ($rc, $msg) = $self->run_hooks("mail", $from); + if ($rc == DONE) { + return 1; + } + elsif ($rc == DENY) { + $msg ||= $from->format . ', denied'; + $self->log(2, "deny mail from " . $from->format . " ($msg)"); + $self->respond(550, $msg); + } + elsif ($rc == DENYSOFT) { + $msg ||= $from->format . ', temporarily denied'; + $self->log(2, "denysoft mail from " . $from->format . " ($msg)"); + $self->respond(450, $msg); + } + else { # includes OK + $self->log(2, "getting mail from ".$from->format); + $self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!"); + $self->transaction->sender($from); + } } } @@ -182,41 +189,34 @@ sub rcpt { return $self->respond(501, "syntax error in parameters") unless $_[0] =~ m/^to:/i; return(503, "Use MAIL before RCPT") unless $self->transaction->sender; - my $from = $self->transaction->sender; - - # Move to a plugin -- FIXME - if (0 and $from->format ne "<>" and $self->config('rhsbl_zones')) { - my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->config('rhsbl_zones'); - my $host = $from->host; - for my $rhsbl (keys %rhsbl_zones) { - $self->respond("550", "Mail from $host rejected because it $rhsbl_zones{$rhsbl}"), return 1 - if check_rhsbl($rhsbl, $host); - } - } - my ($rcpt) = ($_[0] =~ m/to:(.*)/i)[0]; $rcpt = $_[1] unless $rcpt; $rcpt = (Mail::Address->parse($rcpt))[0]; return $self->respond(501, "could not parse recipient") unless $rcpt; - return $self->respond(550, "will not relay for ". $rcpt->host) unless $self->check_relay($rcpt->host); - $self->transaction->add_recipient($rcpt); - $self->respond(250, $rcpt->format . ", recipient ok"); -} - -sub check_relay { - my $self = shift; - my $host = lc shift; - my @rcpt_hosts = $self->config("rcpthosts"); - return 1 if exists $ENV{RELAYCLIENT}; - for my $allowed (@rcpt_hosts) { - $allowed =~ s/^\s*(\S+)/$1/; - return 1 if $host eq lc $allowed; - return 1 if substr($allowed,0,1) eq "." and $host =~ m/\Q$allowed\E$/i; + my ($rc, $msg) = $self->run_hooks("rcpt", $rcpt); + if ($rc == DONE) { + return 1; + } + elsif ($rc == DENY) { + $msg ||= 'relaying denied'; + $self->respond(550, $msg); + } + elsif ($rc == DENYSOFT) { + $msg ||= 'relaying denied'; + return $self->respond(550, $msg); + } + elsif ($rc == OK) { + $self->respond(250, $rcpt->format . ", recipient ok"); + return $self->transaction->add_recipient($rcpt); + } + else { + return $self->respond(450, "Could not determine of relaying is allowed"); } return 0; } + sub get_qmail_config { my ($self, $config) = (shift, shift); $self->log(5, "trying to get config for $config"); @@ -269,9 +269,10 @@ sub rset { sub quit { my $self = shift; - my @fortune = `/usr/games/fortune -s`; - @fortune = map { chop; s/^/ \/ /; $_ } @fortune; - $self->respond(221, $self->config('me') . " closing connection. Have a wonderful day.", @fortune); + my ($rc, $msg) = $self->run_hooks("quit"); + if ($rc != DONE) { + $self->respond(221, $self->config('me') . " closing connection. Have a wonderful day."); + } exit; } @@ -449,37 +450,57 @@ sub load_plugins { my $eval = join( "\n", "package $package;", + 'use Qpsmtpd::Constants;', "require Qpsmtpd::Plugin;", 'use vars qw(@ISA);', '@ISA = qw(Qpsmtpd::Plugin);', -# $line, + $line, $sub, "\n", # last line comment without newline? ); warn "eval: $eval"; - $eval =~ m/(.*)/; + $eval =~ m/(.*)/s; $eval = $1; eval $eval; warn "EVAL: $@"; die "eval $@" if $@; - #my $package_path = $package; - #$package_path =~ s!::!/!g; - #$package_path .= ".pm"; - #$INC{$package_path} = "$dir/$plugin"; - #use Data::Dumper; - #warn Data::Dumper->Dump([\%INC, \@INC], [qw(INCh INCa)]); - - my $plug = $package->new(); - $plug->register(); + my $plug = $package->new(qpsmtpd => $self); + $plug->register($self); } +} +sub run_hooks { + my ($self, $hook) = (shift, shift); + if ($self->{_hooks}->{$hook}) { + my @r; + for my $code (@{$self->{_hooks}->{$hook}}) { + (@r) = &{$code}($self->transaction, @_); + last unless $r[0] == DECLINED; + } + return @r; + } + warn "Did not run any hooks ..."; + return (0, ''); +} + +sub _register_hook { + my $self = shift; + my ($hook, $code) = @_; + + #my $plugin = shift; # see comment in Plugin.pm:register_hook + + $self->{_hooks} ||= {}; + my $hooks = $self->{_hooks}; + push @{$hooks->{$hook}}, $code; } + + 1; diff --git a/lib/Qpsmtpd/Constants.pm b/lib/Qpsmtpd/Constants.pm index 8deb382..ec9a1c2 100644 --- a/lib/Qpsmtpd/Constants.pm +++ b/lib/Qpsmtpd/Constants.pm @@ -1,7 +1,21 @@ package Qpsmtpd::Constants; use strict; +require Exporter; + +my (@common) = qw(OK DECLINED DONE DENY DENYSOFT TRACE); + +use vars qw($VERSION @ISA @EXPORT); +@ISA = qw(Exporter); +@EXPORT = @common; + use constant TRACE => 10; +use constant OK => 900; +use constant DENY => 901; +use constant DENYSOFT => 902; +use constant DECLINED => 909; +use constant DONE => 910; + 1; diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index a15b286..f4788a0 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -4,14 +4,28 @@ use strict; sub new { my $proto = shift; my $class = ref($proto) || $proto; - bless ({}, $class); + my %args = @_; + bless ({ _qp => $args{qpsmtpd} }, $class); } - - sub register_hook { - warn "REGISTER HOOK!"; + my ($plugin, $hook, $method) = @_; + # 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, sub { $plugin->$method(@_) }); } +sub qp { + shift->{_qp}; +} + +sub log { + shift->qp->log(@_); +} + +sub transaction { + # not sure if this will work in a non-forking or a threaded daemon + shift->qp->transaction; +} 1; diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index 19b5f7e..b9a7448 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -45,6 +45,12 @@ sub blocked { $self->{_blocked}; } +sub notes { + my $self = shift; + my $key = shift; + @_ and $self->{_notes}->{$key} = shift; + $self->{_notes}->{$key}; +} #sub add_header_line { #} diff --git a/plugins/check_relay b/plugins/check_relay new file mode 100644 index 0000000..6474ea3 --- /dev/null +++ b/plugins/check_relay @@ -0,0 +1,23 @@ +# this plugin checks the standard rcpthosts config and +# $ENV{RELAYCLIENT} to see if relaying is allowed. +# +# It should be configured to be run _LAST_! +# + +sub register { + my ($self, $qp) = @_; + $self->register_hook("rcpt", "check_relay"); +} + +sub check_relay { + my ($self, $transaction, $recipient) = @_; + my $host = lc $recipient->host; + my @rcpt_hosts = $self->qp->config("rcpthosts"); + return (OK) if exists $ENV{RELAYCLIENT}; + for my $allowed (@rcpt_hosts) { + $allowed =~ s/^\s*(\S+)/$1/; + return (OK) if $host eq lc $allowed; + return (OK) if substr($allowed,0,1) eq "." and $host =~ m/\Q$allowed\E$/i; + } + return (DENY); +} diff --git a/plugins/quit_fortune b/plugins/quit_fortune index 3ad54e3..4d5ef09 100644 --- a/plugins/quit_fortune +++ b/plugins/quit_fortune @@ -1,14 +1,12 @@ -sub new {} - sub register { - my ($self, $qp) = @_; - - $qp->register_hook("quit", "quit_handler"); - + shift->register_hook("quit", "quit_handler"); } sub quit_handler { - my ($self, $qp) = @_; - + my $qp = shift->qp; + my @fortune = `/usr/games/fortune -s`; + @fortune = map { chop; s/^/ \/ /; $_ } @fortune; + $qp->respond(221, $qp->config('me') . " closing connection.", @fortune); + return DONE; } diff --git a/plugins/require_resolvable_fromhost b/plugins/require_resolvable_fromhost new file mode 100644 index 0000000..c0869fb --- /dev/null +++ b/plugins/require_resolvable_fromhost @@ -0,0 +1,46 @@ +use Net::DNS qw(mx); + +sub register { + my ($self, $qp) = @_; + $self->register_hook("mail", "mail_handler"); +} + +sub mail_handler { + my ($self, $transaction, $sender) = @_; + + $sender->format ne "<>" + and $self->qp->config("require_resolvable_fromhost") + and !check_dns($sender->host) + and return (DENYSOFT, + ($sender->host + ? "Could not resolve ". $sender->host + : "FQDN required in the envelope sender")); + + return DECLINED; + +} + + +sub check_dns { + my $host = shift; + + # for stuff where we can't even parse a hostname out of the address + return 0 unless $host; + + return 1 if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; + + my $res = new Net::DNS::Resolver; + return 1 if mx($res, $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"; + } + } + else { + warn "$$ query for $host failed: ", $res->errorstring, "\n" + unless $res->errorstring eq "NXDOMAIN"; + } + return 0; +} + diff --git a/plugins/rhsbl b/plugins/rhsbl new file mode 100644 index 0000000..da49f59 --- /dev/null +++ b/plugins/rhsbl @@ -0,0 +1,37 @@ + +sub register { + my ($self, $qp) = @_; + $self->register_hook("mail", "mail_handler"); + $self->register_hook("rcpt", "rcpt_handler"); +} + +sub mail_handler { + my ($self, $transaction, $sender) = @_; + # lookup the address here; but always just return DECLINED + if ($sender->format ne "<>" and $self->qp->config('rhsbl_zones')) { + my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->qp->config('rhsbl_zones'); + my $host = $sender->host; + for my $rhsbl (keys %rhsbl_zones) { + $transaction->notes('rhsbl', "Mail from $host rejected because it $rhsbl_zones{$rhsbl}") + if check_rhsbl($self, $rhsbl, $host); + } + } +} + +sub rcpt_handler { + my ($self, $transaction, $rcpt) = @_; + my $note = $transaction->notes('rhsbl'); + return (DENY, $note) if $note; + return DECLINED; +} + +sub check_rhsbl { + my ($self, $rhsbl, $host) = @_; + return 0 unless $host; + $self->log(2, "checking $host in $rhsbl"); + return 1 if ((gethostbyname("$host.$rhsbl"))[4]); + return 0; +} + + + diff --git a/qpsmtpd b/qpsmtpd index 22bb166..69b843a 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -26,36 +26,6 @@ $qpsmtpd->run(); __END__ -sub check_rhsbl { - my ($rhsbl, $host) = @_; - return 0 unless $host; - warn "$$ checking $host in $rhsbl\n" if $TRACE > 2; - return 1 if ((gethostbyname("$host.$rhsbl"))[4]); - return 0; -} - -sub check_dns { - my $host = shift; - - # for stuff where we can't even parse a hostname out of the address - return 0 unless $host; - - return 1 if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; - - my $res = new Net::DNS::Resolver; - return 1 if mx($res, $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"; - } - } - else { - warn "$$ query for $host failed: ", $res->errorstring, "\n" - unless $res->errorstring eq "NXDOMAIN"; - } - return 0; -} 1;