Unverified Commit f8dd33c7 authored by IKEDA Soji's avatar IKEDA Soji Committed by GitHub
Browse files

Merge pull request #655 from ikedas/dmarc-subdomain by ikedas

DMARC protection: "p" tag is not applied to subdomains #654
parents 00655023 d911a074
......@@ -3119,273 +3119,270 @@ sub _getCharset {
sub dmarc_protect {
my $self = shift;
# Net::DNS is optional.
return unless $Net::DNS::VERSION;
my $list = $self->{context};
return unless ref $list eq 'Sympa::List';
return
unless $list->{'admin'}{'dmarc_protection'}
and $list->{'admin'}{'dmarc_protection'}{'mode'};
return unless $list->{'admin'}{'dmarc_protection'};
my @modes = @{$list->{'admin'}{'dmarc_protection'}{'mode'} || []};
return unless grep { $_ and $_ ne 'none' } @modes;
$log->syslog('debug', 'DMARC protection on');
my $dkimdomain = $list->{'admin'}{'dmarc_protection'}{'domain_regex'};
my $originalFromHeader = $self->get_header('From');
my $anonaddr;
my $anonphrase;
my @addresses = Mail::Address->parse($originalFromHeader);
my $dkimSignature = $self->get_header('DKIM-Signature');
my $mungeFrom = 0;
my $origFrom;
if (@addresses) {
$origFrom = $addresses[0]->address;
$log->syslog('debug', 'From addresses: %s', $origFrom);
}
my $dkim_signature = $self->get_header('DKIM-Signature');
my $domain_regex = $list->{'admin'}{'dmarc_protection'}{'domain_regex'};
my $original_from = $self->get_header('From');
my ($from) = Mail::Address->parse($original_from);
my $from_address = $from->address if $from;
$log->syslog('debug', 'From address: <%s>', $from_address);
# Will this message be processed?
if (Sympa::Tools::Data::is_in_array(
$list->{'admin'}{'dmarc_protection'}{'mode'}, 'all'
)
) {
if (grep { $_ eq 'all' } @modes) {
$log->syslog('debug', 'Munging From for ALL messages');
$mungeFrom = 1;
}
if ( !$mungeFrom
and $dkimSignature
and Sympa::Tools::Data::is_in_array(
$list->{'admin'}{'dmarc_protection'}{'mode'},
'dkim_signature'
)
} elsif (
$dkim_signature and grep {
$_ eq 'dkim_signature'
} @modes
) {
$log->syslog('debug', 'Munging From for DKIM-signed messages');
$mungeFrom = 1;
}
if ( !$mungeFrom
and $origFrom
and $dkimdomain
and Sympa::Tools::Data::is_in_array(
$list->{'admin'}{'dmarc_protection'}{'mode'},
'domain_regex'
)
} elsif (
$from_address
and $domain_regex
and grep {
$_ eq 'domain_regex'
} @modes
and eval {
$from_address =~ /$domain_regex$/;
}
) {
$log->syslog('debug',
'Munging From for messages based on domain regexp');
$mungeFrom = 1 if ($origFrom =~ /$dkimdomain$/);
}
if ( !$mungeFrom
and $origFrom
and (
Sympa::Tools::Data::is_in_array(
$list->{'admin'}{'dmarc_protection'}{'mode'},
'dmarc_reject')
or Sympa::Tools::Data::is_in_array(
$list->{'admin'}{'dmarc_protection'}{'mode'}, 'dmarc_any')
or Sympa::Tools::Data::is_in_array(
$list->{'admin'}{'dmarc_protection'}{'mode'},
'dmarc_quarantine'
)
)
) {
} elsif ($from_address and $self->_check_dmarc_rr($from_address)) {
$log->syslog('debug', 'Munging From for messages with strict policy');
# Strict auto policy - is the sender domain policy to reject
my $dom = $origFrom;
$dom =~ s/^.*\@//;
my $res = Net::DNS::Resolver->new;
my $packet = $res->query("_dmarc.$dom", "TXT");
if ($packet) {
$log->syslog('debug', 'DMARC DNS entry found');
foreach my $rr (grep { $_->type eq 'TXT' } $packet->answer) {
next if ($rr->string !~ /v=DMARC/);
if (!$mungeFrom
and Sympa::Tools::Data::is_in_array(
$list->{'admin'}{'dmarc_protection'}{'mode'},
'dmarc_reject'
)
) {
$log->syslog('debug', 'Will block if DMARC rejects');
if ($rr->string =~ /p=reject/) {
$log->syslog('debug', 'DMARC reject policy found');
$mungeFrom = 1;
}
}
if (!$mungeFrom
and Sympa::Tools::Data::is_in_array(
$list->{'admin'}{'dmarc_protection'}{'mode'},
'dmarc_quarantine'
)
) {
$log->syslog('debug', 'Will block if DMARC quarantine');
if ($rr->string =~ /p=quarantine/) {
$log->syslog('debug',
'DMARC quarantine policy found');
$mungeFrom = 1;
}
}
if (!$mungeFrom
and Sympa::Tools::Data::is_in_array(
$list->{'admin'}{'dmarc_protection'}{'mode'},
'dmarc_any'
)
) {
$log->syslog('debug',
'Will munge whatever DMARC policy is');
$mungeFrom = 1;
}
$self->add_header(
'X-Original-DMARC-Record',
"domain=$dom; " . $rr->string
);
last;
}
}
} else {
return;
}
if ($mungeFrom) {
$log->syslog('debug', 'Will munge From field');
my $listtype = $self->{listtype} || '';
my $listtype = $self->{listtype} || '';
# Remove any DKIM signatures we find
if ($dkim_signature) {
$self->add_header('X-Original-DKIM-Signature', $dkim_signature);
$self->delete_header('DKIM-Signature');
$self->delete_header('DomainKey-Signature');
$log->syslog('debug',
'Removing previous DKIM and DomainKey signatures');
}
# Remove any DKIM signatures we find
if ($dkimSignature) {
$self->add_header('X-Original-DKIM-Signature', $dkimSignature);
$self->delete_header('DKIM-Signature');
$self->delete_header('DomainKey-Signature');
$log->syslog('debug',
'Removing previous DKIM and DomainKey signatures');
# Identify default new From address
my $phraseMode = $list->{'admin'}{'dmarc_protection'}{'phrase'}
|| 'name_via_list';
my $newName;
my $newComment;
my $anonaddr;
my $anonphrase;
if ($listtype eq 'owner' or $listtype eq 'editor') {
# -request or -editor address
$anonaddr = Sympa::get_address($list, $listtype);
} else {
$anonaddr = $list->{'admin'}{'dmarc_protection'}{'other_email'};
$anonaddr = Sympa::get_address($list)
unless $anonaddr and $anonaddr =~ /\@/;
my @anonFrom = Mail::Address->parse($anonaddr);
if (@anonFrom) {
$anonaddr = $anonFrom[0]->address;
$anonphrase = $anonFrom[0]->phrase;
}
# Identify default new From address
my $phraseMode = $list->{'admin'}{'dmarc_protection'}{'phrase'}
|| 'name_via_list';
my $newName;
my $newComment;
if ($listtype eq 'owner' or $listtype eq 'editor') {
# -request or -editor address
$anonaddr = Sympa::get_address($list, $listtype);
} else {
$anonaddr = $list->{'admin'}{'dmarc_protection'}{'other_email'};
$anonaddr = Sympa::get_address($list)
unless $anonaddr and $anonaddr =~ /\@/;
my @anonFrom = Mail::Address->parse($anonaddr);
if (@anonFrom) {
$anonaddr = $anonFrom[0]->address;
$anonphrase = $anonFrom[0]->phrase;
}
}
$log->syslog('debug', 'Anonymous From: %s', $anonaddr);
if ($from) {
# We should always have a From address in reality, unless the
# message is from a badly-behaved automate.
my $origName =
MIME::EncWords::decode_mimewords($from->phrase,
Charset => 'UTF-8')
if defined $from->phrase;
unless (defined $origName and $origName =~ /\S/) {
# If we dont have a Phrase, should we search the Sympa
# database for the sender to obtain their name that way?
# Might be difficult.
($origName) = split /\@/, $from_address;
}
$log->syslog('debug', 'Anonymous From: %s', $anonaddr);
if (@addresses) {
# We should always have a From address in reality, unless the
# message is from a badly-behaved automate.
my $origName =
MIME::EncWords::decode_mimewords($addresses[0]->phrase,
Charset => 'UTF-8')
if defined $addresses[0]->phrase;
unless (defined $origName and $origName =~ /\S/) {
# If we dont have a Phrase, should we search the Sympa
# database for the sender to obtain their name that way?
# Might be difficult.
($origName) = split /\@/, $origFrom;
}
if ($phraseMode eq 'name_and_email') {
$newName = $origName;
$newComment = $origFrom;
} elsif ($phraseMode eq 'name_email_via_list') {
$newName = $origName;
if ($listtype eq 'owner') {
$newComment = $language->gettext_sprintf(
'%s via Owner Address of %s Mailing List',
$origFrom, $list->{'name'});
} elsif ($listtype eq 'editor') {
$newComment = $language->gettext_sprintf(
'%s via Moderator Address of %s Mailing List',
$origFrom, $list->{'name'});
} else {
$newComment =
$language->gettext_sprintf('%s via %s Mailing List',
$origFrom, $list->{'name'});
}
} elsif ($phraseMode eq 'name_via_list') {
$newName = $origName;
if ($listtype eq 'owner') {
$newComment = $language->gettext_sprintf(
'via Owner Address of %s Mailing List',
$list->{'name'});
} elsif ($listtype eq 'editor') {
$newComment = $language->gettext_sprintf(
'via Moderator Address of %s Mailing List',
$list->{'name'});
} else {
$newComment =
$language->gettext_sprintf('via %s Mailing List',
$list->{'name'});
}
} elsif ($phraseMode eq 'list_for_email') {
if ($listtype eq 'owner') {
$newName = $language->gettext_sprintf(
'Owner Address of %s Mailing List',
$list->{'name'});
} elsif ($listtype eq 'editor') {
$newName = $language->gettext_sprintf(
'Moderator Address of %s Mailing List',
$list->{'name'});
} else {
$newName = $language->gettext_sprintf('%s Mailing List',
$list->{'name'});
}
if ($phraseMode eq 'name_and_email') {
$newName = $origName;
$newComment = $from_address;
} elsif ($phraseMode eq 'name_email_via_list') {
$newName = $origName;
if ($listtype eq 'owner') {
$newComment = $language->gettext_sprintf(
'%s via Owner Address of %s Mailing List',
$from_address, $list->{'name'});
} elsif ($listtype eq 'editor') {
$newComment = $language->gettext_sprintf(
'%s via Moderator Address of %s Mailing List',
$from_address, $list->{'name'});
} else {
$newComment =
$language->gettext_sprintf('on behalf of %s', $origName);
} elsif ($phraseMode eq 'list_for_name') {
if ($listtype eq 'owner') {
$newName = $language->gettext_sprintf(
'Owner Address of %s Mailing List',
$list->{'name'});
} elsif ($listtype eq 'editor') {
$newName = $language->gettext_sprintf(
'Moderator Address of %s Mailing List',
$list->{'name'});
} else {
$newName = $language->gettext_sprintf('%s Mailing List',
$list->{'name'});
}
$language->gettext_sprintf('%s via %s Mailing List',
$from_address, $list->{'name'});
}
} elsif ($phraseMode eq 'name_via_list') {
$newName = $origName;
if ($listtype eq 'owner') {
$newComment = $language->gettext_sprintf(
'via Owner Address of %s Mailing List',
$list->{'name'});
} elsif ($listtype eq 'editor') {
$newComment = $language->gettext_sprintf(
'via Moderator Address of %s Mailing List',
$list->{'name'});
} else {
$newComment =
$language->gettext_sprintf('on behalf of %s', $origFrom);
$language->gettext_sprintf('via %s Mailing List',
$list->{'name'});
}
} elsif ($phraseMode eq 'list_for_email') {
if ($listtype eq 'owner') {
$newName = $language->gettext_sprintf(
'Owner Address of %s Mailing List',
$list->{'name'});
} elsif ($listtype eq 'editor') {
$newName = $language->gettext_sprintf(
'Moderator Address of %s Mailing List',
$list->{'name'});
} else {
$newName = $origName;
$newName = $language->gettext_sprintf('%s Mailing List',
$list->{'name'});
}
$self->add_header('Reply-To', $origFrom)
unless $self->get_header('Reply-To');
}
# If the new From email address has a Phrase component, then
# append it
if (defined $anonphrase and length $anonphrase) {
if (defined $newName and $newName =~ /\S/) {
$newName .= ' ' . $anonphrase;
$newComment =
$language->gettext_sprintf('on behalf of %s', $origName);
} elsif ($phraseMode eq 'list_for_name') {
if ($listtype eq 'owner') {
$newName = $language->gettext_sprintf(
'Owner Address of %s Mailing List',
$list->{'name'});
} elsif ($listtype eq 'editor') {
$newName = $language->gettext_sprintf(
'Moderator Address of %s Mailing List',
$list->{'name'});
} else {
$newName = $anonphrase;
$newName = $language->gettext_sprintf('%s Mailing List',
$list->{'name'});
}
$newComment =
$language->gettext_sprintf('on behalf of %s', $from_address);
} else {
$newName = $origName;
}
$self->add_header('Reply-To', $from_address)
unless $self->get_header('Reply-To');
}
# If the new From email address has a Phrase component, then
# append it
if (defined $anonphrase and length $anonphrase) {
if (defined $newName and $newName =~ /\S/) {
$newName .= ' ' . $anonphrase;
} else {
$newName = $anonphrase;
}
$newName = $language->gettext('Anonymous')
unless defined $newName and $newName =~ /\S/;
$self->add_header('X-Original-From', "$originalFromHeader");
$self->replace_header(
'From',
Sympa::Tools::Text::addrencode(
$anonaddr, $newName,
Conf::lang2charset($language->get_lang), $newComment
)
);
}
$newName = $language->gettext('Anonymous')
unless defined $newName and $newName =~ /\S/;
$self->add_header('X-Original-From', $original_from);
$self->replace_header(
'From',
Sympa::Tools::Text::addrencode(
$anonaddr, $newName,
Conf::lang2charset($language->get_lang), $newComment
)
);
}
# Strict auto policy - is the sender domain policy to reject
sub _check_dmarc_rr {
my $self = shift;
my $email = shift;
# Net::DNS is optional.
unless ($Net::DNS::VERSION) {
$log->syslog('err',
'Unable to get DNS RR. Net::DNS required. Install it first');
return 0;
}
my $domain = $email;
$domain =~ s/\A.*\@//; # strip local part.
my $list = $self->{context};
my $dns = Net::DNS::Resolver->new;
my $rrstr;
my $sp = 0;
while (0 <= index $domain, '.') {
my $packet = $dns->query("_dmarc.$domain", 'TXT');
next unless $packet;
($rrstr) =
map { $_->string }
grep { $_->type eq 'TXT' and $_->string =~ /\Av=DMARC/i }
$packet->answer;
last if $rrstr;
} continue {
$domain =~ s/\A[^.]*[.]//;
$sp = 1;
}
return 0 unless $rrstr; # no valid record found.
my %rr = _parse_dmarc_rr($rrstr);
my $policy = ($sp and $rr{sp}) || $rr{p};
return 0 unless $policy; # no policy found.
$log->syslog('debug', 'DMARC DNS record found: %s', $rrstr);
$self->add_header('X-Original-DMARC-Record', sprintf 'domain=%s; %s',
$domain, $rrstr);
my @modes = @{$list->{'admin'}{'dmarc_protection'}{'mode'} || []};
unless (
(lc $policy eq 'reject' and grep { $_ eq 'dmarc_reject' } @modes)
or (lc $policy eq 'quarantine'
and grep { $_ eq 'dmarc_quarantine' } @modes)
or grep { $_ eq 'dmarc_any' } @modes
) {
$log->syslog('debug', 'No DMARC policy matched');
return 0;
} else {
$log->syslog('debug', 'DMARC policy "%s" matched', $policy);
return 1;
}
}
# Parse DMARC TXT RR.
# Partially borrowed from parse() in Mail::DMARC::Policy by MBRADSHAW@cpan.
sub _parse_dmarc_rr {
my $str = shift;
my $cleaned = $str;
$cleaned =~ s/\s//g; # remove whitespace
$cleaned =~ s/\\;/;/g; # replace \; with ;
$cleaned =~ s/;;/;/g; # replace ;; with ;
$cleaned =~ s/;0;/;/g; # replace ;0; with ;
chop $cleaned if ';' eq substr $cleaned, -1, 1; # remove a trailing ;
my @tag_vals = split /;/, $cleaned;
my %rr;
foreach my $tv (@tag_vals) {
my ($tag, $value) = split /=|:|-/, $tv, 2;
next unless defined $tag and defined $value and length $value;
$rr{lc $tag} = $value;
}
return %rr;
}
# Old name: Sympa::List::compute_topic()
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment