=head1 NAME

batv

=head1 DESCRIPTION

Plugin to implement Bounce Address Tag Validation (BATV).

For relay clients this plugin rewrites the envelope sender to include a 
signature as described in section 4 (Simple Private Signature (prvs)) of
draft-levine-batv-03.

For unauthenticated clients, it does the following:

If the sender is not <> and the recipient address doesn't conform to
BATV syntax, return DECLINED. 

If the signature checks out, return OK. (is this a good idea? Or should
we merely remove the signature and return DECLINED?)

Otherwise return DENY.

=head1 CONFIG

The following parameters can be passed to require_resolvable_client:

=over 4


=item secret <secret_file>

The path of the file containing the secret.
(generations? Last line?)
Default: config_dir/batv_secrets

=item domain_map <map_file>

If specified, the domain name of outgoing messages will be changed according to
the map included in <map_file>.

Example:

    example.net bounce.example.net
    example.com sender.example.com

will map any oufgoing address of the form <foo@example.net> to
<prvs=XXXXXXXXXX=foo@bounce.example.net>.
When receiving a message, the reverse mapping will be performed.

WARNING: Starting with release 308, batv is performed only for domains in this
file. If it doesn't exist, the batv plugin does nothing.

Default: none

=back

=head1 NOTES

This plugin makes use of the following connection notes:

=over

=item $connection->('client_options')->{batv}{skip}

...

=back

and of the following transaction notes:

=over

=item $transaction->notes('recipient_options')->{batv}

...

=back

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2008 Peter J. Holzer <hjp@hjp.at>. 

This plugin is licensed under the same terms as the qpsmtpd package
itself.
Please see the LICENSE file included with qpsmtpd for details.

=cut

use Digest::SHA1  qw(sha1_hex);


sub register {
    my ($self, $qp, %arg) = @_;
}

sub init {
    my ($self, $qp, %arg) = @_;
    $self->log(LOGRADAR, "in batv::init");
    my $secret_file = $arg{secret} || $self->qp->config_dir('batv_secrets') . '/batv_secrets';
    my $fh;
    unless (open($fh, '<', $secret_file)) {
        $self->log(LOGCRIT, "cannot open $secret_file: $!");
        return;
    }
    while (<$fh>) {
        chomp;
        my ($gen, $secret) = split;
        push @{$self->{batv_secrets} }, {gen => $gen, secret => $secret};
    }
    if ($arg{domain_map}) {
        unless (open($fh, '<', $arg{domain_map})) {
            $self->log(LOGCRIT, "cannot open $arg{domain_map}: $!");
            return;
        }
        while (<$fh>) {
            chomp;
            my ($orig_domain, $batv_domain) = split;
            $self->{batv_map_out}{$orig_domain} = $batv_domain;
            $self->{batv_map_in}{$batv_domain} = $orig_domain;
        }
    }
    return;
}


sub hook_mail {
    my ($self, $transaction, $sender) = @_;
    $self->log(LOGRADAR, "in batv::hook_mail");
    my $connection = $self->qp->connection;
    return DECLINED unless $connection->relay_client;
    my $domain_out = $self->{batv_map_out}{$sender->host};
    return DECLINED unless $domain_out;

    unless ($self->{batv_secrets}) {
        $self->log(LOGCRIT, "no batv_secrets defined");
        return DECLINED;
    }
    my $gen = $self->{batv_secrets}[0]{gen};
    unless ($gen =~ /^\d$/) {
        $self->log(LOGCRIT, "batv generation not a single digit");
        return DECLINED;
    }
    my $secret = $self->{batv_secrets}[0]{secret};
    my $day = sprintf("%03d", (time / 86400 + 7) % 1000);
    my $hash_source =  $gen . $day . $sender;
    my $tagval = $gen . $day . substr(sha1_hex($hash_source . $secret), 0, 6);
    my $localpart = "prvs=$tagval=" . $sender->user;
    if ($sender->can('notes')) {
        $sender->notes('rewrite', $localpart . '@' . $sender->host);
        $self->log(LOGINFO, "delayed change of sender to $sender");
    } else {
        $sender->address($localpart . '@' . $sender->host);
        $self->log(LOGINFO, "changed sender to $sender");
    }
    return DECLINED;
}


sub hook_rcpt {
    my ($self, $transaction, $recipient) = @_;
    $self->log(LOGDEBUG, "\$recipient = ", $recipient);
    my $localpart = $recipient->user;
    if (my ($gen, $day, $hash, $orig_localpart) = ($localpart =~ /^prvs=(\d)(\d\d\d)(\w{6})=(.*)/)) {

        my $domain_in = $self->{batv_map_in}{$recipient->host};
        return DECLINED unless $domain_in;

        my $secret;
        for (@{$self->{batv_secrets}}) {
            $secret = $_->{secret} if $_->{gen} == $gen;
        }
        $self->log(LOGDEBUG, "\$recipient->host = ", $recipient->host);
        my $orig_address = '<' . $orig_localpart . '@' . $domain_in . '>';
        my $hash_source =  $gen . $day . $orig_address;
        $self->log(LOGDEBUG, "hash_source = $hash_source");
        my $hash2 = substr(sha1_hex($hash_source . $secret), 0, 6);
        $self->log(LOGDEBUG, "hash = $hash");
        $self->log(LOGDEBUG, "hash2 = $hash2");
        if ($hash eq $hash2) {
            $self->log(LOGDEBUG, "day = $day");
            my $today = (time / 86400) % 1000;
            $self->log(LOGDEBUG, "today = $today");
            my $dt = ($day - $today + 1000) % 1000;
            $self->log(LOGDEBUG, "dt = $dt");
            if ($dt <= 7) {
                $recipient->address($orig_address);
                if ($self->{batv_map_in}{$recipient->host}) {
                    $self->log(LOGDEBUG, "mapping " . $recipient->host . " to " . $self->{batv_map_in}{$recipient->host});
                    $recipient->address($recipient->user . "@" . $self->{batv_map_in}{$recipient->host});
                }
                $self->log(LOGDEBUG, "accepted for address $recipient");
                return DECLINED;
            } else {
                return (DENY, "expired BATV address");
            }
        } else {
            return (DENY, "garbled BATV address");
        }
    } else {
        if ($transaction->sender->address) {
            # no bounce and no BATV address - ok
            return DECLINED;
        } elsif ($self->qp->connection->relay_client) {
            # if a relay client generates a bounce message, it probably
            # still has the original address, not the mangled address,
            # so we need to accept it.
            return DECLINED;
        } elsif ($self->{batv_map_out}{$recipient->host}) {
            # bounce without BATV address to BATV protected domain - bad
            return (DENY, "bounce to faked address rejected");
        } else {
            # domain not BATV protected - ok.
            return DECLINED;
        }
    }
}

sub hook_queue {
    my ($self, $transaction) = @_;
    return DECLINED unless $transaction->sender->can('notes');
    my $addr = $transaction->sender->notes('rewrite');
    if ($addr) {
        $self->log(LOGINFO, "sender: ", $transaction->sender->address(), " -> $addr");
        $transaction->sender->address($addr);
    }
    return DECLINED;
}

# vim: sw=4 expandtab tw=0