171 lines
4.2 KiB
Perl
171 lines
4.2 KiB
Perl
#!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;
|
|
}
|