Email-Abuse-Investigator
view release on metacpan or search on metacpan
_domain_whois _raw_whois _rdap_lookup )) {
no strict 'refs';
$_ORIG{$m} = \&{ "Email::Abuse::Investigator::$m" };
}
}
sub restore_net {
no warnings 'redefine';
for my $m (keys %_ORIG) {
no strict 'refs';
*{ "Email::Abuse::Investigator::$m" } = $_ORIG{$m};
}
}
# =============================================================================
# new()
# =============================================================================
subtest 'new() — constructor API' => sub {
my $a = Email::Abuse::Investigator->new();
ok defined $a, 'new() returns a value';
ok blessed($a), 'return value is blessed';
is blessed($a), 'Email::Abuse::Investigator', 'blessed into correct class';
is $a->{timeout}, 10, 'default timeout is 10';
is $a->{verbose}, 0, 'default verbose is 0';
is_deeply $a->{trusted_relays}, [], 'default trusted_relays is []';
my $b = Email::Abuse::Investigator->new(
timeout => 30,
verbose => 1,
trusted_relays => ['62.105.128.0/24', '91.198.174.5'],
);
is $b->{timeout}, 30, 'custom timeout stored';
is $b->{verbose}, 1, 'custom verbose stored';
is_deeply $b->{trusted_relays},
['62.105.128.0/24', '91.198.174.5'],
'custom trusted_relays stored';
};
# =============================================================================
# parse_email( $text )
# =============================================================================
subtest 'parse_email() — accepts scalar and scalar-ref; returns $self' => sub {
my $raw = make_email();
my $a = Email::Abuse::Investigator->new();
my $ret = $a->parse_email($raw);
is $ret, $a, 'parse_email returns $self (scalar input)';
my $b = Email::Abuse::Investigator->new();
my $ret2 = $b->parse_email(\$raw);
is $ret2, $b, 'parse_email returns $self (scalar-ref input)';
is_deeply $b->{_headers}, $a->{_headers},
'scalar and scalar-ref inputs produce same result';
};
subtest 'parse_email() — handles multipart, quoted-printable, base64 bodies' => sub {
my $qp_body = "Caf=C3=A9 au lait";
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(ct => 'text/plain', cte => 'quoted-printable',
body => $qp_body));
like $a->{_body_plain}, qr/Caf/, 'QP body decoded';
my $b64_body = encode_base64("Base64 encoded content here");
my $b = Email::Abuse::Investigator->new();
$b->parse_email(make_email(ct => 'text/plain', cte => 'base64',
body => $b64_body));
like $b->{_body_plain}, qr/Base64 encoded content/, 'base64 body decoded';
my $bnd = 'UNIT_BOUNDARY';
my $mp = "--$bnd\r\nContent-Type: text/plain\r\n\r\nplain text here\r\n"
. "--$bnd\r\nContent-Type: text/html\r\n\r\n<b>html here</b>\r\n"
. "--$bnd--\r\n";
my $c = Email::Abuse::Investigator->new();
$c->parse_email(make_email(
ct => qq{multipart/alternative; boundary="$bnd"},
body => $mp,
));
like $c->{_body_plain}, qr/plain text here/, 'multipart plain part decoded';
like $c->{_body_html}, qr/html here/, 'multipart html part decoded';
};
subtest 'parse_email() — re-parse resets all lazy caches' => sub {
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email());
$a->{_origin} = { ip => '0.0.0.0' };
$a->{_urls} = [ { url => 'stale' } ];
$a->{_mailto_domains} = [ { domain => 'stale.example' } ];
$a->{_domain_info} = { 'stale.example' => {} };
$a->{_risk} = { level => 'STALE', score => 99, flags => [] };
$a->parse_email(make_email());
is $a->{_origin}, undef, 're-parse clears _origin';
is $a->{_urls}, undef, 're-parse clears _urls';
is $a->{_mailto_domains}, undef, 're-parse clears _mailto_domains';
is_deeply $a->{_domain_info}, {}, 're-parse clears _domain_info';
is $a->{_risk}, undef, 're-parse clears _risk';
};
# =============================================================================
# originating_ip()
# =============================================================================
subtest 'originating_ip() — documented hashref structure' => sub {
stub_net(rdns => 'mail.spammer.example', org => 'Bad ISP',
abuse => 'abuse@bad-isp.example', country => 'US');
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(
received => 'from spammer (spammer [91.198.174.42]) by mx'));
my $orig = $a->originating_ip();
ok defined $orig, 'returns a defined value';
is reftype($orig), 'HASH', 'returns a hashref';
for my $key (qw( ip rdns org abuse confidence note )) {
ok exists $orig->{$key}, "hashref contains key '$key'";
}
like $orig->{ip}, qr/^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/,
'ip is a dotted-quad IPv4 address';
ok $orig->{confidence} =~ /^(?:high|medium|low)$/,
"confidence is 'high', 'medium', or 'low'";
restore_net();
};
subtest 'originating_ip() — confidence levels per POD' => sub {
stub_net();
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(
received => 'from spammer (spammer [91.198.174.1]) by mx'));
is $a->originating_ip()->{confidence}, 'medium',
'single external hop yields medium confidence';
my $raw2 = "Received: from r1 (r1 [91.198.174.2]) by r2\n"
. "Received: from r2 (r2 [91.198.174.3]) by mx\n"
. "From: x\@y.com\nSubject: s\n\nbody";
my $b = Email::Abuse::Investigator->new();
$b->parse_email($raw2);
is $b->originating_ip()->{confidence}, 'high',
'two external hops yields high confidence';
my $c = Email::Abuse::Investigator->new();
$c->parse_email(make_email(
received => 'from localhost [127.0.0.1] by mx',
xoip => '62.105.128.99',
my @contacts = $a->abuse_contacts();
is scalar @contacts, 0,
'empty list returned when origin is undef and no domains/URLs';
};
# =============================================================================
# report()
# =============================================================================
subtest 'report() — returns a non-empty plain string' => sub {
stub_net();
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email());
my $r = $a->report();
ok defined $r, 'returns a defined value';
ok !ref($r), 'returns a plain string';
ok length($r) > 0, 'report is non-empty';
restore_net();
};
subtest 'report() — contains all expected section headings' => sub {
stub_net();
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(
body => 'https://spamsite.example/buy and info@spamsite.example',
from => 'Bad <bad@gmail.com>',
));
{
no warnings 'redefine';
local *Email::Abuse::Investigator::_resolve_host = sub { '1.2.3.4' };
local *Email::Abuse::Investigator::_whois_ip = sub {
{ org => 'Test Org', abuse => 'abuse@testorg.example', country => 'US' }
};
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
my $r = $a->report();
like $r, qr/Email::Abuse::Investigator Report/, 'report title present';
like $r, qr/RISK ASSESSMENT/, 'RISK ASSESSMENT present';
like $r, qr/ORIGINATING HOST/, 'ORIGINATING HOST present';
like $r, qr/EMBEDDED HTTP\/HTTPS URLs/, 'EMBEDDED HTTP/HTTPS URLs present';
like $r, qr/CONTACT \/ REPLY-TO DOMAINS/, 'CONTACT/REPLY-TO DOMAINS present';
like $r, qr/WHERE TO SEND ABUSE REPORTS/, 'WHERE TO SEND ABUSE REPORTS present';
}
restore_net();
};
subtest 'report() — idempotent on same object' => sub {
stub_net();
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email());
my $r1 = $a->report();
my $r2 = $a->report();
is $r2, $r1, 'report() returns same string on second call';
restore_net();
};
subtest 'report() — envelope headers are decoded and displayed' => sub {
stub_net();
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
local *Email::Abuse::Investigator::_resolve_host = sub { undef };
# Use a base64-encoded From: display name (as in the firmluminary spam)
my $enc_from = '=?UTF-8?B?' . encode_base64('eharmony Partner', '') . '?=';
my $enc_subj = '=?UTF-8?B?' . encode_base64('Ready to Find Love', '') . '?=';
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(
from => qq{"$enc_from" <peacelight\@firmluminary.com>},
subject => $enc_subj,
));
my $r = $a->report();
like $r, qr/eharmony Partner/, 'encoded From: display name decoded in report';
like $r, qr/Ready to Find Love/, 'encoded Subject decoded in report';
restore_net();
};
# =============================================================================
# Cross-method: lazy evaluation and re-parse
# =============================================================================
subtest 'parse_email() re-invocation clears all public-method caches' => sub {
stub_net(resolve => '1.2.3.4');
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(
body => 'https://first.example/page',
from => 'x@first.example',
received => 'from first (first [91.198.174.1]) by mx',
));
my @urls1 = $a->embedded_urls();
my $orig1 = $a->originating_ip();
my $risk1 = $a->risk_assessment();
ok @urls1 > 0, 'first parse: URLs populated';
ok defined $orig1, 'first parse: origin populated';
$a->parse_email(make_email(
body => 'No links at all.',
from => 'clean@verifiedcorp.example',
received => 'from clean (clean [91.198.174.2]) by mx',
));
my @urls2 = $a->embedded_urls();
is scalar @urls2, 0, 're-parse: URL cache refreshed (no links in new email)';
my $orig2 = $a->originating_ip();
ok !defined($orig2) || $orig2->{ip} ne '91.198.174.1', 're-parse: origin cache refreshed';
restore_net();
};
subtest 'report() — URL shortener flagged inline in URL section' => sub {
stub_net(resolve => '1.2.3.4');
no warnings 'redefine';
local *Email::Abuse::Investigator::_domain_whois = sub { undef };
my $a = Email::Abuse::Investigator->new();
$a->parse_email(make_email(body => 'Click https://bit.ly/abc123 now'));
$a->{_origin} = {
ip => '1.2.3.4', rdns => 'mail.ok', confidence => 'high',
org => 'X', abuse => 'a@b', note => '', country => undef,
};
local *Email::Abuse::Investigator::_resolve_host = sub { '67.199.248.10' };
local *Email::Abuse::Investigator::_whois_ip = sub { { org=>'Bitly', abuse=>'a@b' } };
my $r = $a->report();
like $r, qr/URL SHORTENER/, 'URL shortener warning appears in report';
restore_net();
};
# =============================================================================
# _sanitise_output contract
# =============================================================================
subtest '_sanitise_output() — strips C0 controls, preserves printable' => sub {
my $fn = \&Email::Abuse::Investigator::_sanitise_output;
ok defined &Email::Abuse::Investigator::_sanitise_output,
( run in 1.322 second using v1.01-cache-2.11-cpan-9169edd2b0e )