=head1 NAME
Mail::SpamAssassin::Plugin::DomainKeys - perform DomainKeys verification tests
=head1 SYNOPSIS
loadplugin Mail::SpamAssassin::Plugin::DomainKeys [/path/to/DomainKeys.pm]
Signature:
header DK_SIGNED eval:check_domainkeys_signed()
header DK_VERIFIED eval:check_domainkeys_verified()
Policy:
Note that DK policy record is only fetched if DK_VERIFIED is
false to save a signing domain from unnecessary DNS queries,
as recommended (SHOULD) by draft-delany-domainkeys-base.
Rules DK_POLICY_* should preferably not be relied upon when
DK_VERIFIED is true, although they will return false in current
implementation when a policy record is not fetched, except for
DK_POLICY_TESTING, which is true if t=y appears in a public key
record OR in a policy record (when available).
header DK_POLICY_TESTING eval:check_domainkeys_testing()
header DK_POLICY_SIGNSOME eval:check_domainkeys_signsome()
header DK_POLICY_SIGNALL eval:check_domainkeys_signall()
Whitelisting based on verified signature:
header USER_IN_DK_WHITELIST eval:check_for_dk_whitelist_from()
header USER_IN_DEF_DK_WL eval:check_for_def_dk_whitelist_from()
=head1 DESCRIPTION
This is the DomainKeys plugin and it needs lots more documentation.
Note that if the C<Mail::SpamAssassin::Plugin::DKIM> plugin is installed with
C<Mail::DKIM> version 0.20 or later, that plugin will also perform Domain Key
lookups on DomainKey-Signature headers, in which case this plugin is redundant.
Here is author's note from module C<Mail::DomainKeys> version 1.0:
THIS MODULE IS OFFICIALLY UNSUPPORTED.
Please move on to DKIM like a responsible Internet user. I have.
I will leave this module here on CPAN for a while, just in case someone
has grown to depend on it. It is apparent that DK will not be the way
of the future. Thus, it is time to put this module to ground before it
causes any further harm.
Thanks for your support,
Anthony
=cut
package Mail::SpamAssassin::Plugin::DomainKeys;
use Mail::SpamAssassin::Plugin;
use Mail::SpamAssassin::Logger;
use Mail::SpamAssassin::Timeout;
use strict;
use warnings;
use bytes;
BEGIN { require Mail::DomainKeys::Message; require Mail::DomainKeys::Policy; }
use vars qw(@ISA);
@ISA = qw(Mail::SpamAssassin::Plugin);
sub new {
my $class = shift;
my $mailsaobject = shift;
$class = ref($class) || $class;
my $self = $class->SUPER::new($mailsaobject);
bless ($self, $class);
$self->register_eval_rule ("check_domainkeys_signed");
$self->register_eval_rule ("check_domainkeys_verified");
$self->register_eval_rule ("check_domainkeys_signsome");
$self->register_eval_rule ("check_domainkeys_testing");
$self->register_eval_rule ("check_domainkeys_signall");
$self->register_eval_rule ("check_for_dk_whitelist_from");
$self->register_eval_rule ("check_for_def_dk_whitelist_from");
$self->set_config($mailsaobject->{conf});
return $self;
}
sub set_config {
my($self, $conf) = @_;
my @cmds = ();
=head1 USER SETTINGS
=over 4
=item whitelist_from_dk add@ress.com [signing domain name]
Use this to supplement the whitelist_from addresses with a check to make sure
the message has been signed by a DomainKeys signature that can be verified
against the From: domain's DomainKeys public key.
In order to support signing domain names that differ from the address domain
name, only one whitelist entry is allowed per line, exactly like
C<whitelist_from_rcvd>. Multiple C<whitelist_from_dk> lines are allowed.
File-glob style meta characters are allowed for the From: address, just like
with C<whitelist_from_rcvd>. The optional signing domain name parameter must
match from the right-most side, also like in C<whitelist_from_rcvd>.
If no signing domain name parameter is specified the domain of the address
parameter specified will be used instead.
The From: address is obtained from a signed part of the message (ie. the
"From:" header), not from envelope data that is possible to forge.
Since this whitelist requires a DomainKeys check to be made, network tests must
be enabled.
Examples:
whitelist_from_dk joe@example.com
whitelist_from_dk *@corp.example.com
whitelist_from_dk bob@it.example.net example.net
whitelist_from_dk *@eng.example.net example.net
=item def_whitelist_from_dk add@ress.com [signing domain name]
Same as C<whitelist_from_dk>, but used for the default whitelist entries
in the SpamAssassin distribution. The whitelist score is lower, because
these are often targets for spammer spoofing.
=cut
push (@cmds, {
setting => 'whitelist_from_dk',
code => sub {
my ($self, $key, $value, $line) = @_;
unless (defined $value && $value !~ /^$/) {
return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
}
unless ($value =~ /^(\S+)(?:\s+(\S+))?$/) {
return $Mail::SpamAssassin::Conf::INVALID_VALUE;
}
my $address = $1;
my $signer = (defined $2 ? $2 : $1);
unless (defined $2) {
$signer =~ s/^.*@(.*)$/$1/;
}
$self->{parser}->add_to_addrlist_rcvd ('whitelist_from_dk',
$address, $signer);
}
});
push (@cmds, {
setting => 'def_whitelist_from_dk',
code => sub {
my ($self, $key, $value, $line) = @_;
unless (defined $value && $value !~ /^$/) {
return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
}
unless ($value =~ /^(\S+)(?:\s+(\S+))?$/) {
return $Mail::SpamAssassin::Conf::INVALID_VALUE;
}
my $address = $1;
my $signer = (defined $2 ? $2 : $1);
unless (defined $2) {
$signer =~ s/^.*@(.*)$/$1/;
}
$self->{parser}->add_to_addrlist_rcvd ('def_whitelist_from_dk',
$address, $signer);
}
});
=back
=head1 ADMINISTRATOR SETTINGS
=over 4
=item domainkeys_timeout n (default: 5)
How many seconds to wait for a DomainKeys query to complete, before
scanning continues without the DomainKeys result.
=cut
push (@cmds, {
setting => 'domainkeys_timeout',
is_admin => 1,
default => 5,
type => $Mail::SpamAssassin::Conf::CONF_TYPE_NUMERIC
});
$conf->{parser}->register_commands(\@cmds);
}
sub check_domainkeys_signed {
my ($self, $scan) = @_;
$self->_check_domainkeys($scan) unless $scan->{domainkeys_checked};
return $scan->{domainkeys_signed};
}
sub check_domainkeys_verified {
my ($self, $scan) = @_;
$self->_check_domainkeys($scan) unless $scan->{domainkeys_checked};
return $scan->{domainkeys_verified};
}
sub check_domainkeys_signsome {
my ($self, $scan) = @_;
$self->_check_domainkeys($scan) unless $scan->{domainkeys_checked};
return $scan->{domainkeys_signsome};
}
sub check_domainkeys_testing {
my ($self, $scan) = @_;
$self->_check_domainkeys($scan) unless $scan->{domainkeys_checked};
return $scan->{domainkeys_testing};
}
sub check_domainkeys_signall {
my ($self, $scan) = @_;
$self->_check_domainkeys($scan) unless $scan->{domainkeys_checked};
return $scan->{domainkeys_signall};
}
sub check_for_dk_whitelist_from {
my ($self, $scan) = @_;
$self->_check_dk_whitelist($scan, 0) unless $scan->{dk_whitelist_from_checked};
$scan->{dk_whitelist_from};
}
sub check_for_def_dk_whitelist_from {
my ($self, $scan) = @_;
$self->_check_dk_whitelist($scan, 1) unless $scan->{def_dk_whitelist_from_checked};
$scan->{def_dk_whitelist_from};
}
sub _check_domainkeys {
my ($self, $scan) = @_;
$scan->{domainkeys_checked} = 0;
$scan->{domainkeys_signed} = 0;
$scan->{domainkeys_verified} = 0;
$scan->{domainkeys_signsome} = 0;
$scan->{domainkeys_testing} = 0;
$scan->{domainkeys_signall} = 0;
my $header = $scan->{msg}->get_pristine_header();
my $body = $scan->{msg}->get_body();
my $dksighdr = $scan->{msg}->get_header("DomainKey-Signature");
dbg("dk: signature: $dksighdr") if defined $dksighdr;
$self->sanitize_header_for_dk(\$header)
if defined $dksighdr && $dksighdr !~ /(?:^|;)[ \t]*h=/;
my $message = Mail::DomainKeys::Message->load(HeadString => $header,
BodyReference => $body);
if (!$message) {
dbg("dk: cannot load message using Mail::DomainKeys::Message");
return;
}
$scan->{domainkeys_checked} = 1;
my $domain = $message->senderdomain();
if (!$domain) {
dbg("dk: no sender domain");
return;
}
if (defined $message->sender()) {
$scan->{dk_address} = @{$message->sender()}[1];
dbg("dk: sender: $scan->{dk_address}");
} elsif (defined $message->from()) {
$scan->{dk_address} ||= @{$message->from()}[1];
dbg("dk: from: $scan->{dk_address}");
} else {
dbg("dk: could not determine sender: or from: identity");
}
$scan->{dk_signing_domain} = $self->_dkmsg_signing_domain($scan, $message);
dbg("dk: signing domain name: ".
($scan->{dk_signing_domain} ? $scan->{dk_signing_domain} : "not found"));
my $timeout = $scan->{conf}->{domainkeys_timeout};
my $timer = Mail::SpamAssassin::Timeout->new({ secs => $timeout });
my $err = $timer->run_and_catch(sub {
$self->_dk_lookup_trapped($scan, $message, $domain);
});
if ($timer->timed_out()) {
dbg("dk: lookup timed out after $timeout seconds");
return 0;
}
if ($err) {
chomp $err;
warn("dk: lookup failed: $err\n");
return 0;
}
my $comment = $self->_dkmsg_hdr($message);
$comment ||= '';
$comment =~ s/\s+/ /gs;
$scan->{dk_comment} = "DomainKeys status: $comment";
}
sub _dk_lookup_trapped {
my ($self, $scan, $message, $domain) = @_;
if ($message->signed()) {
$scan->{domainkeys_signed} = 1;
if ($message->verify()) {
$scan->{domainkeys_verified} = 1;
}
}
if ($message->testing()) {
$scan->{domainkeys_testing} = 1;
}
my $policy;
if (!$scan->{domainkeys_verified}) {
$policy = Mail::DomainKeys::Policy->fetch(Protocol => 'dns',
Domain => $domain);
my($fetched_policy) = $policy ? $policy->as_string : 'NONE';
$fetched_policy = '' if !defined $fetched_policy;
dbg ("dk: fetched policy for domain $domain: $fetched_policy");
}
return unless $policy;
if ($policy->signsome()) {
$scan->{domainkeys_signsome} = 1;
}
if ($policy->testing()) {
$scan->{domainkeys_testing} = 1;
}
if ($policy->signall()) {
$scan->{domainkeys_signall} = 1;
}
my $comment = $self->_dkmsg_hdr($message);
dbg("dk: comment is '$comment'");
}
sub _dkmsg_hdr {
my ($self, $message) = @_;
if ($message->can("signature")) {
my($sts,$msg);
if (!$message->signed) {
$sts = "no signature";
} else {
$sts = $message->signature->status;
$msg = $message->signature->errorstr;
}
dbg("dk: $sts" . (defined $msg ? " ($msg)" : ''));
return $sts;
} else {
return $message->header->value;
}
}
sub _dkmsg_signing_domain {
my ($self, $scan, $message) = @_;
if ($message->can("signature")) {
if (!$message->signed) {
return undef;
}
return $message->signature->domain;
} else {
if ($scan->{msg}->get_header("DomainKey-Signature") =~
/(?: ^|; ) [ \t]* d= [ \t]* ([^;]*?) [ \t]* (?: ;|$ )/x) {
return $1;
}
return undef;
}
}
sub sanitize_header_for_dk {
my ($self, $ref) = @_;
dbg("dk: sanitizing header, no \"h\" tag in signature");
$$ref =~ s/!/!ex;/gs;
$$ref =~ s/\n([ \t])/!nl;$1/gs;
my @hdrs = split(/^/m, $$ref);
while (scalar @hdrs > 0) {
my $last = pop @hdrs;
next if ($last =~ /^\r?$/);
if ($last =~ /^ (?:
X-Spam-\S+
|X-MailScanner(?:-SpamCheck)?
|X-Pyzor |X-DCC-\S{2,25}-Metrics
|X-Bogosity
|X-Evolution
|X-MH-Thread-Markup
|X-Keywords
|(?:X-)?Status |X-Flags |Replied |Forwarded
|Lines |Content-Length
|X-UIDL? |X-IMAPbase
|X-MDaemon-Deliver-To
|X-VM-(?:Bookmark|(?:POP|IMAP)-Retrieved|Labels|Last-Modified
|Summary-Format|VHeader|v\d-Data|Message-Order)
|X-Gnus-Mail-Source
|Xref
):/ix)
{
$last =~ /^([^:]+):/; dbg("dk: ignoring header '$1'");
next;
}
push (@hdrs, $last); last;
}
$$ref = join("", @hdrs);
$$ref =~ s/!nl;/\n/gs;
$$ref =~ s/!ex;/!/gs;
}
sub _check_dk_whitelist {
my ($self, $scan, $default) = @_;
return unless $scan->is_dns_available();
unless ($self->check_domainkeys_verified($scan)) {
unless (would_log("dbg", "dk")) {
return;
}
}
unless ($scan->{dk_address}) {
dbg("dk: ". ($default ? "def_" : "") ."whitelist_from_dk: could not find sender or from address");
return;
}
unless ($scan->{dk_signing_domain}) {
dbg("dk: ". ($default ? "def_" : "") ."whitelist_from_dk: could not find signing domain name");
return;
}
if ($default) {
$scan->{def_dk_whitelist_from_checked} = 1;
$scan->{def_dk_whitelist_from} =
$self->_wlcheck_domain($scan,'def_whitelist_from_dk');
if (!$scan->{def_dk_whitelist_from}) {
$scan->{def_dk_whitelist_from} =
$self->_wlcheck_no_domain($scan,'def_whitelist_auth');
}
} else {
$scan->{dk_whitelist_from_checked} = 1;
$scan->{dk_whitelist_from} =
$self->_wlcheck_domain($scan,'whitelist_from_dk');
if (!$scan->{dk_whitelist_from}) {
$scan->{dk_whitelist_from} =
$self->_wlcheck_no_domain($scan,'whitelist_auth');
}
}
if ($default) {
if ($scan->{def_dk_whitelist_from}) {
if ($self->check_domainkeys_verified($scan)) {
dbg("dk: address: $scan->{dk_address} signing domain name: ".
"$scan->{dk_signing_domain} is in user's DEF_WHITELIST_FROM_DK and ".
"passed DK verification");
} else {
dbg("dk: address: $scan->{dk_address} signing domain name: ".
"$scan->{dk_signing_domain} is in user's DEF_WHITELIST_FROM_DK but ".
"failed DK verification");
$scan->{def_dk_whitelist_from} = 0;
}
} else {
dbg("dk: address: $scan->{dk_address} signing domain name: ".
"$scan->{dk_signing_domain} is not in user's DEF_WHITELIST_FROM_DK");
}
} else {
if ($scan->{dk_whitelist_from}) {
if ($self->check_domainkeys_verified($scan)) {
dbg("dk: address: $scan->{dk_address} signing domain name: ".
"$scan->{dk_signing_domain} is in user's WHITELIST_FROM_DK and ".
"passed DK verification");
} else {
dbg("dk: address: $scan->{dk_address} signing domain name: ".
"$scan->{dk_signing_domain} is in user's WHITELIST_FROM_DK but ".
"failed DK verification");
$scan->{dk_whitelist_from} = 0;
}
} else {
dbg("dk: address: $scan->{dk_address} signing domain name: ".
"$scan->{dk_signing_domain} is not in user's WHITELIST_FROM_DK");
}
}
}
sub _wlcheck_domain {
my ($self, $scan, $wl) = @_;
foreach my $white_addr (keys %{$scan->{conf}->{$wl}}) {
my $re = qr/$scan->{conf}->{$wl}->{$white_addr}{re}/i;
foreach my $domain (@{$scan->{conf}->{$wl}->{$white_addr}{domain}}) {
$self->_wlcheck_one_dom($scan, $wl, $white_addr, $domain, $re) and return 1;
}
}
return 0;
}
sub _wlcheck_one_dom {
my ($self, $scan, $wl, $white_addr, $domain, $re) = @_;
if ($scan->{dk_address} =~ $re) {
if ($scan->{dk_signing_domain} =~ /(?:^|\.)\Q${domain}\E$/i) {
dbg("dk: address: $scan->{dk_address} matches $wl $re $domain");
return 1;
}
}
return 0;
}
sub _wlcheck_no_domain {
my ($self, $scan, $wl) = @_;
foreach my $white_addr (keys %{$scan->{conf}->{$wl}}) {
my $domain = ($white_addr =~ /\@(.*?)$/) ? $1 : $white_addr;
my $re = $scan->{conf}->{$wl}->{$white_addr};
$self->_wlcheck_one_dom($scan, $wl, $white_addr, $domain, $re) and return 1;
}
return 0;
}
1;