#!/usr/bin/perl -w

=head1 NAME

bounce_verp - verp all your outgoing mail to make bounces work again

=head1 DESCRIPTION

Anyone who has been using mail for a long time will know that bounces from mail
you didn't send is a real problem. Some solutions have been proposed to handle
this such as SPF which rely on the rest of the internet to implement SPF
checking so that they will not send you bounces. This solution works without
global cooperation.

See also the BATV proposal from Dave Crocker, which uses a slightly different
syntax.

This module will basically change all your outbound email (those that are considered
to be B<"relaying">) from the format:

  localpart@domain

Into:

  securehash=ts=localpart@domain

The securehash and ts (timestamp) are short base32 encoded versions of HMAC and epoch
time respectively. They should be secure enough. The format used is also known as a
"VERP" or Variable Envelope Return Path.

=head1 ISSUES

There are some problems with verping the return path.

=over 4

=item * Ezmlm - this uses the return path to decide who is sending the mail and thus
figure out if you are a member of the mailing list.

=item * Qmail - qmail provides very easy access to the return path via the dot-qmail
files, and so there are likely many systems built on qmail which behave this way.

=item * (Your Entry Here)

=back

Each of these things can be added to the bounce_verp.skip list. (See
L</bounce_verp.skip> below).

=head1 Configuration

There are a few configuration files you can create. All are optional except for
F<bounce_verp.secret>.

=head2 bounce_verp.secret

This file is mandatory, and should contain your secrets (no, not those ones).

Each line should contain a secret. The topmost one is used for outbound verping,
the following lines are used for validation. This allows you to rotate secrets
should you fear they have been found out.

=head2 bounce_verp.maxage

Default: 7 (days)

The maximum number of days a bounce verp should be valid for. Set this to the
longest delay you are willing to accept bounces for, on mails you sent.

=head2 bounce_verp.hashlength

Default: 4

The number of characters to store in your email address for your hash. Normally
four characters is sufficient, however you may wish to increase this if you are
security concious.

=head2 bounce_verp.hashmin

Default: 4

=head2 bounce_verp.skip

This file should contain a list of email addresses or domains that you should
skip this verp magic for. The code tries to be a little bit clever to cope with
systems that send out mails from multiple email addresses, such as ezmlm, so
that you only have to specify the main address. e.g.:

  foo.com
  qpsmtpd@perl.org

Will skip verping/checking for all emails to/from any address or subdomain of I<foo.com>,
and skip verping/checking for all emails to/from the qpsmtpd mailing list, including
help, unsubscribe, and other sub-list requests.

Note: These addresses are easily forgeable. Patches welcome to add checking of rDNS
into the mix to eliminate the forgery problem (though rDNS isn't available to everyone).

=cut

use Mail::SRS;

sub register {
    my ($plugin) = @_;

    $plugin->register_hook('data' => 'do_verp');
    $plugin->register_hook('data_post' => 'check_verp');
}

sub do_verp {
    my ($self, $transaction) = @_;

    if ($self->qp->connection->relaying) {
        $self->log(LOGINFO, "doing outbound verp");
        return $self->do_outbound_verp($transaction);
    }

    return DECLINED;
}

sub check_verp {
    my ($self, $transaction) = @_;

    if ($self->qp->connection->relaying) {
        return DECLINED;
    }
    
    $self->log(LOGINFO, "checking inbound verp");
    return $self->do_inbound_verp($transaction);
}

sub get_srs {
    my $self = shift;

    my @secrets =     $self->qp->config('bounce_verp.secret') ||
                die "No secrets defined";
    my $max_age =     $self->qp->config('bounce_verp.maxage') || 7; # days
    my $hash_length = $self->qp->config('bounce_verp.hashlength') || 4;
    my $hash_min =    $self->qp->config('bounce_verp.hashmin') || 4;

    my $srs = Mail::SRS->new(Secret => \@secrets,
                             MaxAge => $max_age,
                             HashLength => $hash_length,
                             HashMin => $hash_min,
                         );

    return $srs;
}

sub do_outbound_verp {
    my ($self, $transaction) = @_;

    my $sender = $transaction->sender->address;
    
    return DECLINED if $self->skip_verp($sender);

    my $srs = $self->get_srs();

    my $timestamp = $srs->timestamp_create();

    my $hash = $srs->hash_create($timestamp, $sender);

    my $new_address = join('=', $hash, $timestamp, $sender);

    $self->log(LOGDEBUG, "setting sender to $new_address");
    $transaction->sender(Qpsmtpd::Address->new($new_address));

    return DECLINED;
}

sub do_inbound_verp {
    my ($self, $transaction) = @_;

    my ($recip, $not_allowed) = $transaction->recipients;

    $recip = $recip->address;
    
    return DECLINED if $self->skip_verp($recip);

    return DECLINED unless $self->is_bounce($transaction);

    $self->log(LOGDEBUG, "validating bounce recipient: $recip");
    #return DENY, "Multiple recipients of bounces not allowed" if $not_allowed;
    
    my $srs = $self->get_srs();

    my ($hash, $timestamp, $address) = split('=', $recip, 3);

    if (!$srs->hash_verify($hash, $timestamp, $address)) {
        return DENY, "This mail did not originate here.";
    }
    
    if (!$srs->timestamp_check($timestamp)) {
        return DENY, "You took too long to send this bounce,\n" .
            "or someone is trying a replay attack on an old VERP of mine";
    }

    # now set RCPTs to proper address.
    $self->log(LOGDEBUG, "fixing inbound recipient to be $address");
    $transaction->recipients(Qpsmtpd::Address->new($address));

    return DECLINED;
}

sub is_bounce {
    my ($self, $transaction) = @_;

    my $sender = $transaction->sender->address;

    return 1 if ($sender eq '');

    return 1 if ($sender =~ /^postmaster\@/i);

    return 1 if ($sender =~ /^mailer[_-]daemon\@/i);

    my $headers = $transaction->header();
    my $from = $headers->get('From');
    my $subject = $headers->get('Subject');

    return 1 if ($from =~ /\bpostmaster\@/i);
    return 1 if ($from =~ /\bmailer-daemon\@/i);
    
    return 1 if ($subject =~ /failure notice/i);
    return 1 if ($subject =~ /Rejected mail/i);

    return 0;
}

# Should we skip verping for this transaction?
sub skip_verp {
    my ($self, $address) = @_;
    
    my @skips = $self->qp->config('bounce_verp.skip');
    
    foreach my $skip (@skips) {
        if (index($skip, '@') < 0) {
            # skip a domain, and any subdomains
            return 1 if $address =~ /[@\.]\Q$skip\E$/i;
        }
        else {
            # skip an address.
            return 1 if $address eq $skip;
            
            # OK, it's not that address, but is it a mailing list verp
            my ($local, $domain) = ($skip =~ /^(.*)\@(.*?)$/);
            if ($address =~ /^\Q$local\E\b/i and $address =~ /\@\Q$domain\E$/i) {
                return 1;
            }
        }
    }
    
    return 0;
}