# <@LICENSE>
# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements. See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to you under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License. You may obtain a copy of the License at:
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
# </@LICENSE>
=head1 NAME
Mail::SpamAssassin::Plugin::DKIM - perform DKIM verification tests
=head1 SYNOPSIS
loadplugin Mail::SpamAssassin::Plugin::DKIM [/path/to/DKIM.pm]
full DOMAINKEY_DOMAIN eval:check_dkim_verified()
=head1 DESCRIPTION
This SpamAssassin plugin implements DKIM lookups as described by the current
draft specs: draft-ietf-dkim-base-10, as well as DomainKeys lookups, as
described in draft-delany-domainkeys-base-06, thanks to the support for both
types of signatures by newer versions of module Mail::DKIM (0.22 or later).
It requires the C<Mail::DKIM> CPAN module to operate. Many thanks to Jason Long
for that module.
Note that if C<Mail::DKIM> version 0.20 or later is installed, this plugin will
also perform Domain Key lookups on DomainKey-Signature headers.
=head1 SEE ALSO
C<Mail::DKIM>, C<Mail::SpamAssassin::Plugin>
http://jason.long.name/dkimproxy/
=cut
package Mail::SpamAssassin::Plugin::DKIM;
use Mail::SpamAssassin::Plugin;
use Mail::SpamAssassin::Logger;
use Mail::SpamAssassin::Timeout;
use strict;
use warnings;
use bytes;
# Have to do this so that RPM doesn't find these as required perl modules.
BEGIN { require Mail::DKIM; require Mail::DKIM::Verifier; }
use vars qw(@ISA);
@ISA = qw(Mail::SpamAssassin::Plugin);
# constructor: register the eval rule
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_dkim_signed");
$self->register_eval_rule ("check_dkim_verified");
$self->register_eval_rule ("check_dkim_signsome");
$self->register_eval_rule ("check_dkim_testing");
$self->register_eval_rule ("check_dkim_signall");
$self->register_eval_rule ("check_for_dkim_whitelist_from");
$self->register_eval_rule ("check_for_def_dkim_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_dkim add@ress.com [identity]
Use this to supplement the whitelist_from addresses with a check to make sure
the message has been signed by a Domain Keys Identified Mail (DKIM) signature
that can be verified against the From: domain's DKIM public key.
In order to support optional identities, only one whitelist entry is allowed
per line, exactly like C<whitelist_from_rcvd>. Multiple C<whitelist_from_dkim>
lines are allowed. File-glob style meta characters are allowed for the From:
address, just like with C<whitelist_from_rcvd>. The optional identity
parameter must match from the right-most side, also like in
C<whitelist_from_rcvd>.
If no identity 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 an DKIM check to be made, network tests must be
enabled.
Examples:
whitelist_from_dkim joe@example.com
whitelist_from_dkim *@corp.example.com
whitelist_from_dkim jane@example.net example.org
whitelist_from_dkim dick@example.net richard@example.net
=item def_whitelist_from_dkim add@ress.com [identity]
Same as C<whitelist_from_dkim>, 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_dkim',
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 $identity = (defined $2 ? $2 : $1);
unless (defined $2) {
$identity =~ s/^.*(@.*)$/$1/;
}
$self->{parser}->add_to_addrlist_rcvd ('whitelist_from_dkim',
$address, $identity);
}
});
push (@cmds, {
setting => 'def_whitelist_from_dkim',,
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 $identity = (defined $2 ? $2 : $1);
unless (defined $2) {
$identity =~ s/^.*(@.*)$/$1/;
}
$self->{parser}->add_to_addrlist_rcvd ('def_whitelist_from_dkim',
$address, $identity);
}
});
=back
=head1 ADMINISTRATOR SETTINGS
=over 4
=item dkim_timeout n (default: 5)
How many seconds to wait for a DKIM query to complete, before
scanning continues without the DKIM result.
=cut
push (@cmds, {
setting => 'dkim_timeout',
is_admin => 1,
default => 5,
type => $Mail::SpamAssassin::Conf::CONF_TYPE_NUMERIC
});
$conf->{parser}->register_commands(\@cmds);
}
# ---------------------------------------------------------------------------
sub check_dkim_signed {
my ($self, $scan) = @_;
$self->_check_dkim_signature($scan) unless $scan->{dkim_checked_signature};
return $scan->{dkim_signed};
}
sub check_dkim_verified {
my ($self, $scan) = @_;
$self->_check_dkim_signature($scan) unless $scan->{dkim_checked_signature};
return $scan->{dkim_verified};
}
sub check_dkim_signsome {
my ($self, $scan) = @_;
$self->_check_dkim_policy($scan) unless $scan->{dkim_checked_policy};
return $scan->{dkim_signsome};
}
sub check_dkim_signall {
my ($self, $scan) = @_;
$self->_check_dkim_policy($scan) unless $scan->{dkim_checked_policy};
return $scan->{dkim_signall};
}
# public key carries a testing flag, or fetched policy carries a testing flag
sub check_dkim_testing {
my ($self, $scan) = @_;
my $result = 0;
$self->_check_dkim_signature($scan) unless $scan->{dkim_checked_signature};
if ($scan->{dkim_key_testing}) {
$result = 1;
} else {
$self->_check_dkim_policy($scan) unless $scan->{dkim_checked_policy};
$result = 1 if $scan->{dkim_policy_testing};
}
return $result;
}
sub check_for_dkim_whitelist_from {
my ($self, $scanner) = @_;
$self->_check_dkim_whitelist($scanner, 0) unless $scanner->{dkim_whitelist_from_checked};
$scanner->{dkim_whitelist_from};
}
sub check_for_def_dkim_whitelist_from {
my ($self, $scanner) = @_;
$self->_check_dkim_whitelist($scanner, 1) unless $scanner->{def_dkim_whitelist_from_checked};
$scanner->{def_dkim_whitelist_from};
}
# ---------------------------------------------------------------------------
sub _check_dkim_signature {
my ($self, $scan) = @_;
$scan->{dkim_checked_signature} = 1;
$scan->{dkim_signed} = 0;
$scan->{dkim_verified} = 0;
$scan->{dkim_key_testing} = 0;
my $message = Mail::DKIM::Verifier->new_object();
if (!$message) {
dbg("dkim: cannot create Mail::DKIM::Verifier");
return;
}
$scan->{dkim_object} = $message;
# feed content of message into verifier, using \r\n endings,
# required by Mail::DKIM API (see bug 5300)
# note: bug 5179 comment 28: perl does silly things on non-Unix platforms
# unless we use \015\012 instead of \r\n
eval {
foreach my $line (split(/\n/s, $scan->{msg}->get_pristine)) {
$line =~ s/\r?$/\015\012/s; # ensure \015\012 ending
$message->PRINT($line);
}
};
if ($@) { # intercept die() exceptions and render safe
dbg ("dkim: verification failed, intercepted error: $@");
return 0; # cannot verify message
}
my $timeout = $scan->{conf}->{dkim_timeout};
my $timer = Mail::SpamAssassin::Timeout->new({ secs => $timeout });
my $err = $timer->run_and_catch(sub {
dbg("dkim: performing public key lookup and signature verification");
$message->CLOSE(); # the action happens here
$scan->{dkim_address} = ($message->message_originator ? $message->message_originator->address() : '');
dbg("dkim: originator address: ".($scan->{dkim_address} ? $scan->{dkim_address} : 'none'));
$scan->{dkim_identity} = '';
if ($message->signature) {
# i= Identity of the user or agent (e.g., a mailing list manager) on
# behalf of which this message is signed (dkim-quoted-printable;
# OPTIONAL, default is an empty local-part followed by an "@"
# followed by the domain from the "d=" tag).
$scan->{dkim_identity} = $message->signature->identity();
if ($scan->{dkim_identity} eq '') {
$scan->{dkim_identity} = '@' . $message->signature->domain();
}
dbg("dkim: signature identity: ".$scan->{dkim_identity});
}
my $result = $message->result();
my $detail = $message->result_detail();
dbg("dkim: signature verification result: $detail");
# extract the actual lookup results
if ($result eq 'pass') {
$scan->{dkim_signed} = 1;
$scan->{dkim_verified} = 1;
}
elsif ($result eq 'fail') {
$scan->{dkim_signed} = 1;
}
elsif ($result eq 'none') {
# no-op, this is the default state
}
elsif ($result eq 'invalid') {
# Returned if no valid DKIM-Signature headers were found,
# but there is at least one invalid DKIM-Signature header.
dbg("dkim: invalid DKIM-Signature: $detail");
}
});
if ($timer->timed_out()) {
dbg("dkim: public key lookup timed out after $timeout seconds");
} elsif ($err) {
chomp $err;
dbg("dkim: public key lookup failed: $err");
}
}
sub _check_dkim_policy {
my ($self, $scan) = @_;
$scan->{dkim_checked_policy} = 1;
$scan->{dkim_signsome} = 0;
$scan->{dkim_signall} = 0;
$scan->{dkim_policy_testing} = 0;
# must check the message first to obtain signer, domain, and verif. status
$self->_check_dkim_signature($scan) unless $scan->{dkim_checked_signature};
my $message = $scan->{dkim_object};
if (!$message) {
dbg("dkim: policy: dkim object not available (programming error?)");
} elsif (!$scan->is_dns_available()) {
dbg("dkim: policy: not retrieved, no DNS resolving available");
} elsif ($scan->{dkim_verified}) { # no need to fetch policy when verifies
# draft-allman-dkim-ssp-02: If the message contains a valid Originator
# Signature, no Sender Signing Practices check need be performed:
# the Verifier SHOULD NOT look up the Sender Signing Practices
# and the message SHOULD be considered non-Suspicious.
dbg("dkim: policy: not retrieved, signature does verify");
} else {
my $timeout = $scan->{conf}->{dkim_timeout};
my $timer = Mail::SpamAssassin::Timeout->new({ secs => $timeout });
my $err = $timer->run_and_catch(sub {
dbg("dkim: policy: performing lookup");
my $policy;
eval { $policy = $message->fetch_author_policy };
if ($@ ne '') {
# fetching or parsing a policy may throw an error, ignore such policy
chomp($@); dbg("dkim: policy: fetch or parse failed: $@");
undef $policy;
}
if (!$policy) {
dbg("dkim: policy: none");
} else {
my $policy_result = $policy->apply($message);
dbg("dkim: policy result $policy_result: ".$policy->as_string());
# extract the flags we expose, from the policy
my $pol_o = $policy->policy();
if ($pol_o eq '~') {
$scan->{dkim_signsome} = 1;
}
elsif ($pol_o eq '-') {
$scan->{dkim_signall} = 1;
}
if ($policy->testing()) {
$scan->{dkim_policy_testing} = 1;
}
}
});
if ($timer->timed_out()) {
dbg("dkim: lookup timed out after $timeout seconds");
} elsif ($err) {
chomp $err;
dbg("dkim: lookup failed: $err");
}
}
}
sub _check_dkim_whitelist {
my ($self, $scanner, $default) = @_;
return unless $scanner->is_dns_available();
# trigger a DKIM check so we can get address/identity info,
# if verification failed only continue if we want the debug info
unless ($self->check_dkim_verified($scanner)) {
unless (would_log("dbg", "dkim")) {
return;
}
}
unless ($scanner->{dkim_address}) {
dbg("dkim: ". ($default ? "def_" : "") ."whitelist_from_dkim: could not find originator address");
return;
}
unless ($scanner->{dkim_identity}) {
dbg("dkim: ". ($default ? "def_" : "") ."whitelist_from_dkim: could not find identity");
return;
}
if ($default) {
$scanner->{def_dkim_whitelist_from_checked} = 1;
$scanner->{def_dkim_whitelist_from} =
$self->_wlcheck_domain($scanner,'def_whitelist_from_dkim');
if (!$scanner->{def_dkim_whitelist_from}) {
$scanner->{def_dkim_whitelist_from} =
$self->_wlcheck_no_domain($scanner,'def_whitelist_auth');
}
} else {
$scanner->{dkim_whitelist_from_checked} = 1;
$scanner->{dkim_whitelist_from} =
$self->_wlcheck_domain($scanner,'whitelist_from_dkim');
if (!$scanner->{dkim_whitelist_from}) {
$scanner->{dkim_whitelist_from} =
$self->_wlcheck_no_domain($scanner,'whitelist_auth');
}
}
# if the message doesn't pass DKIM validation, it can't pass an DKIM whitelist
if ($default) {
if ($scanner->{def_dkim_whitelist_from}) {
if ($self->check_dkim_verified($scanner)) {
dbg("dkim: address: $scanner->{dkim_address} identity: ".
"$scanner->{dkim_identity} is in user's DEF_WHITELIST_FROM_DKIM and ".
"passed DKIM verification");
} else {
dbg("dkim: address: $scanner->{dkim_address} identity: ".
"$scanner->{dkim_identity} is in user's DEF_WHITELIST_FROM_DKIM but ".
"failed DKIM verification");
$scanner->{def_dkim_whitelist_from} = 0;
}
} else {
dbg("dkim: address: $scanner->{dkim_address} identity: ".
"$scanner->{dkim_identity} is not in user's DEF_WHITELIST_FROM_DKIM");
}
} else {
if ($scanner->{dkim_whitelist_from}) {
if ($self->check_dkim_verified($scanner)) {
dbg("dkim: address: $scanner->{dkim_address} identity: ".
"$scanner->{dkim_identity} is in user's WHITELIST_FROM_DKIM and ".
"passed DKIM verification");
} else {
dbg("dkim: address: $scanner->{dkim_address} identity: ".
"$scanner->{dkim_identity} is in user's WHITELIST_FROM_DKIM but ".
"failed DKIM verification");
$scanner->{dkim_whitelist_from} = 0;
}
} else {
dbg("dkim: address: $scanner->{dkim_address} identity: ".
"$scanner->{dkim_identity} is not in user's WHITELIST_FROM_DKIM");
}
}
}
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->{dkim_address} =~ $re) {
if ($scan->{dkim_identity} =~ /(?:^|\.|(?:@(?!@)|(?=@)))\Q${domain}\E$/i)
{
dbg("dkim: address: $scan->{dkim_address} matches $wl $re $domain");
return 1;
}
}
return 0;
}
# use a traditional whitelist_from-style addrlist, and infer the
# domain from each address on the fly. Note: don't pre-parse and
# store the domains; that's inefficient memory-wise and only saves 1 m//
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;
syntax highlighted by Code2HTML, v. 0.9.1