our
@ISA
=
qw(Mail::SpamAssassin::Plugin)
;
my
$IP_ADDRESS
= IP_ADDRESS;
sub
new {
my
$class
=
shift
;
my
$mailsaobject
=
shift
;
$class
=
ref
(
$class
) ||
$class
;
my
$self
=
$class
->SUPER::new(
$mailsaobject
);
bless
(
$self
,
$class
);
$self
->{
'evalrules'
} = [
'check_rbl_accreditor'
,
'check_rbl'
,
'check_rbl_ns_from'
,
'check_rbl_txt'
,
'check_rbl_sub'
,
'check_rbl_from_host'
,
'check_rbl_from_domain'
,
'check_rbl_envfrom'
,
'check_rbl_headers'
,
'check_rbl_rcvd'
,
'check_dns_sender'
,
];
$self
->set_config(
$mailsaobject
->{conf});
foreach
(@{
$self
->{
'evalrules'
}}) {
$self
->register_eval_rule(
$_
,
$Mail::SpamAssassin::Conf::TYPE_RBL_EVALS
);
}
return
$self
;
}
sub
set_config {
my
(
$self
,
$conf
) =
@_
;
my
@cmds
;
push
(
@cmds
, {
setting
=>
'rbl_headers'
,
is_priv
=> 1,
default
=>
'EnvelopeFrom,Reply-To,Disposition-Notification-To,X-WebmailclientIP,X-Source-IP'
,
type
=>
$Mail::SpamAssassin::Conf::CONF_TYPE_STRING
,
}
);
$conf
->{parser}->register_commands(\
@cmds
);
}
sub
check_start {
my
(
$self
,
$opts
) =
@_
;
my
$pms
=
$opts
->{permsgstatus};
foreach
(@{
$self
->{
'evalrules'
}}) {
$pms
->register_plugin_eval_glue(
$_
);
}
$self
->_init_rbl_subs(
$pms
);
}
sub
_init_rbl_subs {
my
(
$self
,
$pms
) =
@_
;
my
$conf
=
$pms
->{conf};
foreach
my
$rule
(@{
$conf
->{eval_to_rule}->{check_rbl_sub}||[]}) {
next
if
!
exists
$conf
->{rbl_evals}->{
$rule
};
next
if
!
$conf
->{scores}->{
$rule
};
my
$args
=
$conf
->{rbl_evals}->{
$rule
}->[1];
my
(
$set
,
$subtest
) =
@$args
;
if
(!
defined
$subtest
) {
warn
(
"dnseval: missing subtest for rule $rule\n"
);
next
;
}
if
(
$subtest
=~ /^sb:/) {
warn
(
"dnseval: ignored $rule, SenderBase rules are deprecated\n"
);
next
;
}
if
(
$subtest
!~ /^\d+(?:\.\d+\.\d+\.\d+)?$/) {
my
(
$rec
,
$err
) = compile_regexp(
$subtest
, 0);
if
(!
$rec
) {
warn
(
"dnseval: invalid rule $rule subtest regexp '$subtest': $err\n"
);
next
;
}
$subtest
=
$rec
;
}
dbg(
"dnseval: initialize check_rbl_sub for rule $rule, set $set, subtest $subtest"
);
push
@{
$pms
->{rbl_subs}{
$set
}}, [
$subtest
,
$rule
];
}
}
sub
parsed_metadata {
my
(
$self
,
$opts
) =
@_
;
my
$pms
=
$opts
->{permsgstatus};
return
1
if
$self
->{main}->{conf}->{skip_rbl_checks};
return
1
if
!
$pms
->is_dns_available();
my
@fullips
=
map
{
$_
->{ip} } @{
$pms
->{relays_untrusted}};
my
@fullexternal
=
map
{
(!
$_
->{internal}) ? (
$_
->{ip}) : ()
} @{
$pms
->{relays_trusted}};
push
@fullexternal
,
@fullips
;
my
@originating
;
foreach
my
$header
(@{
$pms
->{conf}->{originating_ip_headers}}) {
my
$str
=
$pms
->get(
$header
,
undef
);
next
unless
defined
$str
&&
$str
ne
''
;
push
@originating
, (
$str
=~ m/(
$IP_ADDRESS
)/g);
}
my
@ips
=
$self
->ip_list_uniq_and_strip_private(
@fullips
);
if
(
scalar
@ips
+
scalar
@originating
> 0) {
dbg(
"dnseval: IPs found: full-external: "
.
join
(
", "
,
@fullexternal
).
" untrusted: "
.
join
(
", "
,
@ips
).
" originating: "
.
join
(
", "
,
@originating
));
@{
$pms
->{dnseval_fullexternal}} =
@fullexternal
;
@{
$pms
->{dnseval_ips}} =
@ips
;
@{
$pms
->{dnseval_originating}} =
@originating
;
}
return
1;
}
sub
ip_list_uniq_and_strip_private {
my
(
$self
,
@origips
) =
@_
;
my
@ips
;
my
%seen
;
foreach
my
$ip
(
@origips
) {
next
unless
$ip
;
next
if
exists
$seen
{
$ip
};
$seen
{
$ip
} = 1;
next
if
$ip
=~ IS_IP_PRIVATE;
push
(
@ips
,
$ip
);
}
return
@ips
;
}
sub
check_rbl_accreditor {
my
(
$self
,
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
,
$accreditor
) =
@_
;
return
0
if
$self
->{main}->{conf}->{skip_rbl_checks};
return
0
if
!
$pms
->is_dns_available();
if
(!
defined
$pms
->{accreditor_tag}) {
$self
->message_accreditor_tag(
$pms
);
}
if
(
$pms
->{accreditor_tag}->{
$accreditor
}) {
return
$self
->_check_rbl_backend(
$pms
,
$rule
,
$set
,
$rbl_server
,
'A'
,
$subtest
);
}
return
0;
}
sub
message_accreditor_tag {
my
(
$self
,
$pms
) =
@_
;
my
%acctags
;
if
(
$pms
->get(
'EnvelopeFrom:addr'
) =~ /[@.]a--([a-z0-9]{3,})\./i) {
(
my
$tag
= $1) =~
tr
/A-Z/a-z/;
$acctags
{
$tag
} = -1;
}
my
$accreditor_field
=
$pms
->get(
'Accreditor'
,
undef
);
if
(
defined
$accreditor_field
) {
my
@accreditors
=
split
(/,/,
$accreditor_field
);
foreach
my
$accreditor
(
@accreditors
) {
my
@terms
=
split
(
' '
,
$accreditor
);
if
(
$#terms
>= 0) {
my
$tag
=
$terms
[0];
$tag
=~
tr
/A-Z/a-z/;
$acctags
{
$tag
} = -1;
}
}
}
$pms
->{accreditor_tag} = \
%acctags
;
}
sub
_check_rbl_backend {
my
(
$self
,
$pms
,
$rule
,
$set
,
$rbl_server
,
$type
,
$subtest
) =
@_
;
return
if
!
exists
$pms
->{dnseval_ips};
$rbl_server
=~ s/\.+\z//;
dbg(
"dnseval: checking RBL $rbl_server, set $set, rule $rule"
);
my
$trusted
=
$self
->{main}->{conf}->{trusted_networks};
my
@ips
= @{
$pms
->{dnseval_ips}};
if
(
$set
=~ /-(notfirsthop|lastexternal)$/)
{
@ips
=
$self
->ip_list_uniq_and_strip_private(@{
$pms
->{dnseval_fullexternal}});
if
($1 eq
"lastexternal"
) {
@ips
=
defined
$ips
[0] ? (
$ips
[0]) : ();
}
else
{
pop
@ips
if
(
scalar
@ips
> 1);
}
}
elsif
(
$set
=~ /-(first|un)trusted$/)
{
my
@tips
;
foreach
my
$ip
(@{
$pms
->{dnseval_originating}}) {
if
(
$ip
&& !
$trusted
->contains_ip(
$ip
)) {
push
(
@tips
,
$ip
);
}
}
@ips
=
$self
->ip_list_uniq_and_strip_private(
@ips
,
@tips
);
if
($1 eq
"first"
) {
@ips
=
defined
$ips
[0] ? (
$ips
[0]) : ();
}
else
{
shift
@ips
;
}
}
else
{
my
@tips
;
foreach
my
$ip
(@{
$pms
->{dnseval_originating}}) {
if
(
$ip
&& !
$trusted
->contains_ip(
$ip
)) {
push
(
@tips
,
$ip
);
}
}
@ips
=
reverse
$self
->ip_list_uniq_and_strip_private (
@ips
,
@tips
);
}
my
$checklast
=
$self
->{main}->{conf}->{num_check_received};
if
(
scalar
@ips
>
$checklast
) {
splice
(
@ips
,
$checklast
);
}
if
((
$pms
->{conf}->{tflags}->{
$rule
}||
''
) !~ /\bnice\b/) {
while
(
@ips
&&
$trusted
->contains_ip(
$ips
[0])) {
shift
@ips
}
}
unless
(
scalar
@ips
> 0) {
dbg(
"dnseval: no untrusted IPs to check"
);
return
0;
}
dbg(
"dnseval: only inspecting the following IPs: "
.
join
(
", "
,
@ips
));
my
$queries
;
foreach
my
$ip
(
@ips
) {
if
(
defined
(
my
$revip
= reverse_ip_address(
$ip
))) {
my
$ret
=
$pms
->do_rbl_lookup(
$rule
,
$set
,
$type
,
$revip
.
'.'
.
$rbl_server
,
$subtest
);
$queries
++
if
defined
$ret
;
}
}
return
0
if
!
$queries
;
return
;
}
sub
check_rbl {
my
(
$self
,
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
) =
@_
;
return
0
if
$self
->{main}->{conf}->{skip_rbl_checks};
return
0
if
!
$pms
->is_dns_available();
return
$self
->_check_rbl_backend(
$pms
,
$rule
,
$set
,
$rbl_server
,
'A'
,
$subtest
);
}
sub
check_rbl_txt {
my
(
$self
,
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
) =
@_
;
return
0
if
$self
->{main}->{conf}->{skip_rbl_checks};
return
0
if
!
$pms
->is_dns_available();
return
$self
->_check_rbl_backend(
$pms
,
$rule
,
$set
,
$rbl_server
,
'TXT'
,
$subtest
);
}
sub
check_rbl_sub {
my
(
$self
,
$pms
,
$rule
,
$set
,
$subtest
) =
@_
;
return
;
}
sub
check_rbl_from_host {
my
(
$self
,
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
) =
@_
;
return
0
if
$self
->{main}->{conf}->{skip_rbl_checks};
return
0
if
!
$pms
->is_dns_available();
return
$self
->_check_rbl_addresses(
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
,
$pms
->all_from_addrs());
}
sub
check_rbl_headers {
my
(
$self
,
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
,
$test_headers
) =
@_
;
return
0
if
$self
->{main}->{conf}->{skip_rbl_checks};
return
0
if
!
$pms
->is_dns_available();
my
@env_hdr
;
my
$conf
=
$self
->{main}->{conf};
if
(
defined
$test_headers
) {
@env_hdr
=
split
(/,/,
$test_headers
);
}
else
{
@env_hdr
=
split
(/,/,
$conf
->{rbl_headers});
}
my
$queries
;
foreach
my
$rbl_headers
(
@env_hdr
) {
my
$addr
=
$pms
->get(
$rbl_headers
.
':addr'
,
undef
);
if
(
defined
$addr
&&
$addr
=~ /\@([^\@\s]+)/ ) {
my
$ret
=
$self
->_check_rbl_addresses(
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
,
$addr
);
$queries
++
if
defined
$ret
;
}
else
{
my
$unsplitted_host
=
$pms
->get(
$rbl_headers
);
chomp
(
$unsplitted_host
);
foreach
my
$host
(
split
(/\n/,
$unsplitted_host
)) {
if
(
$host
=~ IS_IP_ADDRESS) {
next
if
(
$conf
->{tflags}->{
$rule
}||
''
) =~ /\bdomains_only\b/;
$host
= reverse_ip_address(
$host
);
}
else
{
next
if
(
$conf
->{tflags}->{
$rule
}||
''
) =~ /\bips_only\b/;
next
unless
is_fqdn_valid(
$host
);
next
unless
$pms
->{main}->{registryboundaries}->is_domain_valid(
$host
);
}
my
$ret
=
$pms
->do_rbl_lookup(
$rule
,
$set
,
'A'
,
"$host.$rbl_server"
,
$subtest
);
$queries
++
if
defined
$ret
;
}
}
}
return
0
if
!
$queries
;
return
;
}
sub
check_rbl_from_domain {
my
(
$self
,
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
) =
@_
;
return
0
if
$self
->{main}->{conf}->{skip_rbl_checks};
return
0
if
!
$pms
->is_dns_available();
return
$self
->_check_rbl_addresses(
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
,
$pms
->all_from_addrs_domains());
}
sub
check_rbl_ns_from {
my
(
$self
,
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
) =
@_
;
my
$domain
;
my
@nshost
= ();
return
0
if
$self
->{main}->{conf}->{skip_rbl_checks};
return
0
unless
$pms
->is_dns_available();
dbg(
"dnseval: EnvelopeFrom header not found"
)
unless
defined
((
$pms
->get(
"EnvelopeFrom:addr"
))[0]);
for
my
$from
(
$pms
->get(
'EnvelopeFrom:addr'
)) {
next
unless
defined
$from
;
$from
=~
tr
/././s;
if
(
$from
=~ m/ \@ ( [^\@\s]+ \. [^\@\s]+ )/x ) {
$domain
=
lc
($1);
last
;
}
}
return
0
unless
defined
$domain
;
dbg(
"dnseval: checking NS for host $domain"
);
my
$obj
= {
dom
=>
$domain
,
rule
=>
$rule
,
set
=>
$set
,
rbl_server
=>
$rbl_server
,
subtest
=>
$subtest
};
my
$ent
= {
rulename
=>
$rule
,
zone
=>
$domain
,
obj
=>
$obj
,
type
=>
"URI-NS"
,
};
my
$ret
=
$pms
->{async}->bgsend_and_start_lookup(
$domain
,
'NS'
,
undef
,
$ent
,
sub
{
my
(
$ent2
,
$pkt
) =
@_
;
$self
->complete_ns_lookup(
$pms
,
$ent2
,
$pkt
,
$domain
) },
master_deadline
=>
$pms
->{master_deadline} );
return
0
if
!
defined
$ret
;
return
;
}
sub
complete_ns_lookup {
my
(
$self
,
$pms
,
$ent
,
$pkt
,
$host
) =
@_
;
my
$rule
=
$ent
->{obj}->{rule};
my
$set
=
$ent
->{obj}->{set};
my
$rbl_server
=
$ent
->{obj}->{rbl_server};
my
$subtest
=
$ent
->{obj}->{subtest};
if
(!
$pkt
) {
dbg(
"dnseval: complete_ns_lookup aborted %s"
,
$ent
->{key});
return
;
}
dbg(
"dnseval: complete_ns_lookup %s"
,
$ent
->{key});
my
@ns
=
$pkt
->authority;
foreach
my
$rr
(
@ns
) {
my
$nshost
=
$rr
->mname;
next
unless
defined
$nshost
;
chomp
(
$nshost
);
if
(is_fqdn_valid(
$nshost
)) {
if
(
defined
$subtest
) {
dbg(
"dnseval: checking [$nshost] / $rule / $set / $rbl_server / $subtest"
);
}
else
{
dbg(
"dnseval: checking [$nshost] / $rule / $set / $rbl_server"
);
}
$pms
->do_rbl_lookup(
$rule
,
$set
,
'A'
,
"$nshost.$rbl_server"
,
$subtest
);
}
}
}
sub
check_rbl_rcvd {
my
(
$self
,
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
) =
@_
;
my
%seen
;
my
@udnsrcvd
= ();
return
0
if
$self
->{main}->{conf}->{skip_rbl_checks};
return
0
if
!
$pms
->is_dns_available();
my
$rcvd
=
$pms
->{relays_untrusted}->[
$pms
->{num_relays_untrusted} - 1];
my
@dnsrcvd
= (
$rcvd
->{ip},
$rcvd
->{by},
$rcvd
->{helo},
$rcvd
->{rdns} );
foreach
my
$value
(
@dnsrcvd
) {
if
( (
defined
$value
) && (!
$seen
{
$value
}++ ) ) {
push
@udnsrcvd
,
$value
;
}
}
my
$queries
;
foreach
my
$host
(
@udnsrcvd
) {
if
((
defined
$host
) and (
$host
ne
""
)) {
chomp
(
$host
);
if
(
$host
=~ IS_IP_ADDRESS) {
next
if
(
$pms
->{conf}->{tflags}->{
$rule
}||
''
) =~ /\bdomains_only\b/;
$host
= reverse_ip_address(
$host
);
}
else
{
next
if
(
$pms
->{conf}->{tflags}->{
$rule
}||
''
) =~ /\bips_only\b/;
$host
=~ s/\.$//;
next
unless
is_fqdn_valid(
$host
);
next
unless
$pms
->{main}->{registryboundaries}->is_domain_valid(
$host
);
}
if
(
defined
$subtest
) {
dbg(
"dnseval: checking [$host] / $rule / $set / $rbl_server / $subtest"
);
}
else
{
dbg(
"dnseval: checking [$host] / $rule / $set / $rbl_server"
);
}
my
$ret
=
$pms
->do_rbl_lookup(
$rule
,
$set
,
'A'
,
"$host.$rbl_server"
,
$subtest
);
$queries
++
if
defined
$ret
;
}
}
return
0
if
!
$queries
;
return
;
}
sub
check_rbl_envfrom {
my
(
$self
,
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
) =
@_
;
return
0
if
$self
->{main}->{conf}->{skip_rbl_checks};
return
0
if
!
$pms
->is_dns_available();
return
$self
->_check_rbl_addresses(
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
,
$pms
->get(
'EnvelopeFrom:addr'
,
undef
));
}
sub
_check_rbl_addresses {
my
(
$self
,
$pms
,
$rule
,
$set
,
$rbl_server
,
$subtest
,
@addresses
) =
@_
;
$rbl_server
=~ s/\.+\z//;
my
%hosts
;
for
(
@addresses
) {
next
if
!
defined
(
$_
) || !/\@([^\@\s]+)/;
my
$address
= $1;
$address
=~ s/^\.+//;
$address
=~ s/\.+\z//;
if
(
$address
=~
tr
/.//s) {
$hosts
{
lc
(
$address
)} = 1;
}
}
return
unless
scalar
keys
%hosts
;
my
$queries
;
for
my
$host
(
keys
%hosts
) {
if
(
$host
=~ IS_IP_ADDRESS) {
next
if
(
$pms
->{conf}->{tflags}->{
$rule
}||
''
) =~ /\bdomains_only\b/;
$host
= reverse_ip_address(
$host
);
}
else
{
next
if
(
$pms
->{conf}->{tflags}->{
$rule
}||
''
) =~ /\bips_only\b/;
next
unless
is_fqdn_valid(
$host
);
next
unless
$pms
->{main}->{registryboundaries}->is_domain_valid(
$host
);
}
dbg(
"dnseval: checking [$host] / $rule / $set / $rbl_server"
);
my
$ret
=
$pms
->do_rbl_lookup(
$rule
,
$set
,
'A'
,
"$host.$rbl_server"
,
$subtest
);
$queries
++
if
defined
$ret
;
}
return
0
if
!
$queries
;
return
;
}
sub
check_dns_sender {
my
(
$self
,
$pms
,
$rule
) =
@_
;
return
0
if
$self
->{main}->{conf}->{skip_rbl_checks};
return
0
if
!
$pms
->is_dns_available();
my
$host
;
foreach
my
$from
(
$pms
->get(
'EnvelopeFrom:addr'
,
undef
)) {
next
unless
defined
$from
;
$from
=~
tr
/.//s;
if
(
$from
=~ m/\@([^\@\s]+\.[^\@\s]+)/) {
$host
=
lc
($1);
last
;
}
}
return
0
unless
defined
$host
;
if
(
$host
eq
'compiling.spamassassin.taint.org'
) {
return
0;
}
$host
= idn_to_ascii(
$host
);
dbg(
"dnseval: checking A and MX for host $host"
);
my
$queries
;
my
$ret
=
$self
->do_sender_lookup(
$pms
,
$rule
,
'A'
,
$host
);
$queries
++
if
defined
$ret
;
$ret
=
$self
->do_sender_lookup(
$pms
,
$rule
,
'MX'
,
$host
);
$queries
++
if
defined
$ret
;
return
0
if
!
$queries
;
return
;
}
sub
do_sender_lookup {
my
(
$self
,
$pms
,
$rule
,
$type
,
$host
) =
@_
;
my
$ent
= {
rulename
=>
$rule
,
type
=>
"DNSBL-Sender"
,
};
return
$pms
->{async}->bgsend_and_start_lookup(
$host
,
$type
,
undef
,
$ent
,
sub
{
my
(
$ent
,
$pkt
) =
@_
;
return
if
!
$pkt
;
$pms
->rule_ready(
$ent
->{rulename});
foreach
my
$answer
(
$pkt
->answer) {
next
if
!
$answer
;
next
if
$answer
->type ne
'A'
&&
$answer
->type ne
'MX'
;
if
(
$pkt
->header->rcode eq
'NXDOMAIN'
||
$pkt
->header->rcode eq
'SERVFAIL'
)
{
if
(++
$pms
->{sender_host_fail} == 2) {
$pms
->got_hit(
$ent
->{rulename},
"DNS: "
,
ruletype
=>
"dns"
);
}
}
}
},
master_deadline
=>
$self
->{master_deadline},
);
}
sub
has_tflags_domains_only { 1 }
sub
has_tflags_ips_only { 1 }
1;