On Monday 12 March 2007 01:48, Matt Sergeant wrote:
Is there a simple rcpt plugin to check against the qmail aliases
directory and the qmail virtualdomains file?
This is my check_goodrcptto that reads the assign file
(typically /var/qmail/users/assign) and allows for non-alias addresses in
there and then looks up the aliases configured in there
(typically /var/qmail/alias).
It takes account of rcpthosts, you could probably expand it for
virtual-domains.
--
Tim
#/bin/perl
=head1 NAME
check_goodrcptto
=head1 DESCRIPTION
This plugin checks that the name recipient is valid according to the qmail
config and refuses the mail otherwise.
=head1 CONFIG
Takes the name of the qmail assign file - normally /var/qmail/users/assign
=cut
sub register {
my ($self, $qp, @args) = @_;
die Requires the path of the assign file (usually /var/qmail/users/assign)
unless (@args 0 and -f $args[0]);
my $assign = ReadAssignments( $args[0] );
die $assign unless ref $assign;
$self-{_assign} = $assign;
$self-register_hook(rcpt, rcpt_handler);
}
sub ReadAssignments {
my $lines = slurp($_[0], sub { [ grep(!/^\s*#/, @_) ] } )
or return Can't read the assign file $_[0];
chomp @$lines;
# last line should be a single dot
return Assign file not properly terminated unless $lines-[-1] eq .;
# extract simple assignments first
# =address:user:uid:gid:directory:dash:extension:
# Messages for address will be delivered as user user, with the
# specified uid and gid, and the file directory/.qmaildashextension
# will specify how the messages are to be delivered.
#
# +prefix:user:uid:gid:directory:dash:prepend:
# Messages received for prefixrest will be delivered as user user,
# with the specified uid and gid, and the file
# directory/.qmaildashprependrest will specify how the messages
# are to be delivered.
my %a;
foreach (@$lines) {
my $type = substr($_,0,1,);
my($address,$user,$uid,$gid,$dir,$dash,$ext) = (split(:, $_), ()x7);
if ($type eq =) {
# got a user
$a{user}-{$address} = { user = $user,
dir = $dir,
dash = $dash,
ext = $ext };
} elsif ($type eq +) {
# got a prefix
$a{prefix}-{$address} = { user = $user,
dir = $dir,
dash = $dash,
ext = $ext };
}
}
return \%a;
}
sub slurp {
my $file = shift;
my $fh;
open($fh,$file) or return undef;
my @lines = $fh;
close $fh;
return @_ ? $_[0]-(@lines) : [EMAIL PROTECTED];
}
# $recipient is a Mail::Address object, see if it looks deliverable
sub rcpt_handler {
my ($self, $transaction, $recipient) = @_;
$self-log(LOGDEBUG, check_goodrcptto of .$recipient-user);
return (DECLINED) if $recipient-user eq ;
# we only check recipients for the domains we accept - let any relayed
# mails pass thru (assuming that relaying is allowed) including
# no hostname (so plain postmaster and abuse works)
my @rcpthosts = $self-qp-config(rcpthosts) or return (DECLINED);
my @localhosts = ($self-qp-config(me), localhost, qx(hostname), );
chomp @localhosts;
my $host = lc $recipient-host;
return(DECLINED) unless grep($_ eq $host, @rcpthosts, @localhosts) 0;
# Look up this user and see if it looks like a valid user
my $user = $recipient-user;
$self-log(LOGDEBUG, check_goodrcptto: $user needs checking);
if (CanBeDelivered($user = $self-{_assign}))
{
$self-log(LOGDEBUG, $user accepted);
return DECLINED;
}
my $sender = $transaction-sender-address;
$sender = unless defined $sender;
$self-log(LOGDEBUG, check_goodrcptto: $user is rejected, tell $sender);
# genuine mistake or, more likely, spammers flooding us
return(DENY, No such account - mail to $user not accepted here)
unless (not(defined($sender)) or $sender eq );
# bounce of email form a non-existant user - recommend SPF
return(DENY, No such account as $user - checking SPF records would prevent
bouncing of joe-job emails);
}
# Returns a name if we believe a message can be delivered to the specified
# user, or undef if not...
sub CanBeDelivered {
my($user,$assign) = @_;
# Look up this user and see if it looks like a valid user
# Delivery will be according that user's .qmail or the defaultdelivery file
return $user if exists $assign-{user}-{$user};
# if the user isn't directly listed, check the prefixes, longest first
foreach my $prefix (reverse sort {length($a) = length($b)}
keys %{$assign-{prefix}}) {
if (substr($user,0,length($prefix)) eq $prefix) {
# this prefix matches the specified user part of the email address
my $v = $assign-{prefix}-{$prefix};
my $rest = substr($user,length($prefix));
my $dotqmail = $v-{dir}./.qmail.$v-{dash}.$v-{ext};
foreach ($dotqmail.$rest, $dotqmail.default) {
if (-f $_)
