qpsmtpd/plugins/domainkeys

#!perl -w

=head1 NAME

domainkeys: validate a DomainKeys signature on an incoming mail

=head1 SYNOPSIS

  domainkeys [reject 1]

Performs a DomainKeys validation on the message.

=head1 DEPRECATION

You should probably NOT be using this plugin. DomainKeys has been deprecated in favor of DKIM. That being said, it's March 2013 and I'm still seeing ham arrive with DomainKeys signatures.

=head1 CONFIGURATION

=head2 reject

  reject 1

Reject is a boolean that toggles message rejection on or off. Messages failing
DomainKeys validation are rejected by default.

=head2 reject_type

  reject_type [ temp | perm ]

The default rejection type is permanent.

=head2 warn_only

A deprecated option that disables message rejection. See reject instead.

=head1 COPYRIGHT

Copyright (C) 2005-2006 John Peacock.

Portions Copyright (C) 2004 Anthony D. Urso.  All rights reserved.  This
program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 AUTHORS

 Matt Simerson    - 2012
 John Peacock     - 2005-2006
 Anthony D. Urso. - 2004

=cut

use strict;
use warnings;

use Qpsmtpd::Constants;

sub init {
    my ($self, $qp, %args) = @_;

    foreach my $key (%args) {
        $self->{$key} = $args{$key};
    }
    $self->{reject} = 1 if !defined $self->{reject};    # default reject
    $self->{reject_type} = 'perm' if !defined $self->{reject_type};

    if ($args{'warn_only'}) {
        $self->log(LOGNOTICE, "warn_only is deprecated. Use reject instead");
        $self->{'reject'} = 0;
    }
}

sub register {
    my $self = shift;

    for my $m (qw/ Mail::DomainKeys::Message Mail::DomainKeys::Policy /) {
        eval "use $m";
        if ($@) {
            warn "skip: plugin disabled, could not load $m\n";
            $self->log(LOGERROR, "skip: plugin disabled, is $m installed?");
            return;
        }
    }

    $self->register_hook('data_post', 'data_post_handler');
}

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

    return DECLINED if $self->is_immune();

    if (!$transaction->header->get('DomainKey-Signature')) {
        $self->log(LOGINFO, "skip, unsigned");
        return DECLINED;
    }

    my $body = $self->assemble_body($transaction);

    my $message =
      load Mail::DomainKeys::Message(
                                  HeadString => $transaction->header->as_string,
                                  BodyReference => $body)
      or do {
        $self->log(LOGWARN, "skip, unable to load message"), return DECLINED;
      };

    # no sender domain means no verification
    if (!$message->senderdomain) {
        $self->log(LOGINFO, "skip, failed to parse sender domain"),
          return DECLINED;
    }

    my $status = $self->get_message_status($message);

    if (defined $status) {
        $transaction->header->add("DomainKey-Status", $status, 0);
        $self->log(LOGINFO, "pass, $status");
        return DECLINED;
    }

    $self->log(LOGERROR, "fail, signature invalid");
    return DECLINED if !$self->{reject};
    my $deny = $self->{reject_type} eq 'temp' ? DENYSOFT : DENY;
    return ($deny, "DomainKeys signature validation failed");
}

sub get_message_status {
    my ($self, $message) = @_;

    if ($message->testing) {
        return "testing";    # key testing, don't do anything else
    }

    if ($message->signed && $message->verify) {
        return $message->signature->status;    # verified: add good header
    }

    # not signed or not verified
    my $policy =
      fetch Mail::DomainKeys::Policy(Protocol => 'dns',
                                     Domain   => $message->senderdomain);

    if (!$policy) {
        return $message->signed ? "non-participant" : "no signature";
    }

    if ($policy->testing) {
        return "testing";    # Don't do anything else
    }

    if ($policy->signall) {
        return undef;        # policy requires all mail to be signed
    }

    # $policy->signsome
    return "no signature";    # not signed and domain doesn't sign all
}

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

    $transaction->body_resetpos;
    $transaction->body_getline;    # \r\n seperator is NOT part of the body

    my @body;
    while (my $line = $transaction->body_getline) {
        push @body, $line;
    }
    return \@body;
}