Permalink
Fetching contributors…
Cannot retrieve contributors at this time
174 lines (123 sloc) 4.43 KB
#!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 - 2013 - save results to Authentication-Results header
instead of DomainKey-Status
Matt Simerson - 2012 - refactored, added tests, safe loading
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_headers', '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->store_auth_results('domainkey=' . $status);
$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;
}