I use qpsmtpd, a sort of mod+perl for SMTP, to front end my SMTP server. This lets me configure various checks in the name of blocking spam and managing mail for my private domain. There are plugins to check messages before accepting them (scan headers, check the body with SpamAssassin, greylist senders or blacklist senders, check for certain bad behaviour typical of spambots etc) and plugins to deliver mail to various back end systems.

I use this to front end qmail which, amongst other features, has nice handling of aliases including wildcard addresses - so after geting various 'dictionary spam' attacks (mail sent to random names in the hope of hitting a valid user) as well as getting spurious bounces from the joe-jobbing activities of spammers, I wanted to have qpsmtpd understand which addresses were valid and which weren't.

As a result, I wrote the following plugin that knows how to parse the various qmail config files for user assignments and aliases.

It may not be perfect - in particular

• it's written against an old version of qpsmtpd - I think there are conveniences in newer versions to tidy up some logic
• it knows about qmail files and config setup, so isn't very generalised for anythign other than qmail
• it assumes it'll be able to access the various files that qmail reads - this is true for my setup, YMMV
• it's not in github or launchpad or similar (but may be soon)

but if you're using qmail behind qpsmtpd and you use the assigns file or similar, then you may find it handy.

<div>
<pre>=head1 NAME

check_goodrcptto

=head1 DESCRIPTION

A qpsmtpd plugin checks that the name recipient is valid according to the qmail
config and refuses the mail otherwise.

See http://wiki.qpsmtpd.org/ for details of qpsmptd itself

=head1 CONFIG

Takes the name of the qmail assign file - normally /var/qmail/users/assign

=head1 AUTHOR

Written by Tim Meadowcroft - http://schmerg.com

Published under the same license as Perl itself - you're free to use this as you see fit.

=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>/.qmail<dash><extension>
  # will specify how the messages are to be delivered.
  #
  #   +prefix:user:uid:gid:directory:dash:prepend:
  # Messages received for <prefix><rest> will be delivered as user <user>,
  # with the specified uid and gid, and the file
  # <directory>/.qmail<dash><prepend><rest> 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) : \@lines;
}

# $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 $_)
    {
        my $d = slurp($_, sub { chomp @_;
                    return join(", ", grep(!/^#/,@_)) });
        return $v->{user}." ($d)";
    }
      }
    }
  }

  return undef;
}

1;