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'll still seeing quite a few hams 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;
};