yay, plugin support works! :-D
git-svn-id: https://svn.perl.org/qpsmtpd/branches/v010@34 958fd67b-6ff1-0310-b445-bb7760255be9
This commit is contained in:
Ask Bjørn Hansen
parent
a032ced541
commit
2fe35f1b8d
|
|
@ -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.
|
||||
|
||||
27
STATUS
27
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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -1,3 +1,7 @@
|
|||
quit_fortune
|
||||
require_resolvable_fromhost
|
||||
rhsbl
|
||||
# dnsbl
|
||||
|
||||
# this plugin needs to run after all other "rcpt" plugins
|
||||
check_relay
|
||||
|
|
|
|||
|
|
@ -2,3 +2,4 @@ dsn.rfc-ignorant.org does not accept bounces. This violates RFC 821/2505/2821 ht
|
|||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
125
lib/Qpsmtpd.pm
125
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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
#}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
||||
|
||||
30
qpsmtpd
30
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;
|
||||
|
|
|
|||
Loading…
Reference in New Issue