File: //usr/share/perl5/vendor_perl/Amavis/DKIM.pm
package Amavis::DKIM;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
$VERSION = '2.412';
@ISA = qw(Exporter);
@EXPORT_OK = qw(&dkim_key_postprocess &generate_authentication_results
&dkim_make_signatures &adjust_score_by_signer_reputation
&collect_some_dkim_info);
}
use subs @EXPORT_OK;
use IO::File ();
use Crypt::OpenSSL::RSA ();
use MIME::Base64;
use Net::DNS::Resolver;
use Mail::DKIM::Verifier 0.31;
use Mail::DKIM::Signer 0.31;
use Mail::DKIM::TextWrap;
use Mail::DKIM::Signature;
use Mail::DKIM::DkSignature;
use Amavis::Conf qw(:platform c cr ca $myproduct_name
%dkim_signing_keys_by_domain
@dkim_signing_keys_list @dkim_signing_keys_storage);
use Amavis::DKIM::CustomSigner;
use Amavis::IO::RW;
use Amavis::Lookup qw(lookup lookup2);
use Amavis::rfc2821_2822_Tools qw(split_address quote_rfc2821_local
qquote_rfc2821_local);
use Amavis::Timing qw(section_time);
use Amavis::Util qw(min max minmax untaint ll do_log unique_list
format_time_interval get_deadline
idn_to_ascii mail_addr_idn_to_ascii idn_to_utf8
safe_encode_utf8 proto_encode proto_decode);
# Convert private keys (as strings in PEM format) into RSA objects
# and do some pre-processing on @dkim_signing_keys_list entries
# (may run unprivileged)
#
sub dkim_key_postprocess() {
# convert private keys (as strings in PEM format) into RSA objects
for my $ks (@dkim_signing_keys_storage) {
my($pkcs1,$dev,$inode,$fname) = @$ks;
if (ref $pkcs1 && UNIVERSAL::isa($pkcs1,'Crypt::OpenSSL::RSA')) {
# it is already a Crypt::OpenSSL::RSA object
} else {
# assume a string is a private key in PEM format, convert it to RSA obj
$ks->[0] = $pkcs1 = Crypt::OpenSSL::RSA->new_private_key($pkcs1);
}
my $key_size = 8 * $pkcs1->size;
my $minimum_key_bits = c('dkim_minimum_key_bits');
if ($key_size < 1024) {
do_log(0,"NOTE: DKIM %d-bit signing key is shorter than ".
"a recommended RFC 6376 minimum of %d bits, file: %s",
$key_size, 1024, $fname);
} elsif ($minimum_key_bits && $key_size < $minimum_key_bits) {
do_log(0,"INFO: DKIM %d-bit signing key is shorter than ".
"a configured \$dkim_minimum_key_bits of %d bits, file: %s",
$key_size, $minimum_key_bits, $fname);
}
}
for my $ent (@dkim_signing_keys_list) {
my $domain = $ent->{domain};
$dkim_signing_keys_by_domain{$domain} = []
if !$dkim_signing_keys_by_domain{$domain};
}
my $any_wild; my $j = 0;
for my $ent (@dkim_signing_keys_list) {
$ent->{v} = 'DKIM1' if !defined $ent->{v}; # provide a default
if (defined $ent->{n}) { # encode n as qp-section (RFC 6376, RFC 2047)
$ent->{n} =~ s{([\000-\037\177=;"])}{sprintf('=%02X',ord($1))}gse;
}
my $domain = $ent->{domain};
if (exists $ent->{g}) {
do_log(0,"INFO: the 'g' tag is historic (RFC 6376), signers are ".
"advised not to include a 'g' tag in key records: ".
"s=%s d=%s g=%s", $ent->{selector}, $domain, $ent->{g});
}
if (ref($domain) eq 'Regexp') {
$ent->{domain_re} = $domain;
$any_wild = sprintf("key#%d, %s", $j+1, $domain) if !defined $any_wild;
} elsif ($domain =~ /\*/) {
# wildcarded signing domain in a key declaration, evil, asks for trouble!
# support wildcards in signing domain for compatibility with dkim_milter
my $regexp = $domain;
$regexp =~ s/\*{2,}/*/gs; # collapse successive wildcards
# '*' is a wildcard, quote the rest
$regexp =~ s{ ([@\#/.^\$|*+?(){}\[\]\\]) }
{ $1 eq '*' ? '.*' : '\\'.$1 }xgse;
$regexp = '^' . $regexp . '\\z'; # implicit anchors
$regexp =~ s/^\^\.\*//s; # remove leading anchor if redundant
$regexp =~ s/\.\*\\z\z//s; # remove trailing anchor if redundant
$regexp = '(?:)' if $regexp eq ''; # just in case, non-empty regexp
# presence of {'domain_re'} entry lets get_dkim_key use this regexp
# instead of a direct string comparison with {'domain'}
$ent->{domain_re} = qr{$regexp}; # compiled regexp object
$any_wild = sprintf("key#%d, %s", $j+1, $domain) if !defined $any_wild;
}
# %dkim_signing_keys_by_domain entries contain lists of indices into
# the @dkim_signing_keys_list of all potentially applicable signing keys.
# This hash (keyed by domain name) avoids linear searching for signing
# keys for all fully-specified domains in @dkim_signing_keys_list.
# Wildcarded entries must still be looked up sequentially at run-time
# to preserve the declared order and the 'first match wins' paradigm.
# Such entries are only supported for compatibility with dkim_milter
# and are evil because amavisd has no quick way of verifying that DNS RR
# really exists, so signatures generated by amavisd can fail when not all
# possible DNS resource records exist for wildcarded signing domains.
#
if (!defined($ent->{domain_re})) { # no regexp, just plain match on domain
push(@{$dkim_signing_keys_by_domain{$domain}}, $j);
} else { # a wildcard in a signing domain, compatibility with dkim_milter
# wildcarded signing domain potentially matches any _by_domain entry
for my $d (keys %dkim_signing_keys_by_domain) {
push(@{$dkim_signing_keys_by_domain{$d}}, $j);
}
# the '*' entry collects only wildcarded signing keys
$dkim_signing_keys_by_domain{'*'} = []
if !$dkim_signing_keys_by_domain{'*'};
push(@{$dkim_signing_keys_by_domain{'*'}}, $j);
}
$j++;
}
do_log(0,"dkim: wildcard in signing domain (%s), may produce unverifiable ".
"signatures with no published public key, avoid!", $any_wild)
if $any_wild;
}
# Fetch a private DKIM signing key for a given signing domain, with its
# resource-record (RR) constraints compatible with proposed signature options.
# The first such key is returned as a hash; if no key is found an empty hash
# is returned. When a selector (s) is given it must match the selector of
# a key; when algorithm (a) is given, the key type and a hash algorithm must
# match the desired use too; the service type (s) must be 'email' or '*';
# when identity (i) is given it must match the granularity (g) of a key.
# RFC 6376: the "g=" tag has been deprecated in this version of the DKIM
# specification (and thus MUST now be ignored), signers are advised not to
# include the "g=" tag in key records.
#
# sign.opts. key options
# ---------- -----------
# d => domain
# s => selector
# a => k, h(list)
# i => g, t=s
#
sub get_dkim_key(@) {
@_ % 2 == 0 or die "get_dkim_key: a list of pairs is expected as query opts";
my(%options) = @_; # signature options (v, a, c, d, h, i, l, q, s, t, x, z),
# of which d is required, while s, a and t are optional but taken into
# account in searching for a compatible key - the rest are ignored
my(%key_options);
my $domain = $options{d}; my $selector = $options{s};
defined $domain && $domain ne ''
or die "get_dkim_key: domain is required, but tag 'd' is missing";
$domain = idn_to_ascii($domain);
$selector = idn_to_ascii($selector) if defined $selector;
my(@indices) = $dkim_signing_keys_by_domain{$domain} ?
@{$dkim_signing_keys_by_domain{$domain}} :
$dkim_signing_keys_by_domain{'*'} ?
@{$dkim_signing_keys_by_domain{'*'}} : ();
if (@indices) {
$selector = $selector eq '' ? undef : lc($selector) if defined $selector;
local($1,$2);
my($keytype,$hashalg) =
defined $options{a} && $options{a} =~ /^([a-z0-9]+)-(.*)\z/is ? ($1,$2)
: ('rsa',undef);
my($identity_localpart,$identity_domain) =
!defined($options{i}) ? () : split_address($options{i});
$identity_localpart = '' if !defined $identity_localpart;
$identity_domain = '' if !defined $identity_domain;
$identity_domain =
idn_to_ascii($identity_domain) if $identity_domain ne '';
# find the first key (associated with a domain) with compatible options
for my $j (@indices) {
my $ent = $dkim_signing_keys_list[$j];
next unless defined $ent->{domain_re} ? $domain =~ $ent->{domain_re}
: $domain eq $ent->{domain};
next if defined $selector && $ent->{selector} ne $selector;
next if $keytype ne (exists $ent->{k} ? $ent->{k} : 'rsa');
next if exists $ent->{s} &&
!(grep($_ eq '*' || $_ eq 'email', split(/:/, $ent->{s})) );
next if defined $hashalg && exists $ent->{'h'} &&
!(grep($_ eq $hashalg, split(/:/, $ent->{'h'})) );
if (defined($options{i})) {
if ($identity_domain eq $domain) {
# ok
} elsif (exists $ent->{t} && (grep($_ eq 's', split(/:/,$ent->{t})))) {
next; # no subdomains allowed
}
# the 'g' tag is now historic, RFC 6376
if (!exists($ent->{g}) || $ent->{g} eq '*') {
# ok
} elsif ($ent->{g} =~ /^ ([^*]*) \* (.*) \z/xs) {
next if $identity_localpart !~ /^ \Q$1\E .* \Q$2\E \z/xs;
} else {
next if $identity_localpart ne $ent->{g};
}
}
%key_options = %$ent; last; # found a suitable match
}
}
if (defined $key_options{key_storage_ind}) {
# obtain actual key from @dkim_signing_keys_storage
($key_options{key}) =
@{$dkim_signing_keys_storage[$key_options{key_storage_ind}]};
}
%key_options;
}
# send a query to a signing service, collect its response and parse it;
# the protocol is much like the AM.PDP protocol, except that attributes
# are different
#
sub query_signing_service($$) {
my($server, $query) = @_;
my($remaining_time, $deadline) = get_deadline('query_signing_service');
my $sock = Amavis::IO::RW->new($server, Eol => "\015\012", Timeout => 10);
$sock or die "Error connecting to a signing server $server: $!";
my $req_id = sprintf("%08x", rand(0x7fffffff));
my $req_id_attr = proto_encode('request_id', $req_id);
$sock->print(join('', map($_."\015\012", (@$query, $req_id_attr, ''))))
or die "Error sending a query to a signing server";
ll(5) && do_log(5, "dkim: query_signing_service, query: %s",
join('; ', @$query, $req_id_attr));
$sock->flush or die "Error flushing signing server session";
# collect a reply
$sock->timeout(max(2, $deadline - Time::HiRes::time));
my(%attr,$ln); local($1,$2);
while (defined($ln = $sock->get_response_line)) {
last if $ln eq "\015\012"; # end of a response block
if ($ln =~ /^ ([^=\000\012]*?) = ([^\012]*?) \015\012 \z/xsi) {
$attr{proto_decode($1)} = proto_decode($2);
}
}
$sock->close or die "Error closing session to a signing server $server: $!";
ll(5) && do_log(5, "dkim: query_signing_service, got: %s",
join('; ', map($_.'='.$attr{$_}, keys %attr)));
$attr{request_id} eq $req_id
or die "Answer id '$attr{request_id}' from $server ".
"does not match the query id '$req_id'";
\%attr;
}
# send candidate originator addresses and signature options to a signing
# service and let it choose a selector 's' and a domain 'd', thus uniquely
# identifying a signing key
#
sub let_signing_service_choose($$$$) {
my($server, $msginfo, $sender_search_list_ref, $sig_opt_prelim) = @_;
my(@query) = (
proto_encode('request', 'choose_key'),
proto_encode('log_id', $msginfo->log_id),
);
# provide some additional information potentially useful in decision-making
if ($sig_opt_prelim) {
for my $opt (sort keys %$sig_opt_prelim) {
push(@query, proto_encode('sig.'.$opt, $sig_opt_prelim->{$opt}));
}
}
push(@query, proto_encode('sender', $msginfo->sender_smtp));
for my $r (@{$msginfo->per_recip_data}) {
push(@query, proto_encode('recip', $r->recip_addr_smtp));
}
for my $pair (!$sender_search_list_ref ? () : @$sender_search_list_ref) {
my($addr,$addr_src) = @$pair;
push(@query, proto_encode('candidate', $addr_src,
qquote_rfc2821_local($addr)));
}
my $attr;
eval {
$attr = query_signing_service($server,\@query); 1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
do_log(0, "query_signing_service failed: %s", $eval_stat);
};
my(%sig_options, $chosen_addr_src, $chosen_addr);
if ($attr) {
for my $opt (keys %$attr) {
if ($opt =~ /^sig\.(.+)\z/) {
$sig_options{$1} = $attr->{$opt} if !exists($sig_options{$1});
}
}
if (defined $attr->{chosen_candidate}) {
($chosen_addr_src, $chosen_addr) =
split(' ', $attr->{chosen_candidate}, 2);
}
}
(!$attr ? undef : \%sig_options, $chosen_addr_src, $chosen_addr);
}
# a CustomSigner callback routine passed to Mail::DKIM in place of a key;
# the routine will be called by Mail::DKIM::Algorithm::*rsa_sha* routines
# instead of calling their own Mail::DKIM::PrivateKey::sign_digest()
#
sub remote_signer {
my($digest_alg_name, $digest, %args) = @_;
# $digest: header digest (binary), ready for signing,
# e.g. $algorithm->{header_digest}->digest
my $server = $args{Server}; # our own info passed back to us
my $msginfo = $args{MsgInfo}; # our own info passed back to us
my(@query) = (
proto_encode('request', 'sign'),
proto_encode('digest_alg', $digest_alg_name),
proto_encode('digest', encode_base64($digest,'')),
proto_encode('s', $args{Selector}),
proto_encode('d', $args{Domain}),
proto_encode('log_id', $msginfo->log_id),
);
my($attr, $b, $reason);
eval {
$attr = query_signing_service($server, \@query); 1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
$reason = $eval_stat;
};
if ($attr) { $b = $attr->{b}; $reason = $attr->{reason} }
if (!defined($b) || $b eq '') {
$reason = 'no signature from a signing server' if !defined $reason;
# die "Can't sign, $reason, query: " . join('; ',@query) . "\n";
do_log(0, "dkim: can't sign, %s, query: %s", $reason, join('; ',@query));
return ''; # Mail::DKIM::Algorithm::rsa_sha256 doesn't like undef
}
decode_base64($b); # resulting signature
}
# prepare requested DKIM signatures for a provided message,
# returning them as a list of Mail::DKIM::Signature objects
#
sub dkim_make_signatures($$;$) {
my($msginfo,$initial_submission,$callback) = @_;
my(@signatures); # resulting signature objects
my(%sig_options); # signature options and constraints for choosing a key
my(%key_options); # options associated with a signing key, IDN as ACE
my(@tried_domains); # used for logging a failure
my($chosen_addr,$chosen_addr_src); my $do_sign = 0;
my $fm = $msginfo->rfc2822_from; # authors
my(@rfc2822_from) = !defined($fm) ? () : ref $fm ? @$fm : $fm;
my $allowed_hdrs = cr('allowed_added_header_fields');
my $from_str = join(', ', qquote_rfc2821_local(@rfc2822_from)); # logging
substr($from_str,100) = '[...]' if length($from_str) > 100;
if (!$allowed_hdrs || !$allowed_hdrs->{lc('DKIM-Signature')}) {
do_log(5, "dkim: inserting a DKIM-Signature header field disabled");
} elsif (!$msginfo->originating) {
do_log(5, "dkim: not signing mail which is not originating from our site");
} elsif ($msginfo->is_in_contents_category(CC_VIRUS)) {
do_log(2, "dkim: not signing infected mail (from inside), From: %s",
$from_str);
} elsif ($msginfo->is_in_contents_category(CC_SPAM)) {
# it is prudent not to sign outgoing spam, otherwise an attacker may be
# able to replay a signed message, re-sending it to other recipients
# in bulk directly from botnets
do_log(2, "dkim: not signing spam (from inside), From: %s", $from_str);
} elsif ($msginfo->is_in_contents_category(CC_SPAMMY)) {
do_log(2, "dkim: not signing suspected spam (from inside), From: %s",
$from_str);
} else {
# Choose a signing key based on the first match on the following
# addresses (in this order): 2822.From, followed by 2822.Resent-From and
# 2822.Resent-Sender address pairs traversed top-down by resent blocks,
# followed by 2822.Sender and 2821.mail_from. We choose to look up
# a From first, as it generates an author domain signature, but the
# search order on remaining entries is admittedly unusual.
# Btw, dkim-milter uses the following search order:
# Resent-Sender, Resent-From, Sender, From.
# Only a signature based on 2822.From is considered an author domain
# signature, others are just third-party signatures and have no more
# merit than any other third-party signature according to RFC 6376.
#
my $rf = $msginfo->rfc2822_resent_from;
my $rs = $msginfo->rfc2822_resent_sender;
my(@rfc2822_resent_from, @rfc2822_resent_sender);
@rfc2822_resent_from = @$rf if defined $rf;
@rfc2822_resent_sender = @$rs if defined $rs;
my(@search_list); # collects candidate addresses for choosing a signing key
# author addresses go first (typically exactly one, but possibly more)
push(@search_list, map([$_,'From'], @rfc2822_from));
# merge Resent-From and Resent-Sender addresses by resent blocks, top-down;
# a merge is simplified by the fact that there is an equal number of
# resent blocks in @rfc2822_resent_from and @rfc2822_resent_sender lists
while (@rfc2822_resent_from || @rfc2822_resent_sender) {
# for each resent block
while (@rfc2822_resent_from) {
my $addr = shift(@rfc2822_resent_from);
last if !defined $addr; # undef delimits resent blocks
push(@search_list, [$addr, 'Resent-From']);
}
while (@rfc2822_resent_sender) {
my $addr = shift(@rfc2822_resent_sender);
last if !defined $addr; # undef delimits resent blocks
push(@search_list, [$addr, 'Resent-Sender']);
}
}
push(@search_list, [$msginfo->rfc2822_sender, 'Sender']);
push(@search_list, [$msginfo->sender, 'mail_from']);
{ # remove duplicates and empty addresses
my(%addr_seen);
@search_list =
grep { my($a,$src) = @$_; defined $a && $a ne '' && !$addr_seen{$a}++ }
@search_list;
}
ll(2) && do_log(2, "dkim: candidate originators: %s",
join(", ", map($_->[1].':'.qquote_rfc2821_local($_->[0]),
@search_list)));
# dkim_signwith_sd() may provide a ref to a pair [selector,domain] - if
# available (e.g. by a custom hook), it will force signing with a private
# key associated with this selector and domain, otherwise we fall back
# to consulting an external service if available, or else we use our
# built-in algorithm for choosing a selector & domain and their associated
# signing key
#
my $sd_pair = $msginfo->dkim_signwith_sd;
if (ref($sd_pair) eq 'ARRAY') {
my($s,$d) = @$sd_pair;
if (defined $s && $s ne '' && defined $d && $d ne '') {
do_log(5, "dkim: dkim_signwith_sd presets d=%s, s=%s", $d,$s);
$sig_options{s} = $s; $sig_options{d} = $d;
}
}
my $dkim_signing_service = c('dkim_signing_service');
if (defined $dkim_signing_service && $dkim_signing_service ne '') {
# try the signing service: it should provide an 's' and 'd' if it has
# a suitable signing key available, and/or may supply signing options,
# overriding the defaults set so far
my $sig_opt_ref;
($sig_opt_ref, $chosen_addr_src, $chosen_addr) =
let_signing_service_choose($dkim_signing_service,
$msginfo, \@search_list, undef);
if ($sig_opt_ref) { # merge returned signature options with ours
while (my($k,$v) = each(%$sig_opt_ref)) {
$sig_options{$k} = $v if defined $v;
}
}
}
my $sobm = ca('dkim_signature_options_bysender_maps');
# last resort: fall back to our local configuration settings
for my $pair (@search_list) {
my($addr,$addr_src) = @$pair;
my($addr_localpart,$addr_domain) = split_address($addr);
# fetch a list of hashes from all entries matching the address
my($dkim_options_ref,$mk_ref);
($dkim_options_ref,$mk_ref) = lookup2(1,$addr,$sobm) if $sobm && @$sobm;
$dkim_options_ref = [] if !defined $dkim_options_ref;
# signature options (parenthesized options are set automatically;
# the RFC 6651 (failure reporting) added a tag: r=y) :
# (v), a, (b), (bh), c, d, (h), i, (l), q, r, s, (t), x, (z)
# place a catchall default at the end of the list of options;
push(@$dkim_options_ref, { c => 'relaxed/simple', a => 'rsa-sha256' });
# start each iteration with the same set of options collected so far
my(%tmp_sig_options) = %sig_options;
# traverse list of hashes from specific to general, first match wins
for my $opts_hash_ref (@$dkim_options_ref) {
next if ref $opts_hash_ref ne 'HASH'; # just in case
while (my($k,$v) = each(%$opts_hash_ref)) { # for each entry in a hash
$tmp_sig_options{$k} = $v if !exists $tmp_sig_options{$k};
}
}
# a default for a signing domain is a domain of each tried address
if (!exists($tmp_sig_options{d})) {
my $d = $addr_domain; $d =~ s/^\@//; $tmp_sig_options{d} = $d;
}
push(@tried_domains, $tmp_sig_options{d});
ll(5) && do_log(5, "dkim: signature options for %s(%s): %s",
$addr, $addr_src,
join('; ', map($_.'='.$tmp_sig_options{$_},
keys %tmp_sig_options)));
# find a private key associated with a signing domain and selector,
# and meeting constraints
%key_options = get_dkim_key(%tmp_sig_options)
if defined $tmp_sig_options{d} && $tmp_sig_options{d} ne '';
# my(@domain_path); # host.sub.example.com sub.example.com example.com com
# $addr_domain =~ s/^\@//; $addr_domain =~ s/\.\z//;
# if ($addr_domain !~ /\[/) { # don't split address literals
# for (my $d=$addr_domain; $d ne ''; $d =~ s/^[^.]*(?:\.|\z)//s)
# { push(@domain_path,$d) }
# }
# for my $d (@domain_path) {
# $tmp_sig_options{d} = $d;
# %key_options = get_dkim_key(%tmp_sig_options);
# last if defined $key_options{key};
# }
my $key = $key_options{key};
if (defined $key && $key ne '') { # found; copy the key and its options
$tmp_sig_options{key} = $key;
$tmp_sig_options{s} = idn_to_utf8($key_options{selector});
$chosen_addr = $addr; $chosen_addr_src = $addr_src;
# merge the just collected signature options into the final set
while (my($k,$v) = each(%tmp_sig_options)) {
$sig_options{$k} = $v if defined $v;
}
last;
}
}
# provide defaults for 'c' and 'a' tags if missing
$sig_options{c} = 'relaxed/simple' if !exists $sig_options{c};
$sig_options{a} = 'rsa-sha256' if !exists $sig_options{a};
# prepare for a second stage of using an external signing service:
# when we do have a 's' and 'd', thus uniquely identifying a signing key,
# but do not have a key ourselves, we'll provide a callback routine
# in place of a key object so that Mail::DKIM will call it at the time
# of signing, and our routine will consult a remote signing service
#
if (!defined $sig_options{key} &&
defined $dkim_signing_service && $dkim_signing_service ne '' &&
defined $sig_options{d} && $sig_options{d} ne '' &&
defined $sig_options{s} && $sig_options{s} ne '') {
my $s = $sig_options{s}; my $d = $sig_options{d};
# let Mail::DKIM use our custom code for signing (pref. 0.38 or later)
$key_options{key} = Amavis::DKIM::CustomSigner->new(
CustomSigner => \&remote_signer, MsgInfo => $msginfo,
Selector => idn_to_ascii($s),
Domain => idn_to_ascii($d),
Server => $dkim_signing_service);
$key_options{selector} = $s; $key_options{domain} = $d;
$sig_options{key} = $key_options{key};
}
my $sig_opt_d_ace = idn_to_ascii($sig_options{d});
if (!defined $sig_opt_d_ace || $sig_opt_d_ace eq '') {
do_log(2, "dkim: not signing, empty signing domain, From: %s",$from_str);
} elsif (!defined $sig_options{key} || $sig_options{key} eq '') {
do_log(2, "dkim: not signing, no applicable private key for domains %s,".
" s=%s, From: %s",
join(", ",@tried_domains), $sig_options{s}, $from_str);
} else {
# copy key's options to signature options for convenience
for (keys %key_options) {
$sig_options{'KEY.'.$_} = $key_options{$_} if /^[ghknst]\z/;
}
$sig_options{'KEY.key_ind'} = $key_options{key_ind};
# check matching of identity to a signing domain or provide a default;
# presence of a t=s flag in a public key RR prohibits subdomains in i
my $key_allows_subdomains =
grep($_ eq 's', split(/:/,$sig_options{'KEY.t'})) ? 0 : 1;
if (defined $sig_options{i}) { # explicitly given, possibly empty
# have mercy: provide a leading '@' if missing
$sig_options{i} = '@'.$sig_options{i} if $sig_options{i} ne '' &&
$sig_options{i} !~ /\@/;
} elsif (!$key_allows_subdomains) {
# we have no other choice but to keep it at its default @d
} else { # the public key record permits subdomains
# provide default for i in a form of a sender's domain
local($1);
if ($chosen_addr =~ /\@([^\@]*)\z/) {
my $identity_domain = $1;
if (idn_to_ascii($identity_domain) =~ /.\.\Q$sig_opt_d_ace\E\z/s) {
$sig_options{i} = '@'.$identity_domain;
do_log(5, "dkim: identity defaults to %s", $sig_options{i});
}
}
}
if (!defined $sig_options{i} || $sig_options{i} eq '') {
$do_sign = 1; # just sign, don't bother with i
} else { # check if the requested i is compatible with d
local($1);
my $identity_domain = $sig_options{i} =~ /\@([^\@]*)\z/ ? $1 : '';
my $identity_domain_ace = idn_to_ascii($identity_domain);
if (!$key_allows_subdomains && $identity_domain_ace ne $sig_opt_d_ace){
do_log(2, "dkim: not signing, identity domain %s not the same as ".
"a signing domain %s, flags t=%s, From: %s",
$sig_options{i}, $sig_options{d}, $sig_options{'KEY.t'},
$from_str);
} elsif ($key_allows_subdomains &&
$identity_domain_ace !~ /(?:^|\.)\Q$sig_opt_d_ace\E\z/i) {
do_log(2, "dkim: not signing, identity %s not a subdomain of %s, ".
"From: %s", $sig_options{i}, $sig_options{d}, $from_str);
} else {
$do_sign = 1;
}
}
}
}
my $sig_opt_d_ace = idn_to_ascii($sig_options{d});
if ($do_sign) { # avoid adding same signature on multiple passes through MTA
my $sigs_ref = $msginfo->dkim_signatures_valid;
if ($sigs_ref) {
for my $sig (@$sigs_ref) {
if ( idn_to_ascii($sig->domain) eq $sig_opt_d_ace &&
(!defined $sig_options{i} || $sig_options{i} eq $sig->identity)) {
do_log(2, "dkim: not signing, already signed by domain %s, ".
"From: %s", $sig_opt_d_ace, $from_str);
$do_sign = 0;
}
}
}
}
if ($do_sign) {
# relative expiration time
if (defined $sig_options{ttl} && $sig_options{ttl} > 0) {
my $xt = $msginfo->rx_time + $sig_options{ttl};
$sig_options{x} = int($xt) + ($xt > int($xt) ? 1 : 0); # ceiling
}
# remove redundant options with RFC 6376 -default values
for my $k (keys %sig_options) { delete $sig_options{$k} if !defined $k }
delete $sig_options{i} if $sig_options{i} =~ /^\@/ &&
idn_to_ascii($sig_options{i}) eq '@'.$sig_opt_d_ace;
delete $sig_options{c} if $sig_options{c} eq 'simple/simple' ||
$sig_options{c} eq 'simple';
delete $sig_options{q} if $sig_options{q} eq 'dns/txt';
if (ref $callback eq 'CODE') { &$callback($msginfo,\%sig_options) }
if (ll(2)) {
my $opts = join(', ',map($_ eq 'key' ? ()
: ($_ . '=>' . safe_encode_utf8($sig_options{$_})),
sort keys %sig_options));
do_log(2,"dkim: signing (%s), From: %s (%s:%s), %s",
grep(/\@\Q$sig_opt_d_ace\E\z/si,
map(mail_addr_idn_to_ascii($_), @rfc2822_from))
? 'author' : '3rd-party',
$from_str, $chosen_addr_src, qquote_rfc2821_local($chosen_addr),
$opts);
}
my $key = $sig_options{key};
if (UNIVERSAL::isa($key,'Crypt::OpenSSL::RSA')) {
# my $pkcs1 = $key->get_private_key_string; # most compact
# $pkcs1 =~ s/^---.*?---(?:\r?\n|\z)//gm; $pkcs1 =~ tr/\r\n//d;
# $key = Mail::DKIM::PrivateKey->load(Data => $pkcs1);
$key = Mail::DKIM::PrivateKey->load(Cork => $key); # avail since 0.31
} elsif (ref $key) {
# already a Mail::DKIM::PrivateKey or Amavis::DKIM::CustomSigner object
} else {
$key = Mail::DKIM::PrivateKey->load(File => $key); # read from a file
}
# Sendmail milter interface does not provide a just-generated Received
# header field to milters. Milters therefore need to fabricate a pseudo
# Received header field in order to provide client IP address to a filter.
# Unfortunately it is not possible to reliably fabricate a header field
# which will exactly match the later-inserted one, so we must not sign
# it to avoid a likely possibility of a signature being invalidated.
my $conn = $msginfo->conn_obj;
my $appl_proto = !$conn ? undef : $conn->appl_proto;
my $skip_topmost_received = defined($appl_proto) &&
($appl_proto eq 'AM.PDP' || $appl_proto eq 'AM.CL');
my $policyfn = sub {
my $dkim = $_[0];
my $signed_header_fields_ref = cr('signed_header_fields') || {};
my $hfn = $dkim->{header_field_names};
my(@field_names_to_be_signed);
#
# when $signed_header_fields_ref->{$nm} is greater than 1 it indicates
# that one surplus occurrence of a header filed name in an 'h' tag
# should be inserted, consequently prohibiting further instances of
# such header field to be added to a message header section without
# breaking a signature; useful for example for a From and Subject
#
if ($hfn) {
my(%hfn_cnt);
$hfn_cnt{lc $_}++ for @$hfn;
for (@$hfn) {
my $nm = lc($_);
push(@field_names_to_be_signed, $nm); $hfn_cnt{$nm}--;
if (!$hfn_cnt{$nm} && $signed_header_fields_ref->{$nm} > 1) {
# causes signing one additional null occurrence of a header field
push(@field_names_to_be_signed, $nm);
}
}
}
@field_names_to_be_signed =
grep($signed_header_fields_ref->{$_}, @field_names_to_be_signed);
if ($skip_topmost_received) { # don't sign topmost Received header field
for my $j (0..$#field_names_to_be_signed) {
if (lc($field_names_to_be_signed[$j]) eq 'received')
{ splice(@field_names_to_be_signed,$j,1); last }
}
}
my $expiration;
if (defined $sig_options{x}) {
$expiration = $sig_options{x};
my $j = int($expiration);
$expiration = $expiration > $j ? $j+1 : $j; # ceiling
}
# RFC 6531 section 3.2: Any domain name to be looked up in the DNS
# MUST conform to and be processed as specified for Internationalizing
# Domain Names in Applications (IDNA) [RFC5890]. When doing lookups,
# the SMTPUTF8-aware SMTP client or server MUST either use a Unicode-
# aware DNS library, or transform the internationalized domain name
# to A-label form (i.e., a fully- qualified domain name that contains
# one or more A-labels but no U-labels) as specified in RFC 5890.
$dkim->add_signature( Mail::DKIM::Signature->new(
Selector => idn_to_ascii($sig_options{s}),
Domain => idn_to_ascii($sig_options{d}),
Timestamp => int($msginfo->rx_time), # floor
Headers => join(':', reverse @field_names_to_be_signed),
Key => $key,
!defined $sig_options{c} ? () : (Method => $sig_options{c}),
!defined $sig_options{a} ? () : (Algorithm => $sig_options{a}),
!defined $sig_options{q} ? () : (Query => $sig_options{q}),
!defined $sig_options{i} ? () : (Identity =>
mail_addr_idn_to_ascii($sig_options{i})),
!defined $expiration ? () : (Expiration => $expiration), # ceiling
));
undef;
}; # end sub
my $dkim_wrapper;
eval {
my $dkim_signer = Mail::DKIM::Signer->new(Policy => $policyfn);
$dkim_signer or die "Could not create a Mail::DKIM::Signer object\n";
#
# NOTE: dkim wrapper will strip bare CR before signing, which suits
# forwarding by SMTP which does the same; with other forwarding methods
# such as a pipe or milter, bare CRs in a message may break signatures
#
# feeding mail to a DKIM signer
require Amavis::Out::SMTP;
$dkim_wrapper = Amavis::Out::SMTP->new_dkim_wrapper($dkim_signer,1);
my $msg = $msginfo->mail_text; # a file handle or a MIME::Entity object
my $msg_str_ref = $msginfo->mail_text_str; # have an in-memory copy?
$msg = $msg_str_ref if ref $msg_str_ref;
my $hdr_edits = $msginfo->header_edits;
$hdr_edits = Amavis::Out::EditHeader->new if !$hdr_edits;
my($received_cnt,$file_position) =
$hdr_edits->write_header($msginfo,$dkim_wrapper,!$initial_submission);
if (!defined $msg) {
# empty mail
} elsif (ref $msg eq 'SCALAR') {
# do it in chunks, saves memory, cache friendly
while ($file_position < length($$msg)) {
$dkim_wrapper->print(substr($$msg,$file_position,16384))
or die "Can't write to dkim signer: $!";
$file_position += 16384; # may overshoot, no problem
}
} elsif ($msg->isa('MIME::Entity')) {
$msg->print_body($dkim_wrapper);
} else {
my($nbytes,$buff);
while (($nbytes = $msg->read($buff,16384)) > 0) {
$dkim_wrapper->print($buff) or die "Can't write to dkim signer: $!";
}
defined $nbytes or die "Error reading: $!";
}
$dkim_wrapper->close or die "Can't close dkim wrapper: $!";
undef $dkim_wrapper;
$dkim_signer->CLOSE or die "Can't close dkim signer: $!";
@signatures = $dkim_signer->signatures;
undef $dkim_signer;
1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
do_log(0, "dkim: signing error: %s", $eval_stat);
};
if (defined $dkim_wrapper) { $dkim_wrapper->close } # ignoring status
section_time('fwd-data-dkim');
}
# signatures must have all the required tags: d, s, b, bh; check to make sure
# if (ll(5)) { do_log(5, "dkim: %s", $_->as_string) for @signatures }
my(@sane_signatures);
for my $s (@signatures) {
my(@missing);
for my $pair ( ['d', $s->domain], ['s', $s->selector],
['b', $s->data], ['bh', $s->body_hash] ) {
my($tag,$val) = @$pair;
push(@missing,$tag) if !defined($val) || $val eq '';
}
if (!@missing) {
push(@sane_signatures, $s);
# remember just the last one (typically the only one)
$msginfo->dkim_signwith_sd( [$s->selector, $s->domain] );
} else {
do_log(2, "dkim: signature is missing tag %s, skipping: %s",
join(',',@missing), $s->as_string);
}
}
@sane_signatures;
}
# Prepare Authentication-Results header fields according to RFC 7601.
#
sub generate_authentication_results($;$$) {
my($msginfo,$allow_none,$sigs_ref) = @_;
$sigs_ref = $msginfo->dkim_signatures_all if @_ < 3; # for all by default
my $authservid = c('myauthservid');
$authservid = c('myhostname') if !defined $authservid || $authservid eq '';
$authservid = idn_to_ascii($authservid);
# note that RFC 7601 declares A-R header field as structured, which is why
# we are inserting a \n into top-level locations suitable for folding,
# and let sub hdr() choose suitable folding points
my(@results, %all_b, %all_b_valid, %all_b_8);
my($sig_cnt_dk, $sig_cnt_dkim, $result_str) = (0, 0, '');
for my $sig (!$sigs_ref ? () : @$sigs_ref) { # first pass
my($sig_result, $details, $str);
$sig_result = $sig->result;
if (defined $sig_result) {
$sig_result = lc $sig_result;
} else {
($sig_result, $details) = ('pass', 'just generated, assumed good');
$sig->result($sig_result, $details);
}
my $valid = $sig_result eq 'pass';
if ($valid) {
my $expiration_time = $sig->expiration;
if (defined $expiration_time &&
$expiration_time =~ /^0*\d{1,10}\z/ &&
$msginfo->rx_time > $expiration_time) {
($sig_result, $details) = ('fail', 'good, but expired');
$sig->result($sig_result, $details);
$valid = 0;
}
}
if ($sig->isa('Mail::DKIM::DkSignature')) { $sig_cnt_dk++ }
else { $sig_cnt_dkim++ };
my $b = $sig->data;
if (defined $b) {
$b =~ tr/ \t\n//d; # remove FWS, just in case
$all_b_8{substr($b,0,8)}++;
$all_b{$b}++;
$all_b_valid{$b}++ if $valid;
}
}
# RFC 7601 result: none, pass, fail, policy, neutral, temperror, permerror
# Mail::DKIM result: pass, fail, invalid, temperror, none
for my $sig (!$sigs_ref ? () : @$sigs_ref) { # second pass
my $result_val; # RFC 7601 result value
my $sig_result = lc $sig->result;
my $details = $sig->result_detail;
my $valid = $sig_result eq 'pass';
if ($valid) {
$result_val = 'pass';
} else {
# map a Mail::DKIM::Signature result into an RFC 7601 result value
$result_val = $sig_result eq 'temperror' ? 'temperror'
: $sig_result eq 'fail' ? 'fail'
: $sig_result eq 'invalid' ? 'neutral' : 'permerror';
}
my $sdid_ace = idn_to_ascii($sig->domain);
my $str = '';
my $add_header_b; # RFC 6008, should we add a header.b for this signature?
my $key_size = eval {
my $pk = $sig->get_public_key;
$pk && $pk->cork && $pk->cork->size * 8;
};
if ($sig->isa('Mail::DKIM::DkSignature')) {
$add_header_b = 1 if $sig_cnt_dk > 1;
my $rfc2822_sender = $msginfo->rfc2822_sender;
my $fm = $msginfo->rfc2822_from;
my(@rfc2822_from) = !defined($fm) ? () : ref $fm ? @$fm : $fm;
my $id_ace = defined $sdid_ace ? '@'.$sdid_ace : '';
$str .= ";\n domainkeys=" . $result_val;
$str .= sprintf(' (%d-bit key)', $key_size) if $key_size;
if (defined $details && $details ne '' && lc $details ne lc $result_val){
local($1); # turn it into an RFC 2045 quoted-string
$details =~ s{([\000-\037\177"\\])}{\\$1}gs; # RFC 5322 qtext
$str .= "\n reason=\"$details\"";
}
if (@rfc2822_from && $rfc2822_from[0] =~ /(\@[^\@]*)\z/s &&
idn_to_ascii($1) eq $id_ace) {
$str .= "\n header.from=" .
join(',', map(quote_rfc2821_local($_), @rfc2822_from));
}
if (defined($rfc2822_sender) && $rfc2822_sender =~ /(\@[^\@]*)\z/s &&
idn_to_ascii($1) eq $id_ace) {
$str .= "\n header.sender=" . quote_rfc2821_local($rfc2822_sender);
}
} else { # a DKIM signature
$add_header_b = 1 if $sig_cnt_dkim > 1;
$str .= ";\n dkim=" . $result_val;
$str .= sprintf(' (%d-bit key)', $key_size) if $key_size;
if (defined $details && $details ne '' && lc $details ne lc $result_val){
local($1); # turn it into an RFC 2045 quoted-string
$details =~ s{([\000-\037\177"\\])}{\\$1}gs; # RFC 5322 qtext
$str .= "\n reason=\"$details\"";
}
}
$str .= "\n header.d=" . $sdid_ace if defined $sdid_ace;
my $b = $sig->data;
if (defined $b && $add_header_b) {
# RFC 6008: The value associated with this item in the header field
# MUST be at least the first eight characters of the digital signature
# (the "b=" tag from a DKIM-Signature) for which a result is being
# relayed, and MUST be long enough to be unique among the results
# being reported.
$b =~ tr/ \t\n//d; # remove FWS, just in case
if ($b !~ m{^ [A-Za-z0-9+/]+ =* \z}xs) { # ensure base64 syntax
do_log(2, "generate_AR: bad signature tag b=%s", $b);
} elsif ($all_b{$b} > 1 && $all_b_valid{$b} && !$valid) {
# exact duplicates: do not report invalid ones if at least one is valid
# RFC 6008 section 6.2.: a cautious implementation could discard
# the false negative in that instance.
do_log(2, "generate_AR: not reporting bad duplicates: %s", $b);
$str = ''; # ditch the report for this signature
} elsif ($all_b_8{$b} > $all_b{$b}) {
do_log(2, "generate_AR: not reporting b for collisions: %s", $b);
} else {
$str .= "\n header.b=" . '"'.substr($b,0,8) .'"';
}
}
$result_str .= $str;
}
# just provide a single A-R with all results combined
push(@results, $result_str) if $result_str ne '';
push(@results, ";\n dkim=none") if !@results && $allow_none;
$_ = sprintf("%s (%s)%s", $authservid, $myproduct_name, $_) for @results;
@results; # none, one, or more A-R header field bodies
}
# adjust spam score for each recipient so that the final spam score
# will be shifted towards a fixed score assigned to a signing domain (its
# 'reputation', as obtained through @signer_reputation_maps); the formula is:
# adjusted_spam_score = f*reputation + (1-f)*spam_score; 0 <= f <= 1
# which has the same semantics as auto_whitelist_factor in SpamAssassin AWL
#
sub adjust_score_by_signer_reputation($) {
my $msginfo = $_[0];
my $reputation_factor = c('reputation_factor');
$reputation_factor = 0 if $reputation_factor < 0;
$reputation_factor = 1 if $reputation_factor > 1;
my $sigs_ref = $msginfo->dkim_signatures_valid;
if (defined $reputation_factor && $reputation_factor > 0 &&
$sigs_ref && @$sigs_ref) {
my($best_reputation_signer,$best_reputation_score);
my $minimum_key_bits = c('dkim_minimum_key_bits');
my $srm = ca('signer_reputation_maps');
# walk through all valid signatures, find best (smallest) reputation value
for my $sig (@$sigs_ref) {
my $sdid = $sig->domain;
my($val,$key) = lookup2(0, '@'.$sdid, $srm);
if (defined $val &&
(!defined $best_reputation_score || $val < $best_reputation_score)) {
my $key_size;
$key_size = eval {
my $pk = $sig->get_public_key;
$pk && $pk->cork && $pk->cork->size * 8 } if $minimum_key_bits;
if ($key_size && $key_size < $minimum_key_bits) {
do_log(1, "dkim: reputation for signing domain %s not used, ".
"valid signature ignored, %d-bit key is shorter than %d",
$sdid, $key_size, $minimum_key_bits);
} else {
$best_reputation_signer = $sdid;
$best_reputation_score = $val;
}
}
}
if (defined $best_reputation_score) {
my $ll = 2; # initial log level
for my $r (@{$msginfo->per_recip_data}) {
my $spam_level = $r->spam_level;
next if !defined $spam_level;
my $new_level = $reputation_factor * $best_reputation_score
+ (1-$reputation_factor) * $spam_level;
$r->spam_level($new_level);
my $spam_tests = 'AM.DKIM_REPUT=' .
(0+sprintf("%.3f", $new_level-$spam_level));
if (!$r->spam_tests) {
$r->spam_tests([ \$spam_tests ]);
} else {
unshift(@{$r->spam_tests}, \$spam_tests);
}
ll($ll) &&
do_log($ll, "dkim: score %.3f adjusted to %.3f due to reputation ".
"(%s) of a signer domain %s", $spam_level, $new_level,
$best_reputation_score, $best_reputation_signer);
$ll = 5; # reduce log clutter after the first recipient
}
}
}
}
# check if we have a valid author domain signature, and do
# other DKIM pre-processing; called from collect_some_dkim()
#
sub collect_some_dkim_info($) {
my $msginfo = $_[0];
my $rfc2822_sender = $msginfo->rfc2822_sender;
my(@rfc2822_from) = $msginfo->rfc2822_from;
# now that we have a parsed From, check if we have a valid
# author domain signature and do other DKIM pre-processing
my(@bank_names, %bn_auth_already_queried);
my $atpbm = ca('author_to_policy_bank_maps');
my(@signatures_valid);
my $sigs_ref = $msginfo->dkim_signatures_all;
my $sig_ind = 0; # index of a signature in a signature array
for my $sig (!$sigs_ref ? () : @$sigs_ref) { # for each signature
my $valid = lc($sig->result) eq 'pass';
my($timestamp_age, $creation_time, $expiration_time);
if (!$sig->isa('Mail::DKIM::DkSignature')) {
$creation_time = $sig->timestamp; # method only implemented for DKIM sig
$timestamp_age = $msginfo->rx_time - $creation_time
if defined $creation_time && $creation_time =~ /^0*\d{1,10}\z/;
}
$expiration_time = $sig->expiration;
my $expired =
defined $expiration_time && $expiration_time =~ /^0*\d{1,10}\z/ &&
($msginfo->rx_time > $expiration_time ||
( defined $creation_time && $creation_time =~ /^0*\d{1,10}\z/ &&
$creation_time > $expiration_time )
);
my($pubkey, $key_size, $eval_stat);
eval {
# Mail::DKIM >=0.31 caches a public key result
$pubkey = $sig->get_public_key; # can die with "not available"
$pubkey or die "No public key";
$key_size = $pubkey->cork && $pubkey->cork->size * 8;
$key_size or die "Can't determine a public key size";
1;
} or do {
$eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
do_log(5, "dkim: public key s=%s d=%s, error: %s",
$sig->selector, $sig->domain, $eval_stat);
};
if ($pubkey && ll(5)) {
# RFC 6376: Although the "g=" tag has been deprecated in this version
# of the DKIM specification (and thus MUST now be ignored), signers are
# advised not to include the "g=" tag in key records...
do_log(5, "dkim: public key s=%s d=%s%s, %d-bit key",
$sig->selector, $sig->domain,
join('', map { my $v = $pubkey->get_tag($_);
defined $v ? " $_=$v" : '' } qw(v g h k t s)),
$key_size||0 );
}
# See if a signature matches address in any of the sender/author fields.
# In the absence of an explicit Sender header field, the first author
# acts as the 'agent responsible for the transmission of the message'.
my(@addr_list) = ($msginfo->sender,
defined $rfc2822_sender ? $rfc2822_sender : $rfc2822_from[0],
@rfc2822_from);
my $sdid_ace = idn_to_ascii($sig->domain);
for my $addr (@addr_list) {
next if !defined $addr;
local($1); my $domain;
$domain = $1 if $addr =~ /\@([^\@]*)\z/s;
# turn addresses in @addr_list into booleans, representing match outcome
$addr = defined $domain && idn_to_ascii($domain) eq $sdid_ace ? 1 : 0;
}
# # Label which header fields are covered by each signature;
# # doesn't work for old DomainKeys signatures where h may be missing
# # and where recurring header fields may only be listed once.
# # NOTE: currently unused and commented out
# { my(%field_counts);
# my(@signed_header_field_names) = map(lc($_), $sig->headerlist); # 'h' tag
# $field_counts{$_}++ for @signed_header_field_names;
# for (my $j=-1; ; $j--) { # walk through header fields, bottom-up
# my($f_ind,$fld) = $msginfo->get_header_field2(undef,$j);
# last if !defined $f_ind; # reached the top
# local $1;
# my $f_name; $f_name = lc $1 if $fld =~ /^([^:]*?)[ \t]*:/s;
# if ($field_counts{$f_name} > 0) { # header field is covered by this sig
# $msginfo->header_field_signed_by($f_ind,$sig_ind); # store sig index
# $field_counts{$f_name}--;
# }
# }
# }
if ($valid && !$expired) {
push(@signatures_valid, $sig);
my $sig_domain = $sig->domain;
$sig_domain = '?' if !$sig_domain; # make sure it is true as a boolean
#
# note that only the author domain signature (based on RFC 2822.From)
# is a valid concept in ADSP; we are also using the same rules to match
# against RFC 2822.Sender and envelope sender address, but results are
# only of informational/curiosity interest and deeper significance
# must not be attributed to dkim_envsender_sig and dkim_sender_sig!
#
$msginfo->dkim_envsender_sig($sig_domain) if $addr_list[0];
$msginfo->dkim_sender_sig($sig_domain) if $addr_list[1];
$msginfo->dkim_author_sig($sig_domain)
if grep($_, @addr_list[2..$#addr_list]); # SDID matches addr
$msginfo->dkim_thirdparty_sig($sig_domain) if !$msginfo->dkim_author_sig;
if (@$atpbm) { # any author to policy bank name mappings?
for my $j (0..$#rfc2822_from) { # for each author (usually only one)
my $key_ace = mail_addr_idn_to_ascii($rfc2822_from[$j]);
# query key: as-is author address for author domain signatures, and
# author address with '/@signer-domain' appended for 3rd party sign.
# e.g.: 'user@example.com', 'user@sub.example.com/@example.org'
my $sdid_ace = idn_to_ascii($sig->domain);
for my $opt ( ($addr_list[$j+2] ? '' : ()), '/@'.$sdid_ace ) {
next if $bn_auth_already_queried{$key_ace.$opt};
my($result,$matchingkey) = lookup2(0,$key_ace,$atpbm,
Label=>'AuthToPB', $opt eq '' ? () : (AppendStr=>$opt));
$bn_auth_already_queried{$key_ace.$opt} = 1;
next if !$result;
if ($result eq '1') {
# a handy usability trick to supply a hardwired policy bank
# name when acl-style lookup table is used, which can only
# return a boolean (undef, 0, or 1)
$result = 'AUTHOR_APPROVED';
}
my $minimum_key_bits = c('dkim_minimum_key_bits');
# $result is a list of bank names as a comma-separated string
local $1;
my(@pbn) = map(/^\s*(\S.*?)\s*\z/s ? $1 : (), split(/,/, $result));
if (!@pbn) {
# no policy banks specified, nothing to do
} elsif ($key_size && $minimum_key_bits &&
$key_size < $minimum_key_bits) {
do_log(1, "dkim: policy bank %s by %s NOT LOADED, valid ".
"signature ignored, %d-bit key is shorter than %d",
join(',',@pbn), $matchingkey,
$key_size, $minimum_key_bits);
} else {
push(@bank_names, @pbn);
ll(2) && do_log(2, "dkim: policy bank %s by %s",
join(',',@pbn), $matchingkey);
}
}
}
}
}
ll(2) && do_log(2, "dkim: %s%s%s %s signature by d=%s, From: %s, ".
"a=%s, c=%s, s=%s, i=%s%s%s%s",
$valid ? 'VALID' : 'FAILED', $expired ? ', EXPIRED' : '',
$timestamp_age >= -1 ? ''
: ', IN_FUTURE:('.format_time_interval(-$timestamp_age).')',
join('+', (map($_ ? 'Author' : (), @addr_list[2..$#addr_list])),
$addr_list[1] ? 'Sender' : (),
$addr_list[0] ? 'MailFrom' : (),
!grep($_, @addr_list) ? 'third-party' : ()),
$sig->domain, join(", ", qquote_rfc2821_local(@rfc2822_from)),
$sig->algorithm, scalar($sig->canonicalization),
$sig->selector, $sig->identity,
!$msginfo->originating ? ''
: ', ORIG [' . $msginfo->client_addr . ']:' . $msginfo->client_port,
!defined($msginfo->is_mlist) ? '' : ", m.list(".$msginfo->is_mlist.")",
$valid ? '' : ', '.$sig->result_detail,
);
$sig_ind++;
}
Amavis::load_policy_bank($_,$msginfo) for @bank_names;
$msginfo->originating(c('originating'));
$msginfo->dkim_signatures_valid(\@signatures_valid) if @signatures_valid;
# if (ll(5) && $sig_ind > 0) {
# # show which header fields are covered by which signature
# for (my $j=0; ; $j++) {
# my($f_ind,$fld) = $msginfo->get_header_field2(undef,$j);
# last if !defined $f_ind;
# my(@sig_ind) = $msginfo->header_field_signed_by($f_ind);
# do_log(5, "dkim: %-5s %s.", !@sig_ind ? '' : '['.join(',',@sig_ind).']',
# substr($fld,0,54));
# }
# }
}
1;