| File: | blib/lib/Email/Abuse/Investigator.pm |
| Coverage: | 92.3% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package Email::Abuse::Investigator; | |||||
| 2 | ||||||
| 3 | 22 22 22 11 64 133 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 787262 21 323 19 94 820 3 0 22 2 1 18 2 1 37 1356 1 9 2430 2 13 1465 2 13 912 1 12 | use strict; | |||
| 4 | 22 22 22 133 34 6 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 39 19 556 122 56 22 2 2 4 2 1 3 1 2 4 495 2 10 1329 1 10 561 2 10 1610 2 13 | use warnings; | |||
| 5 | 22 22 22 3 20 15 1 1 0 1 1 0 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 | 3660 117283 55 359 34 25 102 5 0 114 5 0 120 6 0 1318 1 13 1431 1 9 1372 1 13 862 2 12 | use autodie qw(:all); | |||
| 6 | ||||||
| 7 | 22 22 22 18 18 22 1 1 0 1 1 0 1 1 0 1 1 1 1 1 1 1 1 1 | 139776 28 585 1318 29 30 352 5 0 442 5 0 460 5 0 153 1 18 2554 1 14 1246 1 18 | use Carp qw(croak carp); | |||
| 8 | 22 22 22 25 25 104 1 1 0 1 1 0 1 1 0 1 1 1 1 1 1 1 1 1 | 3461 12744 487 1118 50 81 291 4 0 312 4 0 351 4 0 2 0 33 2 1 31 2 1 34 | use IO::Select; | |||
| 9 | 22 22 22 107 75 75 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 2556 117792 136 1050 55 61 312 2 2 309 2 1 285 2 1 2 1 4 2 1 4 3 1 3 | use IO::Socket::INET; | |||
| 10 | 22 30 1 1 1 1 1 1 | 5692 47 1 1 2 2210 2191 2222 | BEGIN { $Sub::Private::config{mode} = 'enforce' } | |||
| 11 | 22 22 22 390 73 76 1 0 1 1 0 1 1 0 1 1 1 1 1 1 1 1 1 1 | 4108 640318 97 333 67 1056 4 0 271 4 0 276 3 0 305 2 34 2 1 36 2 1 86 4 | use Sub::Private; | |||
| 12 | 22 22 22 12 76 8 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 6342 71300 94 21 69 11 2 1 1 1 2 1 2 2 1 0 17 3 1 16 1 1 18 2 | use Sub::Protected; | |||
| 13 | 22 22 22 76 3 76 1 0 1 1 0 1 1 0 1 1 1 1 1 1 1 1 1 1 | 5055 5113 577 71 5 993 3 0 804 3 0 264 3 0 273 1 5 230 1 6 216 0 6 235 | use MIME::QuotedPrint qw( decode_qp ); | |||
| 14 | 22 22 22 4 73 292 1 0 1 1 0 1 1 0 1 1 1 1 1 1 1 1 1 1 | 65 24 325 16 62 18843 5 0 6086 4 0 5055 4 0 6282 2 2 3 2 1 3 7 2 5 | use MIME::Base64 qw( decode_base64 ); | |||
| 15 | 22 22 22 76 76 376 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 4844 552786 405 50 129 5650 1 22 1137 2 27 1705 1 26 1547 117 1 6 133 1 4 131 1 4 | use Object::Configure; | |||
| 16 | 22 22 22 106 5 5 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 73 35 451 137 64 3572 1 14 2415 1 16 731 1 21 2980 71 1 30 74 2 20 74 1 23 | use Params::Get; | |||
| 17 | 22 22 22 104 4 4 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 48 232 314 102 52 4661 1 14 2542 1 16 1020 2 20 2958 3 1 14 2 1 13 2 2 13 | use Params::Validate::Strict 0.34; | |||
| 18 | 22 22 22 4 4 4 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 57 25 383 9 49 4387 1 12 1181 1 17 1815 1 19 860 1 1 8 2 0 11 1 2 11 | use Readonly; | |||
| 19 | 22 22 22 18 18 75 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 3651 11332 1772 25 178 11412 2 13 3956 1 16 3521 3 16 2988 3 1 16 1 1 17 1 1 23 | use Readonly::Values::Months; | |||
| 20 | 22 22 22 75 39 43 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 63 20 539 93 74 12858 1 14 3684 1 11 2796 1 16 4135 2 11 13 2 12 16 2 12 16 | use Socket qw( inet_aton inet_ntoa AF_INET ); | |||
| 21 | 22 22 22 43 54 74 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 3760 71549 92 45 103 4790 1 13 2057 1 10 1130 3 16 2054 2 1 15 2 1 15 1 1 18 | use Time::Piece; | |||
| 22 | ||||||
| 23 - 32 | =head1 NAME Email::Abuse::Investigator - Analyse spam email to identify originating hosts, hosted URLs, and suspicious domains =head1 VERSION Version 0.12 =cut | |||||
| 33 | ||||||
| 34 | our $VERSION = '0.12'; | |||||
| 35 | ||||||
| 36 - 99 | =head1 SYNOPSIS use Email::Abuse::Investigator; my $analyser = Email::Abuse::Investigator->new( verbose => 1 ); $analyser->parse_email($raw_email_text); # Originating IP and its network owner my $origin = $analyser->originating_ip(); # All HTTP/HTTPS URLs found in the body my @urls = $analyser->embedded_urls(); # All domains extracted from mailto: links and bare addresses in the body my @mdoms = $analyser->mailto_domains(); # All domains mentioned anywhere (union of the above) my @adoms = $analyser->all_domains(); # Full printable report print $analyser->report(); =head1 DESCRIPTION C<Email::Abuse::Investigator> examines the raw source of a spam/phishing e-mail and answers the questions manual abuse investigators ask: =over 4 =item 1. Where did the message really come from? Walks the C<Received:> chain, skips private/trusted IPs, and identifies the first external hop. Enriches with rDNS, WHOIS/RDAP org name and abuse contact. Both IPv4 and IPv6 addresses are supported. =item 2. Who hosts the advertised web sites? Extracts every C<http://> and C<https://> URL from both plain-text and HTML parts, resolves each hostname to an IP, and looks up the network owner. =item 3. Who owns the reply-to / contact domains? Extracts domains from C<mailto:> links, bare e-mail addresses in the body, the C<From:>/C<Reply-To:>/C<Sender:>/C<Return-Path:> headers, C<DKIM-Signature: d=> (the signing domain), C<List-Unsubscribe:> (the ESP or bulk-sender domain), and the C<Message-ID:> domain. For each unique domain it gathers: =over 8 =item * Domain registrar and registrant (WHOIS) =item * Web-hosting IP and network owner (A record -> RDAP) =item * Mail-hosting IP and network owner (MX record -> RDAP) =item * DNS nameserver operator (NS record -> RDAP) =item * Whether the domain was recently registered (potential flag) =back =back =cut | |||||
| 100 | ||||||
| 101 | # ----------------------------------------------------------------------- | |||||
| 102 | # Optional modules -- gracefully degraded when absent | |||||
| 103 | # ----------------------------------------------------------------------- | |||||
| 104 | ||||||
| 105 | # Net::DNS enables MX, NS, AAAA lookups; falls back to gethostbyname | |||||
| 106 | my $HAS_NET_DNS; | |||||
| 107 | ||||||
| 108 | # LWP::UserAgent enables RDAP queries; falls back to raw WHOIS | |||||
| 109 | my $HAS_LWP; | |||||
| 110 | my $HAS_CONN_CACHE; | |||||
| 111 | ||||||
| 112 | # HTML::LinkExtor enables structural HTML link extraction | |||||
| 113 | my $HAS_HTML_LINKEXTOR; | |||||
| 114 | ||||||
| 115 | # CHI enables a persistent cross-message cache for IP/domain data | |||||
| 116 | my $HAS_CHI; | |||||
| 117 | ||||||
| 118 | # IO::Socket::IP provides dual-stack (IPv4+IPv6) socket support | |||||
| 119 | my $HAS_IO_SOCKET_IP; | |||||
| 120 | ||||||
| 121 | # Domain::PublicSuffix enables accurate eTLD+1 normalisation | |||||
| 122 | my $HAS_PUBLIC_SUFFIX; | |||||
| 123 | ||||||
| 124 | # AnyEvent::DNS enables parallel DNS queries | |||||
| 125 | my $HAS_ANYEVENT_DNS; | |||||
| 126 | ||||||
| 127 | BEGIN { | |||||
| 128 | 22 22 0 54 39 16 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 6057 1159 0 98 67 5031 1 13 1426 2 13 981 1 12 1540 2 4 65 1 1 70 1 1 69 | $HAS_NET_DNS = eval { require Net::DNS; 1 }; | |||
| 129 | 22 22 0 16 3 6 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 7145 969 0 26 42 3979 2 13 759 2 10 1544 1 14 545 3 0 46 2 1 17 2 1 18 | $HAS_LWP = eval { require LWP::UserAgent; 1 }; | |||
| 130 | 22 22 0 6 6 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 5498 917 0 11 43 4950 1 12 1425 2 13 890 1 13 1227 2 1 4 3 1 3 2 1 3 | $HAS_CONN_CACHE = eval { require LWP::ConnCache; 1 }; | |||
| 131 | 22 22 22 3 3 6 1 1 1 1 1 1 1 1 1 1 1 0 1 1 0 1 1 0 | 4899 3813 69631 5 75 3147 2 16 950 2 10 1097 1 14 1064 109 6 0 132 4 0 115 6 0 | $HAS_HTML_LINKEXTOR= eval { require HTML::LinkExtor; 1 }; | |||
| 132 | 22 22 0 6 3 3 1 1 1 1 1 1 1 1 1 1 1 0 1 1 0 1 1 0 | 23 1065 0 13 39 3781 2 13 529 1 18 1481 1 13 796 409 5 0 834 5 0 446 5 0 | $HAS_CHI = eval { require CHI; 1 }; | |||
| 133 | 22 22 22 3 5 5 1 1 1 1 1 1 1 1 1 1 1 0 1 1 0 1 1 0 | 5228 3284 37982 4 43 3473 2 11 1137 1 9 1134 2 13 884 302 4 0 738 4 0 313 4 0 | $HAS_IO_SOCKET_IP = eval { require IO::Socket::IP; 1 }; | |||
| 134 | 22 22 0 5 5 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 | 26 1032 0 10 57 5247 1 12 968 2 8 2034 1 12 928 304 2 1 730 5 0 275 1 1 | $HAS_PUBLIC_SUFFIX = eval { require Domain::PublicSuffix; 1 }; | |||
| 135 | 22 22 0 3 3 3 1 1 1 1 1 1 1 1 1 1 1 0 1 1 0 1 1 0 | 4959 5485 0 7 39 3849 2 12 1106 1 14 1144 1 11 1367 1 4 0 678 4 0 2 4 0 | $HAS_ANYEVENT_DNS = eval { require AnyEvent::DNS; 1 }; | |||
| 136 | } | |||||
| 137 | ||||||
| 138 | # ----------------------------------------------------------------------- | |||||
| 139 | # Constants -- all magic numbers and strings live here | |||||
| 140 | # ----------------------------------------------------------------------- | |||||
| 141 | ||||||
| 142 | # WHOIS protocol port (IANA-assigned) | |||||
| 143 | Readonly::Scalar my $WHOIS_PORT => 43; | |||||
| 144 | ||||||
| 145 | # Bytes to read per sysread() call from a WHOIS socket | |||||
| 146 | Readonly::Scalar my $WHOIS_READ_CHUNK => 4096; | |||||
| 147 | ||||||
| 148 | # Maximum WHOIS response bytes stored in whois_raw (keep reports compact) | |||||
| 149 | Readonly::Scalar my $WHOIS_RAW_MAX => 2048; | |||||
| 150 | ||||||
| 151 | # Maximum multipart nesting depth (recursion guard -- RFC 2046 has no limit | |||||
| 152 | # but we cap it to prevent stack exhaustion on crafted messages) | |||||
| 153 | Readonly::Scalar my $MAX_MULTIPART_DEPTH => 20; | |||||
| 154 | ||||||
| 155 | # Number of days before registration that triggers recently_registered flag | |||||
| 156 | Readonly::Scalar my $RECENT_REG_DAYS => 180; | |||||
| 157 | ||||||
| 158 | # Number of days ahead of expiry that triggers domain_expires_soon flag | |||||
| 159 | Readonly::Scalar my $EXPIRY_WARN_DAYS => 30; | |||||
| 160 | ||||||
| 161 | # Seconds in a day -- used in date arithmetic throughout | |||||
| 162 | Readonly::Scalar my $SECS_PER_DAY => 86400; | |||||
| 163 | ||||||
| 164 | # Suspicious date window: dates outside +/- 7 days raise a flag | |||||
| 165 | Readonly::Scalar my $DATE_SKEW_DAYS => 7; | |||||
| 166 | ||||||
| 167 | # Maximum positive timezone offset in minutes (+14:00 = Line Islands) | |||||
| 168 | Readonly::Scalar my $TZ_MAX_POS_MINS => 840; | |||||
| 169 | ||||||
| 170 | # Maximum negative timezone offset in minutes (-12:00 = Baker Island) | |||||
| 171 | Readonly::Scalar my $TZ_MAX_NEG_MINS => 720; | |||||
| 172 | ||||||
| 173 | # High-risk score threshold | |||||
| 174 | Readonly::Scalar my $SCORE_HIGH => 9; | |||||
| 175 | ||||||
| 176 | # Medium-risk score threshold | |||||
| 177 | Readonly::Scalar my $SCORE_MEDIUM => 5; | |||||
| 178 | ||||||
| 179 | # Low-risk score threshold | |||||
| 180 | Readonly::Scalar my $SCORE_LOW => 2; | |||||
| 181 | ||||||
| 182 | # Flag severity weights (contribute to the numeric risk score) | |||||
| 183 | Readonly::Hash my %FLAG_WEIGHT => ( | |||||
| 184 | HIGH => 3, | |||||
| 185 | MEDIUM => 2, | |||||
| 186 | LOW => 1, | |||||
| 187 | INFO => 0, | |||||
| 188 | ); | |||||
| 189 | ||||||
| 190 | # Maximum merged-role display string length before summarisation kicks in | |||||
| 191 | Readonly::Scalar my $ROLE_MAX_LEN => 80; | |||||
| 192 | ||||||
| 193 | # CHI cache TTL in seconds (1 hour -- IP allocations change slowly) | |||||
| 194 | Readonly::Scalar my $CACHE_TTL_SECS => 3600; | |||||
| 195 | ||||||
| 196 | # Default constructor timeout for network operations (seconds) | |||||
| 197 | Readonly::Scalar my $DEFAULT_TIMEOUT => 10; | |||||
| 198 | ||||||
| 199 | # Maximum role string length before truncation | |||||
| 200 | Readonly::Scalar my $ROLE_WRAP_LEN => 66; | |||||
| 201 | ||||||
| 202 | # Maximum redirect hops to follow when resolving shortener/redirect-cloaker URLs | |||||
| 203 | Readonly::Scalar my $REDIRECT_MAX_HOPS => 3; | |||||
| 204 | ||||||
| 205 | # Brand names checked in lookalike-domain detection. | |||||
| 206 | # Overridable at runtime via Object::Configure. | |||||
| 207 | Readonly::Array my @LOOKALIKE_BRANDS => qw( | |||||
| 208 | paypal apple google amazon microsoft netflix ebay | |||||
| 209 | instagram facebook twitter linkedin bankofamerica | |||||
| 210 | wellsfargo chase barclays hsbc lloyds santander | |||||
| 211 | ); | |||||
| 212 | ||||||
| 213 | # ----------------------------------------------------------------------- | |||||
| 214 | # Private ranges -- IPs that are never actionable abuse targets | |||||
| 215 | # ----------------------------------------------------------------------- | |||||
| 216 | ||||||
| 217 | # Both IPv4 and IPv6 private/reserved ranges. Each entry is a compiled | |||||
| 218 | # regex; _is_private() iterates over them and returns true on first match. | |||||
| 219 | my @PRIVATE_RANGES = ( | |||||
| 220 | # IPv4 ranges | |||||
| 221 | qr/^0\./, # 0.0.0.0/8 this-network (RFC 1122) | |||||
| 222 | qr/^127\./, # 127.0.0.0/8 loopback | |||||
| 223 | qr/^10\./, # 10.0.0.0/8 RFC 1918 | |||||
| 224 | qr/^192\.168\./, # 192.168.0.0/16 RFC 1918 | |||||
| 225 | qr/^172\.(?:1[6-9]|2\d|3[01])\./, # 172.16.0.0/12 RFC 1918 | |||||
| 226 | qr/^169\.254\./, # 169.254.0.0/16 link-local | |||||
| 227 | qr/^100\.(?:6[4-9]|[7-9]\d|1(?:[01]\d|2[0-7]))\./, # 100.64.0.0/10 CGN (RFC 6598) | |||||
| 228 | qr/^192\.0\.0\./, # 192.0.0.0/24 IETF protocol (RFC 6890) | |||||
| 229 | qr/^192\.0\.2\./, # 192.0.2.0/24 TEST-NET-1 (RFC 5737) | |||||
| 230 | qr/^198\.51\.100\./, # 198.51.100.0/24 TEST-NET-2 (RFC 5737) | |||||
| 231 | qr/^203\.0\.113\./, # 203.0.113.0/24 TEST-NET-3 (RFC 5737) | |||||
| 232 | qr/^255\./, # 255.0.0.0/8 broadcast | |||||
| 233 | # IPv6 ranges | |||||
| 234 | qr/^::1$/, # IPv6 loopback | |||||
| 235 | qr/^fe80:/i, # IPv6 link-local (fe80::/10) | |||||
| 236 | qr/^fc/i, # IPv6 ULA fc00::/7 | |||||
| 237 | qr/^fd/i, # IPv6 ULA fd00::/8 | |||||
| 238 | qr/^2001:db8:/i, # IPv6 documentation range (RFC 3849) | |||||
| 239 | qr/^64:ff9b:/i, # IPv6 NAT64 well-known prefix | |||||
| 240 | ); | |||||
| 241 | ||||||
| 242 | # Priority-ordered patterns for extracting IPs from Received: headers. | |||||
| 243 | # Covers bracketed IPv4, bracketed IPv6, parenthesised address, and bare dotted-quad. | |||||
| 244 | my @RECEIVED_IP_RE = ( | |||||
| 245 | qr/\[\s*([\d.]+)\s*\]/, # [1.2.3.4] | |||||
| 246 | qr/\[\s*([0-9a-fA-F:]+)\s*\]/, # [IPv6 address] | |||||
| 247 | qr/\(\s*[\w.-]*\s*\[?\s*([\d.]+)\s*\]?\s*\)/, # (hostname [1.2.3.4]) | |||||
| 248 | qr/from\s+[\w.-]+\s+([\d.]+)/, # from hostname addr | |||||
| 249 | qr/([\d]{1,3}\.[\d]{1,3}\.[\d]{1,3}\.[\d]{1,3})/, # bare dotted-quad fallback | |||||
| 250 | ); | |||||
| 251 | ||||||
| 252 | # ----------------------------------------------------------------------- | |||||
| 253 | # Default configuration -- overridable via Object::Configure | |||||
| 254 | # ----------------------------------------------------------------------- | |||||
| 255 | ||||||
| 256 | # Object::Configure may overlay | |||||
| 257 | # values from a file before new() uses them. Use Readonly for constants | |||||
| 258 | # that should never be overridden at runtime. | |||||
| 259 | ||||||
| 260 | # ----------------------------------------------------------------------- | |||||
| 261 | # Trusted domains (infrastructure -- never report these as abuse targets) | |||||
| 262 | # Can be overrideen at runtime by Object::Configure | |||||
| 263 | # ----------------------------------------------------------------------- | |||||
| 264 | ||||||
| 265 | my %TRUSTED_DOMAINS = map { $_ => 1 } qw( | |||||
| 266 | gmail.com googlemail.com yahoo.com outlook.com hotmail.com | |||||
| 267 | google.com microsoft.com apple.com amazon.com | |||||
| 268 | googlegroups.com groups.google.com | |||||
| 269 | fonts.googleapis.com fonts.gstatic.com | |||||
| 270 | ajax.googleapis.com maps.googleapis.com | |||||
| 271 | w3.org | |||||
| 272 | fedex.com ups.com dhl.com usps.com royalmail.com | |||||
| 273 | ); | |||||
| 274 | ||||||
| 275 | # ----------------------------------------------------------------------- | |||||
| 276 | # URL shortener domains (real destination is hidden behind these) | |||||
| 277 | # ----------------------------------------------------------------------- | |||||
| 278 | ||||||
| 279 | my %URL_SHORTENERS = map { $_ => 1 } qw( | |||||
| 280 | bit.ly bitly.com tinyurl.com t.co ow.ly | |||||
| 281 | goo.gl is.gd buff.ly ift.tt dlvr.it | |||||
| 282 | short.link rebrand.ly tiny.cc cutt.ly rb.gy | |||||
| 283 | shorturl.at bl.ink smarturl.it yourls.org clicky.me | |||||
| 284 | snip.ly adf.ly bc.vc lnkd.in fb.me | |||||
| 285 | youtu.be | |||||
| 286 | ); | |||||
| 287 | ||||||
| 288 | # Cloud object-stores and CDN hosting paths commonly abused to serve redirect | |||||
| 289 | # pages that hide the real phishing destination (same evasion as a URL shortener | |||||
| 290 | # but using legitimate cloud infrastructure to pass spam filters). | |||||
| 291 | # Exact-match hosts; suffix patterns are in @REDIRECT_HOST_SUFFIXES below. | |||||
| 292 | my %REDIRECT_HOSTS = map { $_ => 1 } qw( | |||||
| 293 | storage.googleapis.com | |||||
| 294 | blob.core.windows.net | |||||
| 295 | pages.dev | |||||
| 296 | firebaseapp.com | |||||
| 297 | web.app | |||||
| 298 | ); | |||||
| 299 | ||||||
| 300 | # Subdomain-suffix patterns for bucket-style hosting (e.g. mybucket.s3.amazonaws.com). | |||||
| 301 | # Checked by _is_redirect_cloaker() using a suffix match against the bare hostname. | |||||
| 302 | Readonly::Array my @REDIRECT_HOST_SUFFIXES => qw( | |||||
| 303 | .s3.amazonaws.com | |||||
| 304 | .s3-website.amazonaws.com | |||||
| 305 | .cloudfront.net | |||||
| 306 | .github.io | |||||
| 307 | .firebaseapp.com | |||||
| 308 | .web.app | |||||
| 309 | ); | |||||
| 310 | ||||||
| 311 | # ----------------------------------------------------------------------- | |||||
| 312 | # Well-known provider abuse contacts | |||||
| 313 | # Can be overrideen at runtime by Object::Configure | |||||
| 314 | # ----------------------------------------------------------------------- | |||||
| 315 | ||||||
| 316 | # Curated table of provider abuse contacts. Entries with only a 'form' | |||||
| 317 | # key (no 'email') require web-form submission; abuse_contacts() suppresses | |||||
| 318 | # email addresses for those providers and form_contacts() surfaces them. | |||||
| 319 | my %PROVIDER_ABUSE = ( | |||||
| 320 | # Google / Gmail | |||||
| 321 | 'google.com' => { email => 'abuse@google.com', note => 'Also report Gmail accounts via https://support.google.com/mail/contact/abuse' }, | |||||
| 322 | 'gmail.com' => { email => 'abuse@google.com', note => 'Report Gmail spam via https://support.google.com/mail/contact/abuse' }, | |||||
| 323 | 'googlemail.com' => { email => 'abuse@google.com', note => 'Report via https://support.google.com/mail/contact/abuse' }, | |||||
| 324 | '1e100.net' => { email => 'abuse@google.com', note => 'Google infrastructure' }, | |||||
| 325 | 'blogspot.com' => { email => 'abuse@google.com', note => 'Blogger/Blogspot -- report via https://support.google.com/blogger/answer/76315' }, | |||||
| 326 | 'blogger.com' => { email => 'abuse@google.com', note => 'Blogger platform abuse' }, | |||||
| 327 | 'sites.google.com' => { email => 'abuse@google.com', note => 'Google Sites hosted content' }, | |||||
| 328 | 'storage.googleapis.com' => { email => 'google-cloud-compliance@google.com', note => 'Google Cloud Storage bucket abuse -- also report via https://support.google.com/code/go/gce_abuse_report' }, | |||||
| 329 | # Microsoft | |||||
| 330 | 'microsoft.com' => { email => 'abuse@microsoft.com', note => 'Also report via https://www.microsoft.com/en-us/wdsi/support/report-unsafe-site' }, | |||||
| 331 | 'outlook.com' => { email => 'abuse@microsoft.com', note => 'Report Outlook spam: https://support.microsoft.com/en-us/office/report-phishing' }, | |||||
| 332 | 'hotmail.com' => { email => 'abuse@microsoft.com', note => 'Report via https://support.microsoft.com/en-us/office/report-phishing' }, | |||||
| 333 | 'live.com' => { email => 'abuse@microsoft.com', note => 'Microsoft consumer mail' }, | |||||
| 334 | 'office365.com' => { email => 'abuse@microsoft.com', note => 'Microsoft 365 infrastructure' }, | |||||
| 335 | 'protection.outlook.com' => { email => 'abuse@microsoft.com', note => 'Microsoft EOP gateway' }, | |||||
| 336 | # Yahoo | |||||
| 337 | 'yahoo.com' => { email => 'abuse@yahoo-inc.com', note => 'Also use https://io.help.yahoo.com/contact/index' }, | |||||
| 338 | 'yahoo.co.uk' => { email => 'abuse@yahoo-inc.com', note => 'Yahoo UK' }, | |||||
| 339 | # Apple | |||||
| 340 | 'apple.com' => { email => 'reportphishing@apple.com', note => 'iCloud / Apple Mail abuse' }, | |||||
| 341 | 'icloud.com' => { email => 'reportphishing@apple.com', note => 'iCloud abuse' }, | |||||
| 342 | 'me.com' => { email => 'reportphishing@apple.com', note => 'Apple legacy mail' }, | |||||
| 343 | # Amazon / AWS | |||||
| 344 | 'amazon.com' => { email => 'abuse@amazonaws.com', note => 'Also https://aws.amazon.com/forms/report-abuse' }, | |||||
| 345 | 'amazonaws.com' => { email => 'abuse@amazonaws.com', note => 'AWS abuse form: https://aws.amazon.com/forms/report-abuse' }, | |||||
| 346 | 'amazonses.com' => { email => 'abuse@amazonaws.com', note => 'Amazon SES sending infrastructure' }, | |||||
| 347 | # Cloudflare | |||||
| 348 | 'cloudflare.com' => { email => 'abuse@cloudflare.com', note => 'Report via https://www.cloudflare.com/abuse/' }, | |||||
| 349 | # Fastly / Akamai | |||||
| 350 | 'fastly.net' => { email => 'abuse@fastly.com', note => 'Fastly CDN' }, | |||||
| 351 | 'akamai.com' => { email => 'abuse@akamai.com', note => 'Akamai CDN' }, | |||||
| 352 | 'akamaitechnologies.com' => { email => 'abuse@akamai.com', note => 'Akamai CDN' }, | |||||
| 353 | # Namecheap | |||||
| 354 | 'namecheap.com' => { email => 'abuse@namecheap.com', note => 'Registrar abuse' }, | |||||
| 355 | # GoDaddy -- web form only; email bounces | |||||
| 356 | 'godaddy.com' => { | |||||
| 357 | form => 'https://supportcenter.godaddy.com/AbuseReport', | |||||
| 358 | form_paste => 'Select the abuse type (spam, phishing, malware etc). ' | |||||
| 359 | . 'Enter the domain name in the Domain field. ' | |||||
| 360 | . 'Paste the originating IP, risk flags, and the relevant ' | |||||
| 361 | . 'Received: headers from the report below.', | |||||
| 362 | form_upload => 'Take a screenshot of the report as a .png or .jpg, ' | |||||
| 363 | . 'or export it as a .pdf.', | |||||
| 364 | note => 'Registrar/host -- email reports not monitored, use web form', | |||||
| 365 | }, | |||||
| 366 | # SendGrid / Twilio | |||||
| 367 | 'sendgrid.net' => { email => 'abuse@sendgrid.com', note => 'ESP -- include full headers' }, | |||||
| 368 | 'sendgrid.com' => { email => 'abuse@sendgrid.com', note => 'ESP -- include full headers' }, | |||||
| 369 | # Mailchimp / Mandrill | |||||
| 370 | 'mailchimp.com' => { email => 'abuse@mailchimp.com', note => 'ESP abuse' }, | |||||
| 371 | 'mandrillapp.com' => { email => 'abuse@mailchimp.com', note => 'Mandrill transactional ESP' }, | |||||
| 372 | # OVH | |||||
| 373 | 'ovh.net' => { email => 'abuse@ovh.net', note => 'OVH hosting' }, | |||||
| 374 | 'ovh.com' => { email => 'abuse@ovh.com', note => 'OVH hosting' }, | |||||
| 375 | # Hetzner | |||||
| 376 | 'hetzner.com' => { email => 'abuse@hetzner.com', note => 'Hetzner hosting' }, | |||||
| 377 | # Digital Ocean | |||||
| 378 | 'digitalocean.com' => { email => 'abuse@digitalocean.com',note => 'DO abuse form: https://www.digitalocean.com/company/contact/#abuse' }, | |||||
| 379 | # Linode / Akamai | |||||
| 380 | 'linode.com' => { email => 'abuse@linode.com', note => 'Linode/Akamai Cloud' }, | |||||
| 381 | # Constant Contact | |||||
| 382 | 'constantcontact.com' => { email => 'abuse@constantcontact.com', note => 'ESP abuse' }, | |||||
| 383 | 'r.constantcontact.com' => { email => 'abuse@constantcontact.com', note => 'Constant Contact sending infrastructure' }, | |||||
| 384 | # HubSpot | |||||
| 385 | 'hubspot.com' => { email => 'abuse@hubspot.com', note => 'ESP abuse' }, | |||||
| 386 | 'hs-analytics.net' => { email => 'abuse@hubspot.com', note => 'HubSpot analytics infrastructure' }, | |||||
| 387 | # Campaign Monitor | |||||
| 388 | 'createsend.com' => { email => 'abuse@campaignmonitor.com', note => 'Campaign Monitor ESP' }, | |||||
| 389 | 'cmail20.com' => { email => 'abuse@campaignmonitor.com', note => 'Campaign Monitor sending infrastructure' }, | |||||
| 390 | # Klaviyo | |||||
| 391 | 'klaviyo.com' => { email => 'abuse@klaviyo.com', note => 'ESP abuse' }, | |||||
| 392 | # Brevo (formerly Sendinblue) | |||||
| 393 | 'sendinblue.com' => { email => 'abuse@sendinblue.com', note => 'ESP abuse' }, | |||||
| 394 | 'brevo.com' => { email => 'abuse@brevo.com', note => 'ESP abuse' }, | |||||
| 395 | # Mailgun | |||||
| 396 | 'mailgun.com' => { email => 'abuse@mailgun.com', note => 'ESP abuse' }, | |||||
| 397 | 'mailgun.org' => { email => 'abuse@mailgun.com', note => 'Mailgun sending infrastructure' }, | |||||
| 398 | # Postmark | |||||
| 399 | 'postmarkapp.com' => { email => 'abuse@postmarkapp.com', note => 'ESP abuse' }, | |||||
| 400 | # WordPress.com | |||||
| 401 | 'wordpress.com' => { email => 'abuse@wordpress.com', note => 'WordPress.com hosted blog -- report via https://en.wordpress.com/abuse/' }, | |||||
| 402 | 'wp.com' => { email => 'abuse@wordpress.com', note => 'WordPress.com short domain' }, | |||||
| 403 | # Substack | |||||
| 404 | 'substack.com' => { email => 'abuse@substack.com', note => 'Substack newsletter platform abuse' }, | |||||
| 405 | # ActiveCampaign | |||||
| 406 | 'activecampaign.com' => { email => 'abuse@activecampaign.com', note => 'ActiveCampaign ESP' }, | |||||
| 407 | 'ac-tinker.com' => { email => 'abuse@activecampaign.com', note => 'ActiveCampaign tracking infrastructure' }, | |||||
| 408 | # Salesforce Marketing Cloud | |||||
| 409 | 'salesforce.com' => { email => 'abuse@salesforce.com', note => 'Salesforce Marketing Cloud / ExactTarget ESP' }, | |||||
| 410 | 'mc.salesforce.com' => { email => 'abuse@salesforce.com', note => 'Salesforce Marketing Cloud sending infrastructure' }, | |||||
| 411 | 'exacttarget.com' => { email => 'abuse@salesforce.com', note => 'ExactTarget / Salesforce Marketing Cloud ESP' }, | |||||
| 412 | 'et.exacttarget.com' => { email => 'abuse@salesforce.com', note => 'ExactTarget sending infrastructure' }, | |||||
| 413 | # Vultr | |||||
| 414 | 'vultr.com' => { email => 'abuse@vultr.com', note => 'Vultr hosting' }, | |||||
| 415 | # Contabo | |||||
| 416 | 'contabo.com' => { email => 'abuse@contabo.com', note => 'Contabo hosting' }, | |||||
| 417 | # Leaseweb | |||||
| 418 | 'leaseweb.com' => { email => 'abuse@leaseweb.com', note => 'Leaseweb hosting' }, | |||||
| 419 | # M247 | |||||
| 420 | 'm247.com' => { email => 'abuse@m247.com', note => 'M247 hosting' }, | |||||
| 421 | # MarkMonitor -- web form only | |||||
| 422 | 'markmonitor.com' => { | |||||
| 423 | form => 'https://corp.markmonitor.com/domain/ui/abuse-report', | |||||
| 424 | form_paste => 'Complete all fields including the domain name and your ' | |||||
| 425 | . 'description of the abuse. Paste the originating IP, ' | |||||
| 426 | . 'risk flags, and the relevant Received: headers from the ' | |||||
| 427 | . 'report below.', | |||||
| 428 | form_upload => 'Take a screenshot of the report as a .png or .jpg, or export it as a .pdf. MarkMonitor does not accept .eml files.', | |||||
| 429 | note => 'Brand-protection registrar -- email reports not processed', | |||||
| 430 | }, | |||||
| 431 | # URL shortener operators | |||||
| 432 | 'is.gd' => { email => 'abuse@is.gd', note => 'URL shortener -- report via https://is.gd/contact.php' }, | |||||
| 433 | 'bitly.com' => { email => 'abuse@bitly.com', note => 'URL shortener abuse' }, | |||||
| 434 | 'bit.ly' => { email => 'abuse@bitly.com', note => 'URL shortener abuse' }, | |||||
| 435 | 'tinyurl.com' => { email => 'abuse@tinyurl.com', note => 'URL shortener abuse' }, | |||||
| 436 | 'ow.ly' => { email => 'abuse@hootsuite.com', note => 'Hootsuite URL shortener' }, | |||||
| 437 | 'buff.ly' => { email => 'abuse@buffer.com', note => 'Buffer URL shortener' }, | |||||
| 438 | 'rb.gy' => { email => 'abuse@rb.gy', note => 'URL shortener abuse' }, | |||||
| 439 | 'cutt.ly' => { email => 'abuse@cutt.ly', note => 'URL shortener abuse' }, | |||||
| 440 | 'shorturl.at' => { email => 'abuse@shorturl.at', note => 'URL shortener abuse' }, | |||||
| 441 | # Dynadot -- web form only | |||||
| 442 | 'dynadot.com' => { | |||||
| 443 | form => 'https://www.dynadot.com/report-abuse', | |||||
| 444 | form_paste => 'Complete all fields including the domain name and your ' | |||||
| 445 | . 'description of the abuse. Paste the originating IP, ' | |||||
| 446 | . 'risk flags, and the relevant Received: headers from the ' | |||||
| 447 | . 'report below.', | |||||
| 448 | form_upload => 'Take a screenshot of the report as a .png or .jpg, ' | |||||
| 449 | . 'or export it as a .pdf.', | |||||
| 450 | note => 'Registrar -- email reports not monitored, use web form', | |||||
| 451 | }, | |||||
| 452 | # Global Domain Group -- web form only | |||||
| 453 | 'globaldomaingroup.com' => { | |||||
| 454 | form => 'https://globaldomaingroup.com/report-abuse', | |||||
| 455 | form_paste => 'Complete all fields including the domain name and your ' | |||||
| 456 | . 'description of the abuse. Paste the originating IP, ' | |||||
| 457 | . 'risk flags, and the relevant Received: headers from the ' | |||||
| 458 | . 'report below.', | |||||
| 459 | form_upload => 'Attach the original spam message as an .eml file.', | |||||
| 460 | note => 'Registrar -- email reports explicitly not accepted', | |||||
| 461 | }, | |||||
| 462 | # TPG / Internode (Australia) | |||||
| 463 | 'tpgi.com.au' => { email => 'abuse@tpg.com.au', note => 'TPG Telecom Australia' }, | |||||
| 464 | 'tpg.com.au' => { email => 'abuse@tpg.com.au', note => 'TPG Telecom Australia' }, | |||||
| 465 | 'internode.on.net' => { email => 'abuse@internode.on.net',note => 'Internode Australia' }, | |||||
| 466 | ); | |||||
| 467 | ||||||
| 468 | # ----------------------------------------------------------------------- | |||||
| 469 | # Constructor | |||||
| 470 | # ----------------------------------------------------------------------- | |||||
| 471 | ||||||
| 472 - 591 | =head1 METHODS
=head2 new( %options )
Constructs and returns a new C<Email::Abuse::Investigator> analyser object. The
object is stateless until C<parse_email()> is called; all analysis results
are stored on the object and retrieved via the public accessor methods
documented below.
A single object may be reused for multiple emails by calling C<parse_email()>
again: all per-message cached state from the previous message is discarded
automatically. Cross-message IP and domain lookup results are retained
in a shared CHI cache (if C<CHI> is installed) to avoid redundant network
queries across messages processed in the same process.
=head3 Usage
# Minimal -- all options take safe defaults
my $analyser = Email::Abuse::Investigator->new();
# With options
my $analyser = Email::Abuse::Investigator->new(
timeout => 15,
trusted_relays => ['203.0.113.0/24', '10.0.0.0/8'],
verbose => 0,
);
$analyser->parse_email($raw_rfc2822_text);
my $origin = $analyser->originating_ip();
my @urls = $analyser->embedded_urls();
my @domains = $analyser->mailto_domains();
my $risk = $analyser->risk_assessment();
my @contacts = $analyser->abuse_contacts();
print $analyser->report();
=head3 Arguments
All arguments are optional named parameters passed as a flat key-value list.
=over 4
=item C<timeout> (integer, default 10)
Maximum seconds to wait for any single network operation. Set to 0 to
disable timeouts (not recommended for production use).
=item C<trusted_relays> (arrayref of strings, default [])
IP addresses or CIDR blocks to skip during Received: chain analysis.
Each element may be an exact IPv4 address (C<'192.0.2.1'>) or a CIDR
block (C<'192.0.2.0/24'>).
=item C<verbose> (boolean, default 0)
When true, diagnostic messages are written to STDERR.
=back
=head3 Returns
A blessed C<Email::Abuse::Investigator> object. No network I/O is performed
during construction.
=head3 Side Effects
If C<CHI> is installed, a shared in-memory cache is initialised (or
re-used if a cache was already created by a prior call to C<new()>).
This cache persists for the lifetime of the process.
=head3 Notes
=over 4
=item *
Unknown option keys are silently ignored.
=item *
The object is not thread-safe. Use a separate object per thread.
=item *
WHOIS read timeouts use C<IO::Select> rather than C<alarm()>, so they
work correctly on Windows and in threaded Perl interpreters.
=back
=head3 API Specification
=head4 Input
{
timeout => {
type => 'integer',
optional => 1,
min => 0,
default => 10,
},
trusted_relays => {
type => 'arrayref',
element_type => 'string',
optional => 1,
default => [],
},
verbose => {
type => 'boolean',
optional => 1,
default => 0,
},
}
=head4 Output
{
type => 'object',
isa => 'Email::Abuse::Investigator',
}
=cut | |||||
| 592 | ||||||
| 593 | # Class-level cross-message CHI cache (shared across all instances). | |||||
| 594 | # Populated lazily on first call to new() when CHI is available. | |||||
| 595 | my $_cache; | |||||
| 596 | ||||||
| 597 | sub new { | |||||
| 598 | 2848 1 | 1856093 14 | my $class = shift; | |||
| 599 | ||||||
| 600 | # Accept hash or hashref arguments uniformly | |||||
| 601 | 2848 1 | 5697 1 | my $params = Params::Validate::Strict::validate_strict({ | |||
| 602 | args => Params::Get::get_params(undef, \@_) || {}, | |||||
| 603 | schema => { | |||||
| 604 | timeout => { | |||||
| 605 | 'type' => 'integer', | |||||
| 606 | 'optional' => 1, | |||||
| 607 | 'min' => 0, | |||||
| 608 | }, | |||||
| 609 | trusted_relays => { | |||||
| 610 | 'type' => 'arrayref', | |||||
| 611 | 'element_type' => 'string', | |||||
| 612 | 'optional' => 1, | |||||
| 613 | }, | |||||
| 614 | verbose => { | |||||
| 615 | 'type' => 'boolean', | |||||
| 616 | 'optional' => 1, | |||||
| 617 | }, | |||||
| 618 | }, | |||||
| 619 | }); | |||||
| 620 | ||||||
| 621 | # Merge in any file-based configuration via Object::Configure | |||||
| 622 | 1870 1 | 210771 23 | $params = Object::Configure::configure($class, $params); | |||
| 623 | ||||||
| 624 | # Initialise the cross-message CHI cache on first construction | |||||
| 625 | 1870 1 | 3458696 2 | if ($HAS_CHI && !$_cache) { | |||
| 626 | 3 1 | 3 2 | $_cache = CHI->new( | |||
| 627 | driver => 'Memory', | |||||
| 628 | global => 1, | |||||
| 629 | expires_in => $CACHE_TTL_SECS, | |||||
| 630 | ); | |||||
| 631 | } | |||||
| 632 | ||||||
| 633 | # Build and bless the object with default slot values | |||||
| 634 | return bless { | |||||
| 635 | timeout => $DEFAULT_TIMEOUT, | |||||
| 636 | trusted_relays => [], | |||||
| 637 | verbose => 0, | |||||
| 638 | _raw => '', | |||||
| 639 | _headers => [], | |||||
| 640 | _body_plain => '', | |||||
| 641 | _body_html => '', | |||||
| 642 | _received => [], | |||||
| 643 | _origin => undef, | |||||
| 644 | _urls => undef, # lazy-computed by embedded_urls() | |||||
| 645 | _mailto_domains=> undef, # lazy-computed by mailto_domains() | |||||
| 646 | _contacts => undef, # lazy-computed by abuse_contacts() | |||||
| 647 | _domain_info => {}, # per-message domain analysis cache | |||||
| 648 | _sending_sw => [], # X-Mailer / X-PHP-Originating-Script etc. | |||||
| 649 | _rcvd_tracking => [], # per-hop tracking IDs from Received: headers | |||||
| 650 | 1870 1870 1 1 | 3621 13140 4 140 | %{$params}, # Overlay Object::Configure and caller-supplied values | |||
| 651 | }, $class; | |||||
| 652 | } | |||||
| 653 | ||||||
| 654 | # ----------------------------------------------------------------------- | |||||
| 655 | # Public: parse | |||||
| 656 | # ----------------------------------------------------------------------- | |||||
| 657 | ||||||
| 658 - 734 | =head2 parse_email( $text )
Feeds a raw RFC 2822 email message to the analyser and prepares it for
subsequent interrogation. This is the only method that must be called
before any other public method.
If the same object is used for a second message, calling C<parse_email()>
again completely replaces all per-message state from the first message.
The cross-message CHI cache is B<not> flushed; IP and domain lookups
cached from prior messages are retained.
=head3 Usage
my $raw = do { local $/; <STDIN> };
$analyser->parse_email($raw);
# Scalar reference (avoids copying large messages)
$analyser->parse_email(\$raw);
# Chained
my $analyser = Email::Abuse::Investigator->new()->parse_email($raw);
=head3 Arguments
=over 4
=item C<$text> (string or string reference, required)
Complete raw RFC 2822 email message, including all headers and the body.
Both LF-only and CRLF line endings are accepted.
=back
=head3 Returns
The object itself (C<$self>), enabling method chaining.
=head3 Side Effects
Parses headers, decodes the body (quoted-printable, base64, multipart),
extracts sending-software fingerprints, and populates per-hop tracking
data. All previously computed lazy results are discarded.
=head3 Notes
=over 4
=item *
If C<$text> is empty or contains no header/body separator, all public
methods will return empty/safe values.
=item *
Decoding errors in base64 or quoted-printable payloads are silenced; raw
bytes are used in place of correct output to prevent exceptions.
=back
=head3 API Specification
=head4 Input
[
{
type => [ 'string', 'stringref' ]
},
]
=head4 Output
{
type => 'object',
isa => 'Email::Abuse::Investigator',
}
=cut | |||||
| 735 | ||||||
| 736 | # TODO: Allow a Mail::Message object to be passed in | |||||
| 737 | sub parse_email { | |||||
| 738 | 673 1 | 67015 6 | my $self = shift; | |||
| 739 | ||||||
| 740 | # Accept both positional string and named 'text' argument | |||||
| 741 | 673 0 | 1046 0 | my $args = Params::Get::get_params('text', \@_); | |||
| 742 | 672 1 | 13652 455 | my $text = $args->{text}; | |||
| 743 | ||||||
| 744 | # Dereference a scalar-ref in a single clean pass | |||||
| 745 | 672 1 | 971 5 | $text = $$text if ref($text) eq 'SCALAR'; | |||
| 746 | ||||||
| 747 | # Any other reference type is a programming error | |||||
| 748 | 672 0 | 1048 0 | Carp::croak(__PACKAGE__ . ': parse_email() requires a string or scalar reference') if ref($text); | |||
| 749 | ||||||
| 750 | # Sanitise: strip control characters that could affect terminal output. | |||||
| 751 | # Keep \t (tabs in headers), \n (line endings), \r (CRLF mail format). | |||||
| 752 | 668 1 | 2684 322 | $text =~ s/[^\x09\x0A\x0D\x20-\x7E\x80-\xFF]//g if defined $text; | |||
| 753 | ||||||
| 754 | # Store the sanitised raw text for later reproduction in reports | |||||
| 755 | 668 1 | 1835 4 | $self->{_raw} = $text // ''; | |||
| 756 | ||||||
| 757 | # Invalidate all per-message lazy caches | |||||
| 758 | 668 0 | 696 0 | $self->{_origin} = undef; | |||
| 759 | 668 1 | 629 323 | $self->{_urls} = undef; | |||
| 760 | 668 1 | 641 2 | $self->{_mailto_domains} = undef; | |||
| 761 | 668 1 | 566 1 | $self->{_contacts} = undef; | |||
| 762 | 668 1 | 1358 1 | $self->{_domain_info} = {}; | |||
| 763 | 668 1 | 709 4 | $self->{_risk} = undef; | |||
| 764 | 668 0 | 645 0 | $self->{_auth_results} = undef; | |||
| 765 | 668 1 | 636 275 | $self->{_sending_sw} = []; | |||
| 766 | 668 1 | 961 2 | $self->{_rcvd_tracking} = []; | |||
| 767 | ||||||
| 768 | # Perform synchronous header/body parsing (no network I/O) | |||||
| 769 | 668 1 | 2996 1 | $self->_split_message($text) if defined $text && $text =~ /\S/; | |||
| 770 | 668 1 | 1146 1 | return $self; | |||
| 771 | } | |||||
| 772 | ||||||
| 773 | # ----------------------------------------------------------------------- | |||||
| 774 | # Public: originating host | |||||
| 775 | # ----------------------------------------------------------------------- | |||||
| 776 | ||||||
| 777 - 838 | =head2 originating_ip()
Identifies the IP address of the machine that originally injected the
message into the mail system by walking the C<Received:> chain, skipping
private/trusted hops, and enriching the first external hop with rDNS,
WHOIS/RDAP organisation name, abuse contact, and country code.
Both IPv4 and IPv6 addresses are extracted and evaluated.
The result is cached; subsequent calls return the same hashref without
repeating network I/O.
=head3 Usage
my $orig = $analyser->originating_ip();
if (defined $orig) {
printf "Origin: %s (%s)\n", $orig->{ip}, $orig->{rdns};
printf "Owner: %s\n", $orig->{org};
}
=head3 Arguments
None. C<parse_email()> must have been called first.
=head3 Returns
A hashref with keys C<ip>, C<rdns>, C<org>, C<abuse>, C<confidence>,
C<note>, and C<country> (may be undef). Returns C<undef> if no suitable
originating IP can be determined.
=head3 Side Effects
On first call: one PTR lookup and one RDAP/WHOIS query. Results are cached
in the object and in the cross-message CHI cache (if available).
=head3 Notes
Only the first (oldest) external IP in the chain is reported. See
C<received_trail()> for the full chain.
=head3 API Specification
=head4 Input
[]
=head4 Output
{
type => [ 'hashref', 'undef' ],
keys => {
ip => { type => 'string', regex => qr/[\d.:a-fA-F]/ },
rdns => { type => 'string' },
org => { type => 'string' },
abuse => { type => 'string' },
confidence => { type => 'string', memberof => [ 'high', 'medium', 'low' ] },
note => { type => 'string' },
country => { type => 'string', optional => 1 },
},
}
=cut | |||||
| 839 | ||||||
| 840 | sub originating_ip { | |||||
| 841 | 934 1 | 12390 4 | my $self = $_[0]; | |||
| 842 | ||||||
| 843 | # Return the cached result if we already have it | |||||
| 844 | 934 0 | 1675 0 | $self->{_origin} //= $self->_find_origin(); | |||
| 845 | 934 1 | 1687 271 | return $self->{_origin}; | |||
| 846 | } | |||||
| 847 | ||||||
| 848 | # ----------------------------------------------------------------------- | |||||
| 849 | # Public: HTTP/HTTPS URLs | |||||
| 850 | # ----------------------------------------------------------------------- | |||||
| 851 | ||||||
| 852 - 926 | =head2 embedded_urls()
Extracts every HTTP and HTTPS URL from the message body and enriches each
one with the hosting IP address, network organisation name, abuse contact,
and country code. Both IPv4 and IPv6 host addresses are supported.
URL extraction runs across both plain-text and HTML body parts. DNS
lookups for each unique hostname are optionally parallelised via
C<AnyEvent::DNS> if that module is installed.
The result is cached; subsequent calls return the same list without
repeating network I/O.
=head3 Usage
my @urls = $analyser->embedded_urls();
for my $u (@urls) {
printf "URL: %s host: %s org: %s\n",
$u->{url}, $u->{host}, $u->{org};
}
=head3 Arguments
None. C<parse_email()> must have been called first.
=head3 Returns
A list of hashrefs, one per unique URL, in first-seen order. Returns an
empty list if no HTTP/HTTPS URLs are present. Each hashref has keys
C<url>, C<host>, C<ip>, C<org>, C<abuse>, C<country>.
=head3 Side Effects
Per unique hostname: one A/AAAA lookup and one RDAP/WHOIS query. Results
are cached in the object and in the cross-message CHI cache.
=head3 Notes
Only C<http://> and C<https://> URLs are extracted. URL shortener hosts
are included in the returned list (they are flagged by C<risk_assessment()>).
When L<LWP::UserAgent> is available, URLs whose host is a known URL shortener
or cloud-storage redirect cloaker (Google Cloud Storage C<storage.googleapis.com>,
Azure Blob Storage C<blob.core.windows.net>, Cloudflare Pages C<pages.dev>,
S3 buckets, CloudFront distributions, etc.) are automatically resolved by
following HTTP 3xx redirects and HTML C<meta http-equiv="refresh"> or
C<window.location> patterns up to C<$REDIRECT_MAX_HOPS> hops. The resolved
destination URL is added to the returned list alongside the original, so abuse
contacts for the real phishing target are always reported even when the email
body contains only an object-store redirect URL.
=head3 API Specification
=head4 Input
[]
=head4 Output
(
{
type => 'hashref',
keys => {
url => { type => 'string', regex => qr{^https?://}i },
host => { type => 'string' },
ip => { type => 'string' },
org => { type => 'string' },
abuse => { type => 'string' },
country => { type => 'string', optional => 1 },
},
},
...
)
=cut | |||||
| 927 | ||||||
| 928 | sub embedded_urls { | |||||
| 929 | 1036 1 | 10556 4 | my $self = $_[0]; | |||
| 930 | ||||||
| 931 | 1036 0 | 1545 0 | $self->{_urls} //= $self->_extract_and_resolve_urls(); | |||
| 932 | 1036 1036 1 1 | 1087 1637 6189 2 | return @{ $self->{_urls} }; | |||
| 933 | } | |||||
| 934 | ||||||
| 935 | # ----------------------------------------------------------------------- | |||||
| 936 | # Public: mailto / reply-to / from domains | |||||
| 937 | # ----------------------------------------------------------------------- | |||||
| 938 | ||||||
| 939 - 997 | =head2 mailto_domains()
Identifies every domain associated with the message as a contact, reply,
or delivery address, then runs a full intelligence pipeline on each one
(A record, MX, NS, WHOIS) to determine hosting and registration details.
The result is cached; subsequent calls return the same list without
repeating network I/O.
=head3 Usage
my @domains = $analyser->mailto_domains();
for my $d (@domains) {
printf "Domain: %s registrar: %s\n",
$d->{domain}, $d->{registrar} // 'unknown';
}
=head3 Arguments
None. C<parse_email()> must have been called first.
=head3 Returns
A list of hashrefs, one per unique domain. See the main POD for the full
set of possible keys. Returns an empty list if no qualifying domains are
found.
=head3 Side Effects
Per unique domain: up to three A lookups, one MX lookup, one NS lookup,
and two WHOIS queries. Results are cached in the object and in the
cross-message CHI cache.
=head3 Notes
MX and NS lookups require C<Net::DNS>. Without it those keys are absent
from every returned hashref.
=head3 API Specification
=head4 Input
[]
=head4 Output
(
{
type => 'hashref',
keys => {
domain => { type => 'string' },
source => { type => 'string' },
# All other keys optional -- see main POD
},
},
...
)
=cut | |||||
| 998 | ||||||
| 999 | sub mailto_domains { | |||||
| 1000 | 944 1 | 3871 24 | my $self = $_[0]; | |||
| 1001 | ||||||
| 1002 | 944 1 | 1404 1004 | $self->{_mailto_domains} //= $self->_extract_and_analyse_domains(); | |||
| 1003 | 944 944 1 1 | 747 1207 1 43 | return @{ $self->{_mailto_domains} }; | |||
| 1004 | } | |||||
| 1005 | ||||||
| 1006 - 1050 | =head2 all_domains()
Returns the deduplicated union of every registrable domain seen anywhere
in the message -- URL hosts from C<embedded_urls()> and contact domains
from C<mailto_domains()> -- normalised to eTLD+1 form.
Triggers C<embedded_urls()> and C<mailto_domains()> lazily.
=head3 Usage
my @domains = $analyser->all_domains();
print "$_\n" for @domains;
=head3 Arguments
None.
=head3 Returns
A list of plain strings (registrable domain names), lower-cased, no
duplicates, in first-seen order.
=head3 Side Effects
Triggers C<embedded_urls()> and C<mailto_domains()> if not already cached.
=head3 Notes
Normalisation to eTLD+1 uses C<Domain::PublicSuffix> if installed, falling
back to a built-in heuristic otherwise.
=head3 API Specification
=head4 Input
[]
=head4 Output
(
{ type => 'string', regex => qr/^[a-z0-9][a-z0-9.-]*\.[a-z]{2,}$/ },
...
)
=cut | |||||
| 1051 | ||||||
| 1052 | sub all_domains { | |||||
| 1053 | 76 1 | 4132 2518 | my $self = $_[0]; | |||
| 1054 | 76 1 | 82 2 | my (%seen, @out); | |||
| 1055 | ||||||
| 1056 | # Collect registrable domains from URL hosts first | |||||
| 1057 | 76 1 | 125 15 | for my $u ($self->embedded_urls()) { | |||
| 1058 | 71 1 | 164 2704 | my $dom = _registrable($u->{host}); | |||
| 1059 | 71 1 | 122 1 | push @out, $dom if $dom && !$seen{$dom}++; | |||
| 1060 | } | |||||
| 1061 | ||||||
| 1062 | # Then from contact domains (normalise subdomains to registrable parent) | |||||
| 1063 | 76 1 | 294 18 | for my $d ($self->mailto_domains()) { | |||
| 1064 | 81 1 | 182 1306 | my $dom = _registrable($d->{domain}) // $d->{domain}; | |||
| 1065 | 29 1 | 103 1 | push @out, $dom if $dom && !$seen{$dom}++; | |||
| 1066 | } | |||||
| 1067 | 24 1 | 40 16 | return @out; | |||
| 1068 | } | |||||
| 1069 | ||||||
| 1070 - 1123 | =head2 unresolved_contacts()
Returns a list of domains and URL hosts found in the message for which no
abuse contact could be determined. Useful for surfacing parties that may
warrant manual investigation.
=head3 Usage
my @unresolved = $analyser->unresolved_contacts();
for my $u (@unresolved) {
printf "Unresolved: %s (%s) via %s\n",
$u->{domain}, $u->{type}, $u->{source};
}
=head3 Arguments
None.
=head3 Returns
A list of hashrefs, each with keys C<domain>, C<type> (C<'url_host'> or
C<'domain'>), and C<source> (where the domain was found).
=head3 Side Effects
Triggers C<embedded_urls()>, C<mailto_domains()>, C<abuse_contacts()>,
and C<form_contacts()> if not already cached.
=head3 Notes
Domains sourced only from spoofable sending headers (C<From:>,
C<Return-Path:>, C<Sender:>) are excluded.
=head3 API Specification
=head4 Input
[]
=head4 Output
(
{
type => 'hashref',
keys => {
domain => { type => 'string' },
type => { type => 'string', memberof => [ 'url_host', 'domain' ] },
source => { type => 'string' },
},
},
...
)
=cut | |||||
| 1124 | ||||||
| 1125 | sub unresolved_contacts { | |||||
| 1126 | 36 1 | 547 3987 | my $self = $_[0]; | |||
| 1127 | ||||||
| 1128 | # Build a set of domains already covered by email or form contacts | |||||
| 1129 | 36 1 | 36 2 | my %covered; | |||
| 1130 | 36 1 | 71 14 | for my $c ($self->abuse_contacts(), $self->form_contacts()) { | |||
| 1131 | 15 1 | 72 5167 | my $dom = $c->{form_domain}; | |||
| 1132 | 15 1 | 27 1 | unless ($dom) { | |||
| 1133 | # Extract domain from abuse email address | |||||
| 1134 | 15 1 | 43 15 | ($dom) = ($c->{address} // '') =~ /\@([\w.-]+)/; | |||
| 1135 | } | |||||
| 1136 | 15 1 | 45 3190 | $covered{lc $dom}++ if $dom; | |||
| 1137 | } | |||||
| 1138 | ||||||
| 1139 | # Also mark URL hosts that already have a resolved abuse address | |||||
| 1140 | 36 1 | 392 1 | for my $u ($self->embedded_urls()) { | |||
| 1141 | 19 1 | 47 45 | (my $bare = lc $u->{host}) =~ s/^www\.//; | |||
| 1142 | 16 1 | 60 2382 | $covered{$bare}++ if $u->{abuse} && $u->{abuse} ne '(unknown)'; | |||
| 1143 | } | |||||
| 1144 | ||||||
| 1145 | 36 1 | 1345 1 | my (@out, %seen); | |||
| 1146 | ||||||
| 1147 | # Check URL hosts first | |||||
| 1148 | 36 1 | 66 15 | for my $u ($self->embedded_urls()) { | |||
| 1149 | 16 1 | 35 975 | (my $bare = lc $u->{host}) =~ s/^www\.//; | |||
| 1150 | 19 1 | 1061 1 | next if $covered{$bare}; | |||
| 1151 | 15 1 | 48 11 | next if $seen{"url:$bare"}++; | |||
| 1152 | push @out, { | |||||
| 1153 | domain => $u->{host}, | |||||
| 1154 | 11 1 | 38 1437 | type => 'url_host', | |||
| 1155 | source => 'URL in body', | |||||
| 1156 | }; | |||||
| 1157 | } | |||||
| 1158 | ||||||
| 1159 | # Then check contact domains, skipping spoofable-header-only sources | |||||
| 1160 | 36 1 | 1004 2 | for my $d ($self->mailto_domains()) { | |||
| 1161 | 40 1 | 44 9 | my $dom = $d->{domain}; | |||
| 1162 | 40 1 | 58 934 | my $source = $d->{source} // ''; | |||
| 1163 | 40 1 | 94 1 | next if $source =~ /^(?:From:|Return-Path:|Sender:) header$/; | |||
| 1164 | 14 1 | 50 10 | next if $covered{lc $dom}; | |||
| 1165 | 10 1 | 28 592 | next if $seen{"dom:$dom"}++; | |||
| 1166 | 13 1 | 976 2 | push @out, { | |||
| 1167 | domain => $dom, | |||||
| 1168 | type => 'domain', | |||||
| 1169 | source => $source, | |||||
| 1170 | }; | |||||
| 1171 | } | |||||
| 1172 | ||||||
| 1173 | 36 1 | 129 10 | return @out; | |||
| 1174 | } | |||||
| 1175 | ||||||
| 1176 | # ----------------------------------------------------------------------- | |||||
| 1177 | # Public: sending software fingerprint | |||||
| 1178 | # ----------------------------------------------------------------------- | |||||
| 1179 | ||||||
| 1180 - 1234 | =head2 sending_software()
Returns information extracted from headers that identify the software or
server-side infrastructure used to compose or inject the message. Headers
such as C<X-PHP-Originating-Script> reveal the exact PHP script and Unix
account responsible on shared-hosting platforms.
Data is extracted during C<parse_email()> with no network I/O.
=head3 Usage
my @sw = $analyser->sending_software();
for my $s (@sw) {
printf "%-30s : %s\n", $s->{header}, $s->{value};
}
=head3 Arguments
None. C<parse_email()> must have been called first.
=head3 Returns
A list of hashrefs in alphabetical header-name order. Returns an empty
list if none of the watched headers are present. Each hashref has keys
C<header>, C<value>, and C<note>.
=head3 Side Effects
None. Data is pre-collected during C<parse_email()>.
=head3 Notes
Header names are lower-cased. Header values are stored verbatim.
=head3 API Specification
=head4 Input
[]
=head4 Output
(
{
type => 'hashref',
keys => {
header => { type => 'string' },
value => { type => 'string' },
note => { type => 'string' },
},
},
...
)
=cut | |||||
| 1235 | ||||||
| 1236 | sub sending_software { | |||||
| 1237 | 97 1 | 284 994 | my $self = $_[0]; | |||
| 1238 | ||||||
| 1239 | 97 97 1 1 | 96 159 2 12 | return @{ $self->{_sending_sw} }; | |||
| 1240 | } | |||||
| 1241 | ||||||
| 1242 | # ----------------------------------------------------------------------- | |||||
| 1243 | # Public: per-hop tracking IDs | |||||
| 1244 | # ----------------------------------------------------------------------- | |||||
| 1245 | ||||||
| 1246 - 1302 | =head2 received_trail()
Returns per-hop tracking data extracted from the C<Received:> header chain:
the IP address, envelope recipient address, and server session ID for each
relay. ISP postmasters use these identifiers to locate the SMTP session in
their logs.
=head3 Usage
my @trail = $analyser->received_trail();
for my $hop (@trail) {
printf "IP: %s ID: %s\n",
$hop->{ip} // '?', $hop->{id} // '?';
}
=head3 Arguments
None. C<parse_email()> must have been called first.
=head3 Returns
A list of hashrefs in oldest-first order. Returns an empty list if no
C<Received:> headers are present or none yielded extractable data. Each
hashref has keys C<received>, C<ip> (may be undef), C<for> (may be undef),
C<id> (may be undef).
=head3 Side Effects
None. Data is pre-collected during C<parse_email()>.
=head3 Notes
Private IPs are NOT filtered here; all IPs including RFC 1918 addresses
are returned as found. Filtering is applied only by C<originating_ip()>.
=head3 API Specification
=head4 Input
[]
=head4 Output
(
{
type => 'hashref',
keys => {
received => { type => 'string' },
ip => { type => 'string', optional => 1 },
for => { type => 'string', optional => 1 },
id => { type => 'string', optional => 1 },
},
},
...
)
=cut | |||||
| 1303 | ||||||
| 1304 | sub received_trail { | |||||
| 1305 | 93 1 | 289 1089 | my $self = $_[0]; | |||
| 1306 | ||||||
| 1307 | 96 96 1 1 | 987 185 1 11 | return @{ $self->{_rcvd_tracking} }; | |||
| 1308 | } | |||||
| 1309 | ||||||
| 1310 | # ----------------------------------------------------------------------- | |||||
| 1311 | # Public: risk assessment | |||||
| 1312 | # ----------------------------------------------------------------------- | |||||
| 1313 | ||||||
| 1314 - 1369 | =head2 risk_assessment()
Evaluates the message against heuristic checks and returns an overall risk
level, a weighted numeric score, and a list of every specific red flag.
The assessment covers five categories: originating IP, email authentication,
Date: header validity, identity/header consistency, and URL/domain properties.
The result is cached; subsequent calls return the same hashref without
repeating any analysis.
=head3 Usage
my $risk = $analyser->risk_assessment();
printf "Risk: %s (score: %d)\n", $risk->{level}, $risk->{score};
for my $f (@{ $risk->{flags} }) {
printf " [%s] %s\n", $f->{severity}, $f->{detail};
}
=head3 Arguments
None. C<parse_email()> must have been called first.
=head3 Returns
A hashref with keys C<level> (HIGH/MEDIUM/LOW/INFO), C<score> (integer),
and C<flags> (arrayref of hashrefs with C<severity>, C<flag>, C<detail>).
=head3 Side Effects
Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()>
if not already cached.
=head3 Notes
Scores: HIGH >= 9, MEDIUM >= 5, LOW >= 2, INFO < 2.
Flag weights: HIGH=3, MEDIUM=2, LOW=1, INFO=0.
=head3 API Specification
=head4 Input
[]
=head4 Output
{
type => 'hashref',
keys => {
level => { type => 'string', memberof => ['HIGH', 'MEDIUM', 'LOW', 'INFO'] },
score => { type => 'integer' },
flags => { type => 'arrayref' },
},
}
=cut | |||||
| 1370 | ||||||
| 1371 | sub risk_assessment { | |||||
| 1372 | 399 1 | 9137 1240 | my $self = $_[0]; | |||
| 1373 | ||||||
| 1374 | 402 1 | 19253 2 | return $self->{_risk} if $self->{_risk}; | |||
| 1375 | ||||||
| 1376 | 376 1 | 313 12 | my (@flags, $score); | |||
| 1377 | 376 1 | 347 814 | $score = 0; | |||
| 1378 | ||||||
| 1379 | # Closure to record a flag and accumulate its weight | |||||
| 1380 | my $flag = sub { | |||||
| 1381 | 384 1 | 454 14 | my ($severity, $name, $detail) = @_; | |||
| 1382 | 384 1 | 948 1440 | $score += $FLAG_WEIGHT{$severity} // 1; | |||
| 1383 | 384 1 | 4813 2 | push @flags, { severity => $severity, flag => $name, detail => $detail }; | |||
| 1384 | 376 1 | 5108 1 | }; | |||
| 1385 | ||||||
| 1386 | 376 1 | 652 12 | $self->_risk_check_origin($flag); | |||
| 1387 | 376 1 | 654 1079 | $self->_risk_check_auth($flag); | |||
| 1388 | 376 1 | 4638 2 | $self->_risk_check_date($flag); | |||
| 1389 | 376 1 | 643 12 | $self->_risk_check_identity($flag); | |||
| 1390 | 376 1 | 660 2150 | $self->_risk_check_urls_and_domains($flag); | |||
| 1391 | ||||||
| 1392 | # Determine overall risk level from accumulated score | |||||
| 1393 | 376 1 | 5224 2 | my $level = $score >= $SCORE_HIGH ? 'HIGH' | |||
| 1394 | : $score >= $SCORE_MEDIUM ? 'MEDIUM' | |||||
| 1395 | : $score >= $SCORE_LOW ? 'LOW' | |||||
| 1396 | : 'INFO'; | |||||
| 1397 | ||||||
| 1398 | 376 1 | 750 10 | $self->{_risk} = { level => $level, score => $score, flags => \@flags }; | |||
| 1399 | 376 1 | 1258 1814 | return $self->{_risk}; | |||
| 1400 | } | |||||
| 1401 | ||||||
| 1402 | # _risk_check_origin( $flag ) | |||||
| 1403 | # | |||||
| 1404 | # Purpose: | |||||
| 1405 | # Evaluate the originating IP for residential rDNS, absent rDNS, | |||||
| 1406 | # low-confidence origin, and high-spam-volume country. | |||||
| 1407 | # | |||||
| 1408 | # Entry criteria: | |||||
| 1409 | # $flag -- coderef( severity, name, detail ) that accumulates flags. | |||||
| 1410 | # | |||||
| 1411 | # Exit status: | |||||
| 1412 | # Returns nothing; side effects via $flag closure. | |||||
| 1413 | ||||||
| 1414 | sub _risk_check_origin :Private { | |||||
| 1415 | my ($self, $flag) = @_; | |||||
| 1416 | my $orig = $self->originating_ip(); | |||||
| 1417 | return unless $orig; | |||||
| 1418 | ||||||
| 1419 | return if(!defined($orig->{ip})); | |||||
| 1420 | ||||||
| 1421 | # Residential / broadband rDNS patterns suggest a compromised host | |||||
| 1422 | if ($orig->{rdns} && $orig->{rdns} =~ / | |||||
| 1423 | \d+[-_.]\d+[-_.]\d+[-_.]\d+ # dotted-quad in rDNS | |||||
| 1424 | | (?:dsl|adsl|cable|broad|dial|dynamic|dhcp|ppp| | |||||
| 1425 | residential|cust|home|pool|client|user| | |||||
| 1426 | static\d|host\d) | |||||
| 1427 | /xi) { | |||||
| 1428 | $flag->('HIGH', 'residential_sending_ip', | |||||
| 1429 | "Sending IP $orig->{ip} rDNS '$orig->{rdns}' looks like a broadband/residential line, not a legitimate mail server"); | |||||
| 1430 | } | |||||
| 1431 | ||||||
| 1432 | # Absence of rDNS is a strong spam indicator | |||||
| 1433 | if (!$orig->{rdns} || $orig->{rdns} eq '(no reverse DNS)') { | |||||
| 1434 | $flag->('HIGH', 'no_reverse_dns', | |||||
| 1435 | "Sending IP $orig->{ip} has no reverse DNS -- legitimate mail servers always have rDNS"); | |||||
| 1436 | } | |||||
| 1437 | ||||||
| 1438 | # Low-confidence origin means the IP came from an unverifiable header | |||||
| 1439 | if ($orig->{confidence} eq 'low') { | |||||
| 1440 | $flag->('MEDIUM', 'low_confidence_origin', | |||||
| 1441 | "Originating IP taken from unverified header ($orig->{note})"); | |||||
| 1442 | } | |||||
| 1443 | ||||||
| 1444 | # Statistically high-volume spam countries (informational only) | |||||
| 1445 | if ($orig->{country} && $orig->{country} =~ /^(?:CN|RU|NG|VN|IN|PK|BD)$/) { | |||||
| 1446 | $flag->('INFO', 'high_spam_country', | |||||
| 1447 | 'Sending IP is in ' . _country_name($orig->{country}) . | |||||
| 1448 | " ($orig->{country}) -- statistically high spam volume country"); | |||||
| 1449 | } | |||||
| 1450 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 | 48181 23 573 5 31 4789 2 12 983 2 11 2640 2 12 1029 270 2 2 646 3 0 373 3 1 | } | |||
| 1451 | ||||||
| 1452 | # _risk_check_auth( $flag ) | |||||
| 1453 | # | |||||
| 1454 | # Purpose: | |||||
| 1455 | # Evaluate SPF, DKIM, DMARC results and DKIM signing domain alignment. | |||||
| 1456 | # | |||||
| 1457 | # Entry criteria: | |||||
| 1458 | # $flag -- accumulator coderef. | |||||
| 1459 | # | |||||
| 1460 | # Exit status: | |||||
| 1461 | # Returns nothing; side effects via $flag closure. | |||||
| 1462 | ||||||
| 1463 | sub _risk_check_auth :Private { | |||||
| 1464 | my ($self, $flag) = @_; | |||||
| 1465 | my $auth = $self->_parse_auth_results_cached(); | |||||
| 1466 | ||||||
| 1467 | if (defined $auth->{spf}) { | |||||
| 1468 | if ($auth->{spf} =~ /^fail/i) { | |||||
| 1469 | $flag->('HIGH', 'spf_fail', | |||||
| 1470 | "SPF result: $auth->{spf} -- sending IP not authorised by domain's SPF record"); | |||||
| 1471 | } elsif ($auth->{spf} =~ /^softfail/i) { | |||||
| 1472 | $flag->('MEDIUM', 'spf_softfail', | |||||
| 1473 | "SPF result: softfail (~all) -- sending IP not explicitly authorised"); | |||||
| 1474 | } elsif ($auth->{spf} !~ /^pass/i) { | |||||
| 1475 | $flag->('HIGH', 'spf_fail', | |||||
| 1476 | "SPF result: $auth->{spf} -- sending IP not authorised"); | |||||
| 1477 | } | |||||
| 1478 | } | |||||
| 1479 | if (defined $auth->{dkim} && $auth->{dkim} !~ /^pass/i) { | |||||
| 1480 | $flag->('HIGH', 'dkim_fail', | |||||
| 1481 | "DKIM result: $auth->{dkim} -- message signature invalid or absent"); | |||||
| 1482 | } | |||||
| 1483 | if (defined $auth->{dmarc} && $auth->{dmarc} !~ /^pass/i) { | |||||
| 1484 | $flag->('HIGH', 'dmarc_fail', "DMARC result: $auth->{dmarc}"); | |||||
| 1485 | } | |||||
| 1486 | ||||||
| 1487 | # DKIM signing domain vs From: domain mismatch check | |||||
| 1488 | return unless $auth->{dkim_domain}; | |||||
| 1489 | my ($from_domain) = ($self->_header_value('from') // '') =~ /\@([\w.-]+)/; | |||||
| 1490 | return unless $from_domain; | |||||
| 1491 | my $reg_dkim = _registrable($auth->{dkim_domain}) // $auth->{dkim_domain}; | |||||
| 1492 | my $reg_from = _registrable(lc $from_domain) // lc $from_domain; | |||||
| 1493 | return if $reg_dkim eq $reg_from; | |||||
| 1494 | ||||||
| 1495 | # Passing DKIM with a different domain is normal for ESPs | |||||
| 1496 | if ($auth->{dkim} && $auth->{dkim} =~ /^pass/i) { | |||||
| 1497 | $flag->('INFO', 'dkim_domain_mismatch', | |||||
| 1498 | "DKIM signed by '$auth->{dkim_domain}' but From: domain is '$from_domain'" | |||||
| 1499 | . ' -- message sent via third-party sender (normal for bulk/ESP mail)'); | |||||
| 1500 | } else { | |||||
| 1501 | # Failing DKIM plus mismatched domain is more suspicious | |||||
| 1502 | $flag->('MEDIUM', 'dkim_domain_mismatch', | |||||
| 1503 | "DKIM signed by '$auth->{dkim_domain}' but From: domain is '$from_domain'" | |||||
| 1504 | . ' and DKIM did not pass -- possible impersonation'); | |||||
| 1505 | } | |||||
| 1506 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 0 1 1 0 1 1 0 | 12209 24 291 4 38 4090 2 15 1403 2 11 1549 2 14 1379 2 3 0 682 4 0 2 5 0 | } | |||
| 1507 | ||||||
| 1508 | # _risk_check_date( $flag ) | |||||
| 1509 | # | |||||
| 1510 | # Purpose: | |||||
| 1511 | # Validate the Date: header for presence, plausible timezone, and | |||||
| 1512 | # date not too far in the past or future. | |||||
| 1513 | # | |||||
| 1514 | # Entry criteria: | |||||
| 1515 | # $flag -- accumulator coderef. | |||||
| 1516 | # | |||||
| 1517 | # Exit status: | |||||
| 1518 | # Returns nothing; side effects via $flag closure. | |||||
| 1519 | ||||||
| 1520 | sub _risk_check_date :Private { | |||||
| 1521 | my ($self, $flag) = @_; | |||||
| 1522 | my $date_raw = $self->_header_value('date'); | |||||
| 1523 | ||||||
| 1524 | if (!$date_raw || $date_raw !~ /\S/) { | |||||
| 1525 | $flag->('MEDIUM', 'missing_date', | |||||
| 1526 | 'No Date: header -- violates RFC 5322; common in spam'); | |||||
| 1527 | return; | |||||
| 1528 | } | |||||
| 1529 | ||||||
| 1530 | # Check for an implausible timezone offset (outside real-world bounds) | |||||
| 1531 | if ($date_raw =~ /([+-])(\d{2})(\d{2})\s*$/) { | |||||
| 1532 | my ($sign, $hh, $mm) = ($1, $2, $3); | |||||
| 1533 | my $offset_mins = $hh * 60 + $mm; | |||||
| 1534 | my $implausible = $mm >= 60 | |||||
| 1535 | || ($sign eq '+' && $offset_mins > $TZ_MAX_POS_MINS) | |||||
| 1536 | || ($sign eq '-' && $offset_mins > $TZ_MAX_NEG_MINS); | |||||
| 1537 | if ($implausible) { | |||||
| 1538 | $flag->('MEDIUM', 'implausible_timezone', | |||||
| 1539 | "Date: '$date_raw' contains an implausible timezone offset " | |||||
| 1540 | . "($sign$hh$mm) -- header is likely forged"); | |||||
| 1541 | } | |||||
| 1542 | } | |||||
| 1543 | ||||||
| 1544 | # Check for dates more than DATE_SKEW_DAYS outside the analysis window | |||||
| 1545 | my $date_epoch = _parse_rfc2822_date($date_raw); | |||||
| 1546 | return unless defined $date_epoch; | |||||
| 1547 | my $delta = time() - $date_epoch; | |||||
| 1548 | if ($delta > $DATE_SKEW_DAYS * $SECS_PER_DAY) { | |||||
| 1549 | $flag->('LOW', 'suspicious_date', | |||||
| 1550 | "Date: '$date_raw' is more than $DATE_SKEW_DAYS days in the past"); | |||||
| 1551 | } elsif ($delta < -($DATE_SKEW_DAYS * $SECS_PER_DAY)) { | |||||
| 1552 | $flag->('LOW', 'suspicious_date', | |||||
| 1553 | "Date: '$date_raw' is more than $DATE_SKEW_DAYS days in the future"); | |||||
| 1554 | } | |||||
| 1555 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 0 1 1 0 1 1 0 | 8133 23 228 3 32 4502 1 12 1231 2 13 1958 1 12 1294 260 3 0 671 3 0 419 6 0 | } | |||
| 1556 | ||||||
| 1557 | # _risk_check_identity( $flag ) | |||||
| 1558 | # | |||||
| 1559 | # Purpose: | |||||
| 1560 | # Check From: display-name spoofing, free webmail, Reply-To mismatch, | |||||
| 1561 | # undisclosed recipients, and MIME-encoded Subject. | |||||
| 1562 | # | |||||
| 1563 | # Entry criteria: | |||||
| 1564 | # $flag -- accumulator coderef. | |||||
| 1565 | # | |||||
| 1566 | # Exit status: | |||||
| 1567 | # Returns nothing; side effects via $flag closure. | |||||
| 1568 | ||||||
| 1569 | sub _risk_check_identity :Private { | |||||
| 1570 | my ($self, $flag) = @_; | |||||
| 1571 | my $from_raw = $self->_header_value('from') // ''; | |||||
| 1572 | my $from_decoded = $self->_decode_mime_words($from_raw); | |||||
| 1573 | ||||||
| 1574 | # Display-name domain spoofing: "PayPal paypal.com" <phish@evil.example> | |||||
| 1575 | if ($from_decoded =~ /^"?([^"<]+?)"?\s*<([^>]+)>/) { | |||||
| 1576 | my ($display, $addr) = ($1, $2); | |||||
| 1577 | while ($display =~ /\b([\w-]+\.(?:com|net|org|io|co|uk|au|gov|edu))\b/gi) { | |||||
| 1578 | my $disp_domain = lc $1; | |||||
| 1579 | my ($addr_domain) = $addr =~ /\@([\w.-]+)/; | |||||
| 1580 | $addr_domain = lc($addr_domain // ''); | |||||
| 1581 | my $reg_disp = _registrable($disp_domain); | |||||
| 1582 | my $reg_addr = _registrable($addr_domain); | |||||
| 1583 | if ($reg_disp && $reg_addr && $reg_disp ne $reg_addr) { | |||||
| 1584 | $flag->('HIGH', 'display_name_domain_spoof', | |||||
| 1585 | "From: display name mentions '$disp_domain' but actual address is <$addr>"); | |||||
| 1586 | } | |||||
| 1587 | } | |||||
| 1588 | } | |||||
| 1589 | ||||||
| 1590 | # Free webmail sender flag (no corporate infrastructure) | |||||
| 1591 | if ($from_raw =~ /\@(gmail|yahoo|hotmail|outlook|live|aol|protonmail|yandex)\./i | |||||
| 1592 | || $from_raw =~ /\@mail\.ru(?:[\s>]|$)/i) { | |||||
| 1593 | $flag->('MEDIUM', 'free_webmail_sender', | |||||
| 1594 | "Message sent from free webmail address ($from_raw)"); | |||||
| 1595 | } | |||||
| 1596 | ||||||
| 1597 | # Reply-To differs from From: -- replies harvested by different address | |||||
| 1598 | my $reply_to = $self->_header_value('reply-to'); | |||||
| 1599 | if ($reply_to) { | |||||
| 1600 | my ($from_addr) = $from_raw =~ /([\w.+%-]+\@[\w.-]+)/; | |||||
| 1601 | my ($reply_addr) = $reply_to =~ /([\w.+%-]+\@[\w.-]+)/; | |||||
| 1602 | if ($from_addr && $reply_addr && lc($from_addr) ne lc($reply_addr)) { | |||||
| 1603 | $flag->('MEDIUM', 'reply_to_differs_from_from', | |||||
| 1604 | "Reply-To ($reply_addr) differs from From: ($from_addr)"); | |||||
| 1605 | } | |||||
| 1606 | } | |||||
| 1607 | ||||||
| 1608 | # Undisclosed or absent To: header | |||||
| 1609 | my $to = $self->_header_value('to') // ''; | |||||
| 1610 | if ($to =~ /undisclosed|:;/ || $to eq '') { | |||||
| 1611 | $flag->('MEDIUM', 'undisclosed_recipients', | |||||
| 1612 | "To: header is '$to' -- message was bulk-sent with hidden recipient list"); | |||||
| 1613 | } | |||||
| 1614 | ||||||
| 1615 | # MIME-encoded Subject (potential filter evasion) | |||||
| 1616 | my $subj_raw = $self->_header_value('subject') // ''; | |||||
| 1617 | if ($subj_raw =~ /=\?[^?]+\?[BQ]\?/i) { | |||||
| 1618 | $flag->('LOW', 'encoded_subject', | |||||
| 1619 | "Subject line is MIME-encoded: '$subj_raw' (decoded: '" | |||||
| 1620 | . $self->_decode_mime_words($subj_raw) . "')"); | |||||
| 1621 | } | |||||
| 1622 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 15340 22 254 4 42 4150 1 13 2110 1 11 1494 1 13 1949 6083 2 27 5782 5 24 6562 1 29 | } | |||
| 1623 | ||||||
| 1624 | # _risk_check_urls_and_domains( $flag ) | |||||
| 1625 | # | |||||
| 1626 | # Purpose: | |||||
| 1627 | # Check embedded URLs for shorteners and plain HTTP, and contact domains | |||||
| 1628 | # for recent registration, imminent expiry, and lookalike brand names. | |||||
| 1629 | # | |||||
| 1630 | # Entry criteria: | |||||
| 1631 | # $flag -- accumulator coderef. | |||||
| 1632 | # | |||||
| 1633 | # Exit status: | |||||
| 1634 | # Returns nothing; side effects via $flag closure. | |||||
| 1635 | ||||||
| 1636 | sub _risk_check_urls_and_domains :Private { | |||||
| 1637 | my ($self, $flag) = @_; | |||||
| 1638 | my (%shortener_seen, %cloaker_seen, %url_host_seen); | |||||
| 1639 | ||||||
| 1640 | for my $u ($self->embedded_urls()) { | |||||
| 1641 | # Skip trusted infrastructure -- these are not spam indicators | |||||
| 1642 | next unless($u->{host}); | |||||
| 1643 | my $bare = lc $u->{host}; | |||||
| 1644 | next unless defined($bare); | |||||
| 1645 | $bare =~ s/^www\.//; | |||||
| 1646 | next if $self->{trusted_domains}->{$bare}; | |||||
| 1647 | next if $TRUSTED_DOMAINS{$bare}; | |||||
| 1648 | ||||||
| 1649 | # URL shortener hides real destination | |||||
| 1650 | if(($URL_SHORTENERS{$bare} || $self->{url_shorteners}->{$bare}) && !$shortener_seen{$bare}++) { | |||||
| 1651 | $flag->('MEDIUM', 'url_shortener', | |||||
| 1652 | "$u->{host} is a URL shortener -- the real destination is hidden"); | |||||
| 1653 | } | |||||
| 1654 | # Cloud object-store / CDN used as a redirect cloaker | |||||
| 1655 | if ($self->_is_redirect_cloaker($bare) && !$cloaker_seen{$bare}++) { | |||||
| 1656 | $flag->('MEDIUM', 'redirect_cloaker', | |||||
| 1657 | "$u->{host} is a cloud storage or CDN host used as a redirect cloaker -- the real phishing destination is hidden behind a client-side redirect"); | |||||
| 1658 | } | |||||
| 1659 | # Plain HTTP provides no encryption | |||||
| 1660 | if ($u->{url} =~ m{^http://}i && !$url_host_seen{ $u->{host} }++) { | |||||
| 1661 | $flag->('LOW', 'http_not_https', | |||||
| 1662 | "$u->{host} linked over plain HTTP -- no encryption"); | |||||
| 1663 | } | |||||
| 1664 | } | |||||
| 1665 | ||||||
| 1666 | # Domain-level checks against contact/reply domains | |||||
| 1667 | for my $d ($self->mailto_domains()) { | |||||
| 1668 | # Recently registered domain is a common phishing indicator | |||||
| 1669 | if ($d->{recently_registered}) { | |||||
| 1670 | $flag->('HIGH', 'recently_registered_domain', | |||||
| 1671 | "$d->{domain} was registered $d->{registered} (less than ${\$RECENT_REG_DAYS} days ago)"); | |||||
| 1672 | } | |||||
| 1673 | ||||||
| 1674 | # Domain expiry checks | |||||
| 1675 | if ($d->{expires}) { | |||||
| 1676 | if(my $exp = $self->_parse_date_to_epoch($d->{expires})) { | |||||
| 1677 | my $now = time(); | |||||
| 1678 | my $remaining = $exp - $now; | |||||
| 1679 | if ($remaining > 0 && $remaining < $EXPIRY_WARN_DAYS * $SECS_PER_DAY) { | |||||
| 1680 | $flag->('HIGH', 'domain_expires_soon', | |||||
| 1681 | "$d->{domain} expires $d->{expires} -- may be a throwaway domain"); | |||||
| 1682 | } elsif ($remaining <= 0) { | |||||
| 1683 | $flag->('HIGH', 'domain_expired', | |||||
| 1684 | "$d->{domain} expired $d->{expires} -- domain has lapsed"); | |||||
| 1685 | } | |||||
| 1686 | } | |||||
| 1687 | } | |||||
| 1688 | ||||||
| 1689 | # Lookalike domain check (brand name in a non-brand domain) | |||||
| 1690 | for my $brand (@LOOKALIKE_BRANDS) { | |||||
| 1691 | next if(!defined($d->{domain})); | |||||
| 1692 | if ($d->{domain} =~ /\Q$brand\E/i && | |||||
| 1693 | $d->{domain} !~ /^\Q$brand\E\.(?:com|co\.uk|net|org)$/) { | |||||
| 1694 | $flag->('HIGH', 'lookalike_domain', | |||||
| 1695 | "$d->{domain} contains brand name '$brand' but is not the real domain -- possible phishing"); | |||||
| 1696 | last; | |||||
| 1697 | } | |||||
| 1698 | } | |||||
| 1699 | } | |||||
| 1700 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 9766 29 217 4 62 4054 2 13 1754 2 11 1181 1 12 1720 1501 2 19 880 2 21 1936 2 18 | } | |||
| 1701 | ||||||
| 1702 | # ----------------------------------------------------------------------- | |||||
| 1703 | # Public: abuse report text | |||||
| 1704 | # ----------------------------------------------------------------------- | |||||
| 1705 | ||||||
| 1706 - 1753 | =head2 abuse_report_text()
Produces a compact, plain-text string suitable for sending as the body of
an abuse report email. It summarises risk level, red flags, originating IP,
abuse contacts, and original message headers. The message body is omitted
to keep the report concise.
Use C<abuse_contacts()> to get the recipient addresses and this method for
the body text.
=head3 Usage
my $text = $analyser->abuse_report_text();
my @contacts = $analyser->abuse_contacts();
for my $c (@contacts) {
send_email(to => $c->{address}, body => $text);
}
=head3 Arguments
None. C<parse_email()> must have been called first.
=head3 Returns
A plain scalar string, newline-terminated, Unix line endings. Never empty
or undef.
=head3 Side Effects
Calls C<risk_assessment()>, C<originating_ip()>, and C<abuse_contacts()>
if not already cached.
=head3 Notes
Output text is sanitised: control characters that could affect terminal or
HTML rendering are stripped from all user-derived content before inclusion.
=head3 API Specification
=head4 Input
[]
=head4 Output
{ type => 'string' }
=cut | |||||
| 1754 | ||||||
| 1755 | sub abuse_report_text { | |||||
| 1756 | 22 1 | 9779 1 | my $self = $_[0]; | |||
| 1757 | 22 1 | 26 13 | my @out; | |||
| 1758 | ||||||
| 1759 | 22 1 | 95 1593 | push @out, 'This is an automated abuse report generated by Email::Abuse::Investigator.', | |||
| 1760 | 'Please investigate the following spam/phishing message.', | |||||
| 1761 | ''; | |||||
| 1762 | ||||||
| 1763 | 22 1 | 10544 1 | my $risk = $self->risk_assessment(); | |||
| 1764 | 22 1 | 47 14 | push @out, "RISK LEVEL: $risk->{level} (score: $risk->{score})", | |||
| 1765 | ''; | |||||
| 1766 | ||||||
| 1767 | # List each red flag with its severity prefix | |||||
| 1768 | 22 22 1 1 | 51 4750 694 2 | if (@{ $risk->{flags} }) { | |||
| 1769 | 13 1 | 17 11 | push @out, 'RED FLAGS IDENTIFIED:'; | |||
| 1770 | 13 13 1 1 | 52 4749 669 1 | for my $f (@{ $risk->{flags} }) { | |||
| 1771 | 19 1 | 39 12 | push @out, " [$f->{severity}] " . _sanitise_output($f->{detail}); | |||
| 1772 | } | |||||
| 1773 | 13 1 | 51 1252 | push @out, ''; | |||
| 1774 | } | |||||
| 1775 | ||||||
| 1776 | # Originating IP summary block | |||||
| 1777 | 22 1 | 3599 1 | my $orig = $self->originating_ip(); | |||
| 1778 | 22 1 | 30 14 | if ($orig) { | |||
| 1779 | push @out, 'ORIGINATING IP: ' . _sanitise_output("$orig->{ip} ($orig->{rdns})"), | |||||
| 1780 | 15 1 | 61 1315 | 'NETWORK OWNER: ' . _sanitise_output($orig->{org}), | |||
| 1781 | ''; | |||||
| 1782 | } | |||||
| 1783 | ||||||
| 1784 | # List every reported URL so the receiving abuse desk knows exactly | |||||
| 1785 | # which resources to investigate or suspend. | |||||
| 1786 | 22 1 | 4397 1 | my @urls = $self->embedded_urls(); | |||
| 1787 | 22 1 | 34 12 | if (@urls) { | |||
| 1788 | 7 1 | 65 1357 | push @out, 'REPORTED URLs:'; | |||
| 1789 | 7 1 | 2901 2 | for my $u (@urls) { | |||
| 1790 | 7 1 | 11 13 | push @out, ' ' . _sanitise_output($u->{url}); | |||
| 1791 | 7 1 | 39 1726 | my @meta; | |||
| 1792 | 7 1 | 3136 1 | push @meta, "host: $u->{host}" if $u->{host}; | |||
| 1793 | 7 1 | 18 12 | push @meta, "IP: $u->{ip}" if $u->{ip} && $u->{ip} ne '(unresolved)'; | |||
| 1794 | 7 1 | 56 1235 | push @meta, "org: $u->{org}" if $u->{org} && $u->{org} ne '(unknown)'; | |||
| 1795 | 7 1 | 3086 1 | push @out, ' (' . join(' ', @meta) . ')' if @meta; | |||
| 1796 | } | |||||
| 1797 | 7 1 | 8 12 | push @out, ''; | |||
| 1798 | } | |||||
| 1799 | ||||||
| 1800 | # Email abuse contacts | |||||
| 1801 | 22 1 | 75 946 | my @contacts = $self->abuse_contacts(); | |||
| 1802 | 22 1 | 4510 1 | if (@contacts) { | |||
| 1803 | 17 1 | 18 15 | push @out, 'ABUSE CONTACTS:'; | |||
| 1804 | 17 1 | 70 1753 | push @out, ' ' . _sanitise_output("$_->{address} ($_->{role})") for @contacts; | |||
| 1805 | 17 1 | 3020 2 | push @out, ''; | |||
| 1806 | } | |||||
| 1807 | ||||||
| 1808 | # Web-form contacts (providers that reject email) | |||||
| 1809 | 22 1 | 35 15 | if(my @form_cs = $self->form_contacts()) { | |||
| 1810 | 4 1 | 33 1029 | push @out, 'WEB-FORM REPORTS REQUIRED:', | |||
| 1811 | ' The following parties do not accept email -- submit manually:'; | |||||
| 1812 | 4 1 | 4700 1 | for my $c (@form_cs) { | |||
| 1813 | push @out, " [$c->{role}]", | |||||
| 1814 | 4 1 | 7 12 | ' Form : ' . _sanitise_output($c->{form}); | |||
| 1815 | 4 1 | 38 1460 | push @out, ' Domain : ' . _sanitise_output($c->{form_domain}) if $c->{form_domain}; | |||
| 1816 | 4 1 | 4730 1 | push @out, ' Paste : ' . _sanitise_output($c->{form_paste}) if $c->{form_paste}; | |||
| 1817 | 4 1 | 6 11 | push @out, ' Upload : ' . _sanitise_output($c->{form_upload}) if $c->{form_upload}; | |||
| 1818 | } | |||||
| 1819 | 4 1 | 42 599 | push @out, ''; | |||
| 1820 | } | |||||
| 1821 | ||||||
| 1822 | # Separator and raw headers (body excluded for brevity) | |||||
| 1823 | 22 1 | 3840 2 | push @out, '-' x 72, | |||
| 1824 | 'ORIGINAL MESSAGE HEADERS:', | |||||
| 1825 | '-' x 72; | |||||
| 1826 | ||||||
| 1827 | 22 22 1 1 | 25 58 12 753 | for my $h (@{ $self->{_headers} }) { | |||
| 1828 | 133 1 | 4993 2 | push @out, _sanitise_output("$h->{name}: $h->{value}"); | |||
| 1829 | } | |||||
| 1830 | 22 1 | 26 12 | push @out, ''; | |||
| 1831 | ||||||
| 1832 | 22 1 | 113 1151 | return join("\n", @out); | |||
| 1833 | } | |||||
| 1834 | ||||||
| 1835 | # ----------------------------------------------------------------------- | |||||
| 1836 | # Public: abuse contacts | |||||
| 1837 | # ----------------------------------------------------------------------- | |||||
| 1838 | ||||||
| 1839 - 1898 | =head2 abuse_contacts()
Collates the complete set of parties that should receive an abuse report:
the sending ISP, URL host operators, contact domain web/mail/DNS/registrar
contacts, account providers identified from key headers, the DKIM signer,
and the ESP identified via List-Unsubscribe.
Addresses are deduplicated globally; if the same address is found via
multiple routes, a single entry is kept and role strings are merged.
=head3 Usage
my @contacts = $analyser->abuse_contacts();
my @addrs = map { $_->{address} } @contacts;
=head3 Arguments
None. C<parse_email()> must have been called first.
=head3 Returns
A list of hashrefs, one per unique abuse address, in discovery order.
Each hashref has keys C<role>, C<roles> (arrayref), C<address>, C<note>,
C<via>. Returns an empty list if no contacts can be determined.
=head3 Side Effects
Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()>
if not already cached.
=head3 Notes
The result is cached on the object; subsequent calls return the same list
without repeating the contact-collection logic. The underlying per-IP and
per-domain lookups are themselves cached by C<originating_ip()>,
C<embedded_urls()>, and C<mailto_domains()>.
=head3 API Specification
=head4 Input
[]
=head4 Output
(
{
type => 'hashref',
keys => {
role => { type => 'string' },
roles => { type => 'arrayref' },
address => { type => 'string', regex => qr/\@/ },
note => { type => 'string' },
via => { type => 'string', memberof => [ 'provider-table', 'ip-whois', 'domain-whois' ] }
},
},
...
)
=cut | |||||
| 1899 | ||||||
| 1900 | sub abuse_contacts { | |||||
| 1901 | 188 1 | 9702 1 | my $self = $_[0]; | |||
| 1902 | 188 1 | 549 13 | $self->{_contacts} //= [ $self->_compute_abuse_contacts() ]; | |||
| 1903 | 188 188 1 1 | 183 5664 1023 2 | return @{ $self->{_contacts} }; | |||
| 1904 | } | |||||
| 1905 | ||||||
| 1906 | # _compute_abuse_contacts() -> list of contact hashrefs | |||||
| 1907 | # | |||||
| 1908 | # Purpose: | |||||
| 1909 | # Actual implementation of abuse_contacts(). Separated so the public | |||||
| 1910 | # method can cache without duplicating logic. | |||||
| 1911 | # | |||||
| 1912 | # Entry criteria: | |||||
| 1913 | # parse_email() must have been called. | |||||
| 1914 | # | |||||
| 1915 | # Exit status: | |||||
| 1916 | # Returns list of deduplicated contact hashrefs. | |||||
| 1917 | ||||||
| 1918 | sub _compute_abuse_contacts :Private { | |||||
| 1919 | my $self = $_[0]; | |||||
| 1920 | ||||||
| 1921 | my (@contacts, %seen_idx); | |||||
| 1922 | ||||||
| 1923 | # Inner closure: add one contact entry, merging roles for duplicate addresses | |||||
| 1924 | my $add = sub { | |||||
| 1925 | my (%args) = @_; | |||||
| 1926 | my $addr = lc($args{address} // ''); | |||||
| 1927 | return unless $addr && $addr =~ /\@/; | |||||
| 1928 | ||||||
| 1929 | # Suppress addresses belonging to form-only providers (no email accepted) | |||||
| 1930 | if ($addr =~ /\@([\w.-]+)$/) { | |||||
| 1931 | my $dom = $1; | |||||
| 1932 | my $pa = $self->_provider_abuse_for_host($dom); | |||||
| 1933 | return if $pa && $pa->{form} && !$pa->{email}; | |||||
| 1934 | } | |||||
| 1935 | ||||||
| 1936 | if (exists $seen_idx{$addr}) { | |||||
| 1937 | # Merge the new role into the existing entry | |||||
| 1938 | my $entry = $contacts[ $seen_idx{$addr} ]; | |||||
| 1939 | push @{ $entry->{roles} }, $args{role}; | |||||
| 1940 | ||||||
| 1941 | # Collapse repeated role labels to avoid unreadable strings | |||||
| 1942 | my (%role_counts, @ordered_roles); | |||||
| 1943 | for my $r (@{ $entry->{roles} }) { | |||||
| 1944 | push @ordered_roles, $r unless $role_counts{$r}++; | |||||
| 1945 | } | |||||
| 1946 | my @display = map { | |||||
| 1947 | $role_counts{$_} > 1 ? "$_ (x$role_counts{$_})" : $_ | |||||
| 1948 | } @ordered_roles; | |||||
| 1949 | my $joined = join(' and ', @display); | |||||
| 1950 | ||||||
| 1951 | # Summarise if the merged string is too long to read. | |||||
| 1952 | # "URL host: hostname" entries are grouped by listing the actual | |||||
| 1953 | # hostnames so the summary is actionable (e.g. "URL host: a.example, | |||||
| 1954 | # b.example" rather than the unhelpful "URL host, URL host"). | |||||
| 1955 | # All other role types fall back to stripping at the first [:(\d] | |||||
| 1956 | # boundary to produce a compact type label. | |||||
| 1957 | if (length($joined) > $ROLE_MAX_LEN) { | |||||
| 1958 | my (@url_hosts, %seen_short, @short); | |||||
| 1959 | for my $r (@display) { | |||||
| 1960 | if ($r =~ /^URL host:\s*(.+)$/) { | |||||
| 1961 | push @url_hosts, $1; | |||||
| 1962 | } else { | |||||
| 1963 | (my $s = $r) =~ s/[:(\d].*//; | |||||
| 1964 | $s =~ s/\s+$//; | |||||
| 1965 | push @short, $s unless $seen_short{$s}++; | |||||
| 1966 | } | |||||
| 1967 | } | |||||
| 1968 | my @parts; | |||||
| 1969 | if (@url_hosts) { | |||||
| 1970 | my $extra = @url_hosts > 3 | |||||
| 1971 | ? ' and ' . (@url_hosts - 3) . ' more' : ''; | |||||
| 1972 | my @shown = @url_hosts > 3 ? @url_hosts[0..2] : @url_hosts; | |||||
| 1973 | push @parts, 'URL host: ' . join(', ', @shown) . $extra; | |||||
| 1974 | } | |||||
| 1975 | push @parts, @short; | |||||
| 1976 | $joined = scalar(@display) . ' routes: ' . join(', ', @parts); | |||||
| 1977 | } | |||||
| 1978 | $entry->{role} = $joined; | |||||
| 1979 | return; | |||||
| 1980 | } | |||||
| 1981 | ||||||
| 1982 | # First time seeing this address -- record and store | |||||
| 1983 | $seen_idx{$addr} = scalar @contacts; | |||||
| 1984 | $args{roles} = [ $args{role} ]; | |||||
| 1985 | push @contacts, \%args; | |||||
| 1986 | }; | |||||
| 1987 | ||||||
| 1988 | # Route 1 -- Sending ISP (originating IP) | |||||
| 1989 | my $orig = $self->originating_ip(); | |||||
| 1990 | if ($orig) { | |||||
| 1991 | my $pa = $self->_provider_abuse_for_ip($orig->{ip}, $orig->{rdns}); | |||||
| 1992 | if ($pa) { | |||||
| 1993 | $add->( | |||||
| 1994 | role => 'Sending ISP', | |||||
| 1995 | address => $pa->{email}, | |||||
| 1996 | note => "$orig->{ip} ($orig->{rdns}) -- $pa->{note}", | |||||
| 1997 | via => 'provider-table', | |||||
| 1998 | ); | |||||
| 1999 | } | |||||
| 2000 | if ($orig->{abuse} && $orig->{abuse} ne '(unknown)') { | |||||
| 2001 | $add->( | |||||
| 2002 | role => 'Sending ISP', | |||||
| 2003 | address => $orig->{abuse}, | |||||
| 2004 | note => "Network owner of originating IP $orig->{ip} ($orig->{org})", | |||||
| 2005 | via => 'ip-whois', | |||||
| 2006 | ); | |||||
| 2007 | } | |||||
| 2008 | } | |||||
| 2009 | ||||||
| 2010 | # Route 2 -- URL hosts | |||||
| 2011 | my %url_host_seen; | |||||
| 2012 | for my $u ($self->embedded_urls()) { | |||||
| 2013 | next if $url_host_seen{ $u->{host} }++; | |||||
| 2014 | my $bare_host = lc $u->{host}; | |||||
| 2015 | $bare_host =~ s/^www\.//; | |||||
| 2016 | # Skip trusted infrastructure (Google, W3C, etc.) | |||||
| 2017 | next if $self->{trusted_domains}->{$bare_host}; | |||||
| 2018 | next if $TRUSTED_DOMAINS{$bare_host}; | |||||
| 2019 | my $pa = $self->_provider_abuse_for_host($u->{host}); | |||||
| 2020 | if ($pa) { | |||||
| 2021 | $add->( | |||||
| 2022 | role => "URL host: $u->{host}", | |||||
| 2023 | address => $pa->{email}, | |||||
| 2024 | note => "$u->{host} -- $pa->{note}", | |||||
| 2025 | via => 'provider-table', | |||||
| 2026 | ); | |||||
| 2027 | } | |||||
| 2028 | if ($u->{abuse} && $u->{abuse} ne '(unknown)') { | |||||
| 2029 | $add->( | |||||
| 2030 | role => "URL host: $u->{host}", | |||||
| 2031 | address => $u->{abuse}, | |||||
| 2032 | note => "Hosting $u->{host} ($u->{ip}, $u->{org})", | |||||
| 2033 | via => 'ip-whois', | |||||
| 2034 | ); | |||||
| 2035 | } | |||||
| 2036 | } | |||||
| 2037 | ||||||
| 2038 | # Route 3 -- Contact domain hosting and registration | |||||
| 2039 | for my $d ($self->mailto_domains()) { | |||||
| 2040 | my $dom = $d->{domain}; | |||||
| 2041 | ||||||
| 2042 | # Web host contact | |||||
| 2043 | if ($d->{web_abuse}) { | |||||
| 2044 | my $pa = $self->_provider_abuse_for_host($dom); | |||||
| 2045 | if ($pa) { | |||||
| 2046 | $add->(role => "Web host of $dom", address => $pa->{email}, | |||||
| 2047 | note => $pa->{note}, via => 'provider-table'); | |||||
| 2048 | } | |||||
| 2049 | $add->( | |||||
| 2050 | role => "Web host of $dom", | |||||
| 2051 | address => $d->{web_abuse}, | |||||
| 2052 | note => sprintf('Hosting %s (%s, %s)', | |||||
| 2053 | $dom // '(unknown domain)', | |||||
| 2054 | $d->{web_ip} // '(unknown IP)', | |||||
| 2055 | $d->{web_org} // '(unknown org)'), | |||||
| 2056 | via => 'ip-whois', | |||||
| 2057 | ); | |||||
| 2058 | } | |||||
| 2059 | ||||||
| 2060 | # MX (mail host) contact | |||||
| 2061 | if ($d->{mx_abuse}) { | |||||
| 2062 | $add->( | |||||
| 2063 | role => "Mail host (MX) for $dom", | |||||
| 2064 | address => $d->{mx_abuse}, | |||||
| 2065 | note => sprintf('MX %s (%s, %s)', | |||||
| 2066 | $d->{mx_host} // '(unknown host)', | |||||
| 2067 | $d->{mx_ip} // '(unknown IP)', | |||||
| 2068 | $d->{mx_org} // '(unknown org)'), | |||||
| 2069 | via => 'ip-whois', | |||||
| 2070 | ); | |||||
| 2071 | } | |||||
| 2072 | ||||||
| 2073 | # NS (DNS host) contact | |||||
| 2074 | if ($d->{ns_abuse}) { | |||||
| 2075 | $add->( | |||||
| 2076 | role => "DNS host (NS) for $dom", | |||||
| 2077 | address => $d->{ns_abuse}, | |||||
| 2078 | note => sprintf('NS %s (%s, %s)', | |||||
| 2079 | $d->{ns_host} // '(unknown host)', | |||||
| 2080 | $d->{ns_ip} // '(unknown IP)', | |||||
| 2081 | $d->{ns_org} // '(unknown org)'), | |||||
| 2082 | via => 'ip-whois', | |||||
| 2083 | ); | |||||
| 2084 | } | |||||
| 2085 | ||||||
| 2086 | # Domain registrar (skip if domain only seen in spoofable headers) | |||||
| 2087 | if ($d->{registrar_abuse}) { | |||||
| 2088 | my $spoofable_only = | |||||
| 2089 | $d->{source} =~ /^(?:From:|Return-Path:|Sender:) header$/ && | |||||
| 2090 | !scalar(grep { | |||||
| 2091 | $_->{host} && | |||||
| 2092 | _registrable($_->{host}) eq (_registrable($dom) // $dom) | |||||
| 2093 | } $self->embedded_urls()); | |||||
| 2094 | unless ($spoofable_only) { | |||||
| 2095 | $add->( | |||||
| 2096 | role => "Domain registrar for $dom", | |||||
| 2097 | address => $d->{registrar_abuse}, | |||||
| 2098 | note => 'Registrar: ' . ($d->{registrar} // '(unknown)'), | |||||
| 2099 | via => 'domain-whois', | |||||
| 2100 | ); | |||||
| 2101 | } | |||||
| 2102 | } | |||||
| 2103 | } | |||||
| 2104 | ||||||
| 2105 | # Route 4 -- From:/Reply-To:/Return-Path:/Sender: account provider | |||||
| 2106 | for my $hname (qw(from reply-to return-path sender)) { | |||||
| 2107 | my $val = $self->_header_value($hname) // next; | |||||
| 2108 | ||||||
| 2109 | # Extract addr-spec from angle-bracket form to avoid display-name @-signs | |||||
| 2110 | my $addr_spec = ($val =~ /<([^>]*)>\s*$/) ? $1 : $val; | |||||
| 2111 | my ($addr_domain) = $addr_spec =~ /\@([\w.-]+)/; | |||||
| 2112 | next unless $addr_domain; | |||||
| 2113 | ||||||
| 2114 | # Skip SRS-rewritten forwarder addresses (not the real sender) | |||||
| 2115 | next if $addr_spec =~ /\+SRS[0-9]?=/i; | |||||
| 2116 | ||||||
| 2117 | my $pa = $self->_provider_abuse_for_host($addr_domain); | |||||
| 2118 | if ($pa) { | |||||
| 2119 | my $role_addr = $addr_spec =~ /\@/ ? $addr_spec : $val; | |||||
| 2120 | $role_addr =~ s/^\s+|\s+$//g; | |||||
| 2121 | $add->( | |||||
| 2122 | role => "Account provider ($hname: $role_addr)", | |||||
| 2123 | address => $pa->{email}, | |||||
| 2124 | note => $pa->{note}, | |||||
| 2125 | via => 'provider-table', | |||||
| 2126 | ); | |||||
| 2127 | } | |||||
| 2128 | } | |||||
| 2129 | ||||||
| 2130 | # Route 5 -- DKIM signing organisation | |||||
| 2131 | my $auth = $self->_parse_auth_results_cached(); | |||||
| 2132 | if ($auth->{dkim_domain}) { | |||||
| 2133 | my $pa = $self->_provider_abuse_for_host($auth->{dkim_domain}); | |||||
| 2134 | if ($pa) { | |||||
| 2135 | $add->( | |||||
| 2136 | role => "DKIM signer: $auth->{dkim_domain}", | |||||
| 2137 | address => $pa->{email}, | |||||
| 2138 | note => $pa->{note}, | |||||
| 2139 | via => 'provider-table', | |||||
| 2140 | ); | |||||
| 2141 | } | |||||
| 2142 | } | |||||
| 2143 | ||||||
| 2144 | # Route 6 -- List-Unsubscribe ESP domain | |||||
| 2145 | my $unsub = $self->_header_value('list-unsubscribe'); | |||||
| 2146 | if ($unsub) { | |||||
| 2147 | my @unsub_domains; | |||||
| 2148 | while ($unsub =~ m{https?://([^/:?\s>]+)}gi) { | |||||
| 2149 | push @unsub_domains, lc $1; | |||||
| 2150 | } | |||||
| 2151 | while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) { | |||||
| 2152 | push @unsub_domains, lc $1; | |||||
| 2153 | } | |||||
| 2154 | my %unsub_seen; | |||||
| 2155 | for my $dom (grep { !$unsub_seen{$_}++ } @unsub_domains) { | |||||
| 2156 | my $pa = $self->_provider_abuse_for_host($dom); | |||||
| 2157 | if ($pa) { | |||||
| 2158 | $add->( | |||||
| 2159 | role => "ESP / bulk sender (List-Unsubscribe: $dom)", | |||||
| 2160 | address => $pa->{email}, | |||||
| 2161 | note => "$pa->{note} -- responsible for this bulk delivery", | |||||
| 2162 | via => 'provider-table', | |||||
| 2163 | ); | |||||
| 2164 | } | |||||
| 2165 | } | |||||
| 2166 | } | |||||
| 2167 | ||||||
| 2168 | # Route 7 -- Reply addresses embedded in the message body | |||||
| 2169 | my %body_addr_seen; | |||||
| 2170 | my $combined_body = $self->{_body_plain} . "\n" . $self->{_body_html}; | |||||
| 2171 | for my $addr_dom ($self->_domains_from_text($combined_body)) { | |||||
| 2172 | next if $body_addr_seen{$addr_dom}++; | |||||
| 2173 | my $pa = $self->_provider_abuse_for_host($addr_dom); | |||||
| 2174 | next unless $pa && $pa->{email}; | |||||
| 2175 | my ($example_addr) = $combined_body =~ /(\S+\@\Q$addr_dom\E)/i; | |||||
| 2176 | $example_addr //= "\@$addr_dom"; | |||||
| 2177 | $add->( | |||||
| 2178 | role => "Reply address in body ($example_addr)", | |||||
| 2179 | address => $pa->{email}, | |||||
| 2180 | note => $pa->{note}, | |||||
| 2181 | via => 'provider-table', | |||||
| 2182 | ); | |||||
| 2183 | } | |||||
| 2184 | ||||||
| 2185 | return @contacts; | |||||
| 2186 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 37795 32 226 11 42 5727 1 13 1665 1 11 2546 2 12 1392 1471 2 18 1633 2 16 758 1 17 | } | |||
| 2187 | ||||||
| 2188 | # ----------------------------------------------------------------------- | |||||
| 2189 | # Public: form contacts (providers that require web-form submission) | |||||
| 2190 | # ----------------------------------------------------------------------- | |||||
| 2191 | ||||||
| 2192 - 2248 | =head2 form_contacts()
Returns the list of parties that require abuse reports via a web form
rather than email. These are providers whose C<%PROVIDER_ABUSE> entry
has a C<form> key. Each hashref includes the form URL, paste
instructions, upload instructions, and the discovery role.
=head3 Usage
my @forms = $analyser->form_contacts();
for my $c (@forms) {
printf "Open: %s\n", $c->{form};
}
=head3 Arguments
None. C<parse_email()> must have been called first.
=head3 Returns
A list of hashrefs, one per unique form contact. Each hashref has keys
C<form>, C<role>, C<note>, C<form_paste> (optional), C<form_upload>
(optional), and C<via>. Returns an empty list if no form contacts are found.
=head3 Side Effects
Triggers C<originating_ip()>, C<embedded_urls()>, and C<mailto_domains()>
if not already cached.
=head3 Notes
Deduplication is by form URL.
=head3 API Specification
=head4 Input
[]
=head4 Output
(
{
type => 'hashref',
keys => {
form => { type => 'string', regex => qr{^https?://} },
role => { type => 'string' },
note => { type => 'string' },
form_paste => { type => 'string', optional => 1 },
form_upload => { type => 'string', optional => 1 },
via => { type => 'string' },
},
},
...
)
=cut | |||||
| 2249 | ||||||
| 2250 | sub form_contacts { | |||||
| 2251 | 216 1 | 5212 12 | my $self = $_[0]; | |||
| 2252 | ||||||
| 2253 | 216 1 | 322 1070 | my (@contacts, %seen); | |||
| 2254 | ||||||
| 2255 | # Inner closure: add one form-contact entry, deduplicating by form URL | |||||
| 2256 | my $add = sub { | |||||
| 2257 | 96 1 | 223 38 | my (%args) = @_; | |||
| 2258 | 63 1 | 123 1008 | my $form = $args{form} // ''; | |||
| 2259 | 63 1 | 3923 1 | return unless $form; | |||
| 2260 | 66 1 | 124 12 | return if $seen{$form}++; | |||
| 2261 | 52 1 | 104 1363 | push @contacts, \%args; | |||
| 2262 | 216 1 | 4257 1 | }; | |||
| 2263 | ||||||
| 2264 | # Route 1 -- Sending ISP | |||||
| 2265 | 189 1 | 4488 1 | my $orig = $self->originating_ip(); | |||
| 2266 | 189 1 | 262 13 | if ($orig) { | |||
| 2267 | 121 1 | 276 1343 | my $pa = $self->_provider_abuse_for_ip($orig->{ip}, $orig->{rdns}); | |||
| 2268 | 110 1 | 3319 1 | if ($pa && $pa->{form}) { | |||
| 2269 | $add->( | |||||
| 2270 | role => 'Sending ISP', | |||||
| 2271 | form => $pa->{form}, | |||||
| 2272 | note => $pa->{note} // '', | |||||
| 2273 | form_paste => $pa->{form_paste} // '', | |||||
| 2274 | 16 1 | 15 13 | form_upload => $pa->{form_upload} // '', | |||
| 2275 | via => 'provider-table', | |||||
| 2276 | ); | |||||
| 2277 | } | |||||
| 2278 | } | |||||
| 2279 | ||||||
| 2280 | # Route 2 -- URL hosts | |||||
| 2281 | 176 1 | 190 534 | my %url_host_seen; | |||
| 2282 | 176 1 | 3591 2 | for my $u ($self->embedded_urls()) { | |||
| 2283 | 82 1 | 147 10 | next if $url_host_seen{ $u->{host} }++; | |||
| 2284 | 71 1 | 126 1319 | my $pa = $self->_provider_abuse_for_host($u->{host}); | |||
| 2285 | 94 1 | 4358 2 | if ($pa && $pa->{form}) { | |||
| 2286 | $add->( | |||||
| 2287 | role => "URL host: $u->{host}", | |||||
| 2288 | form => $pa->{form}, | |||||
| 2289 | form_domain => $u->{host}, | |||||
| 2290 | note => $pa->{note} // '', | |||||
| 2291 | form_paste => $pa->{form_paste} // '', | |||||
| 2292 | 17 1 | 38 12 | form_upload => $pa->{form_upload} // '', | |||
| 2293 | via => 'provider-table', | |||||
| 2294 | ); | |||||
| 2295 | } | |||||
| 2296 | } | |||||
| 2297 | ||||||
| 2298 | # Route 3 -- Contact domains (web host + registrar) | |||||
| 2299 | 191 1 | 271 3597 | for my $d ($self->mailto_domains()) { | |||
| 2300 | 176 1 | 3476 2 | my $dom = $d->{domain}; | |||
| 2301 | 176 1 | 204 15 | my $pa = $self->_provider_abuse_for_host($dom); | |||
| 2302 | 173 1 | 239 2 | if ($pa && $pa->{form}) { | |||
| 2303 | $add->( | |||||
| 2304 | role => "Web host of $dom", | |||||
| 2305 | form => $pa->{form}, | |||||
| 2306 | form_domain => $dom, | |||||
| 2307 | note => $pa->{note} // '', | |||||
| 2308 | form_paste => $pa->{form_paste} // '', | |||||
| 2309 | 18 1 | 4461 1 | form_upload => $pa->{form_upload} // '', | |||
| 2310 | via => 'provider-table', | |||||
| 2311 | ); | |||||
| 2312 | } | |||||
| 2313 | ||||||
| 2314 | # Registrar identified via WHOIS -- check for form-only registrar | |||||
| 2315 | 185 1 | 353 42 | if ($d->{registrar_abuse} && $d->{registrar_abuse} =~ /\@([\w.-]+)/) { | |||
| 2316 | 43 1 | 97 3 | my $reg_domain = lc $1; | |||
| 2317 | 34 1 | 3974 1 | my $rpa = $self->_provider_abuse_for_host($reg_domain); | |||
| 2318 | 34 1 | 71 4 | if ($rpa && $rpa->{form}) { | |||
| 2319 | $add->( | |||||
| 2320 | role => "Domain registrar for $dom (web form only)", | |||||
| 2321 | form => $rpa->{form}, | |||||
| 2322 | form_domain => $dom, | |||||
| 2323 | note => $rpa->{note} // '', | |||||
| 2324 | form_paste => $rpa->{form_paste} // '', | |||||
| 2325 | 22 1 | 126 3715 | form_upload => $rpa->{form_upload} // '', | |||
| 2326 | via => 'provider-table', | |||||
| 2327 | ); | |||||
| 2328 | } | |||||
| 2329 | } | |||||
| 2330 | } | |||||
| 2331 | ||||||
| 2332 | # Route 4 -- Account provider headers | |||||
| 2333 | 169 1 | 3183 1 | for my $hname (qw(from reply-to return-path sender)) { | |||
| 2334 | 655 1 | 628 42 | my $val = $self->_header_value($hname) // next; | |||
| 2335 | 281 1 | 613 3 | my $addr_spec = ($val =~ /<([^>]*)>\s*$/) ? $1 : $val; | |||
| 2336 | 281 1 | 3737 2 | my ($addr_domain) = $addr_spec =~ /\@([\w.-]+)/; | |||
| 2337 | 281 1 | 280 21 | next unless $addr_domain; | |||
| 2338 | # Skip SRS forwarder rewrite addresses | |||||
| 2339 | 281 1 | 384 2 | next if $addr_spec =~ /\+SRS[0-9]?=/i; | |||
| 2340 | 285 1 | 4432 1 | my $pa = $self->_provider_abuse_for_host($addr_domain); | |||
| 2341 | 290 1 | 392 6 | if ($pa && $pa->{form}) { | |||
| 2342 | 27 1 | 87 356 | my $role_addr = $addr_spec =~ /@/ ? $addr_spec : $val; | |||
| 2343 | 71 1 | 3237 3 | $role_addr =~ s/^\s+|\s+$//g; | |||
| 2344 | $add->( | |||||
| 2345 | role => "Account provider ($hname: $role_addr)", | |||||
| 2346 | form => $pa->{form}, | |||||
| 2347 | note => $pa->{note} // '', | |||||
| 2348 | form_paste => $pa->{form_paste} // '', | |||||
| 2349 | 30 1 | 122 2 | form_upload => $pa->{form_upload} // '', | |||
| 2350 | via => 'provider-table', | |||||
| 2351 | ); | |||||
| 2352 | } | |||||
| 2353 | } | |||||
| 2354 | ||||||
| 2355 | # Route 5 -- DKIM signer | |||||
| 2356 | 181 1 | 327 4 | my $auth = $self->_parse_auth_results_cached(); | |||
| 2357 | 178 1 | 4860 182 | if ($auth->{dkim_domain}) { | |||
| 2358 | 18 1 | 19 2 | my $pa = $self->_provider_abuse_for_host($auth->{dkim_domain}); | |||
| 2359 | 17 1 | 61 5 | if ($pa && $pa->{form}) { | |||
| 2360 | $add->( | |||||
| 2361 | role => "DKIM signer: $auth->{dkim_domain}", | |||||
| 2362 | form => $pa->{form}, | |||||
| 2363 | note => $pa->{note} // '', | |||||
| 2364 | form_paste => $pa->{form_paste} // '', | |||||
| 2365 | 16 1 | 3297 136 | form_upload => $pa->{form_upload} // '', | |||
| 2366 | via => 'provider-table', | |||||
| 2367 | ); | |||||
| 2368 | } | |||||
| 2369 | } | |||||
| 2370 | ||||||
| 2371 | # Route 6 -- List-Unsubscribe ESP domains | |||||
| 2372 | 168 1 | 220 2 | my $unsub = $self->_header_value('list-unsubscribe'); | |||
| 2373 | 177 1 | 259 38 | if ($unsub) { | |||
| 2374 | 13 1 | 2589 3 | my @unsub_domains; | |||
| 2375 | 18 17 1 1 | 21 44 2 33 | while ($unsub =~ m{https?://([^/:?\s>]+)}gi) { push @unsub_domains, lc $1 } | |||
| 2376 | 11 10 1 1 | 3433 11 3 2 | while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) { push @unsub_domains, lc $1 } | |||
| 2377 | 11 1 | 37 13 | my %useen; | |||
| 2378 | 11 11 1 1 | 4737 14 3 1 | for my $dom (grep { !$useen{$_}++ } @unsub_domains) { | |||
| 2379 | 11 1 | 51 37 | my $pa = $self->_provider_abuse_for_host($dom); | |||
| 2380 | 11 1 | 4246 3 | if ($pa && $pa->{form}) { | |||
| 2381 | $add->( | |||||
| 2382 | role => "ESP / bulk sender (List-Unsubscribe: $dom)", | |||||
| 2383 | form => $pa->{form}, | |||||
| 2384 | note => $pa->{note} // '', | |||||
| 2385 | form_paste => $pa->{form_paste} // '', | |||||
| 2386 | 5 1 | 11 17 | form_upload => $pa->{form_upload} // '', | |||
| 2387 | via => 'provider-table', | |||||
| 2388 | ); | |||||
| 2389 | } | |||||
| 2390 | } | |||||
| 2391 | } | |||||
| 2392 | ||||||
| 2393 | 171 1 | 643 66 | return @contacts; | |||
| 2394 | } | |||||
| 2395 | ||||||
| 2396 | # ----------------------------------------------------------------------- | |||||
| 2397 | # Public: full analyst report | |||||
| 2398 | # ----------------------------------------------------------------------- | |||||
| 2399 | ||||||
| 2400 - 2447 | =head2 report()
Produces a comprehensive, analyst-facing plain-text report covering all
findings: envelope fields, risk assessment, originating host, sending
software, received chain tracking IDs, embedded URLs, contact domain
intelligence, and recommended abuse contacts.
Use C<report()> for human review or ticketing systems. Use
C<abuse_report_text()> for sending to ISP abuse desks.
=head3 Usage
print $analyser->report();
open my $fh, '>', 'report.txt' or croak "Cannot open: $!";
print $fh $analyser->report();
close $fh;
=head3 Arguments
None. C<parse_email()> must have been called first.
=head3 Returns
A plain scalar string, newline-terminated, Unix line endings. Never empty
or undef.
=head3 Side Effects
Triggers all analysis methods if not already cached.
=head3 Notes
The report is idempotent: calling it multiple times on the same object
always returns an identical string. All user-derived content is sanitised
before output.
=head3 API Specification
=head4 Input
[]
=head4 Output
{ type => 'string' }
=cut | |||||
| 2448 | ||||||
| 2449 | sub report { | |||||
| 2450 | 69 1 | 5164 4 | my $self = $_[0]; | |||
| 2451 | ||||||
| 2452 | 76 1 | 68 2 | my @out; | |||
| 2453 | ||||||
| 2454 | # Banner header | |||||
| 2455 | 65 1 | 131 48 | push @out, '=' x 72; | |||
| 2456 | 65 1 | 4052 3 | push @out, " Email::Abuse::Investigator Report (v$VERSION)"; | |||
| 2457 | 64 1 | 74 1 | push @out, '=' x 72; | |||
| 2458 | 64 1 | 106 111 | push @out, ''; | |||
| 2459 | ||||||
| 2460 | # Envelope summary -- decode MIME encoded-words for readability | |||||
| 2461 | 63 1 | 7445 4 | for my $f (qw(from reply-to return-path subject date message-id)) { | |||
| 2462 | 364 1 | 336 1 | my $v = $self->_header_value($f); | |||
| 2463 | 365 1 | 407 31 | next unless defined $v; | |||
| 2464 | 250 1 | 250 2 | my $decoded = $self->_decode_mime_words($v); | |||
| 2465 | 251 1 | 198 2 | my $label = ucfirst($f); | |||
| 2466 | 249 1 | 408 5 | push @out, sprintf(' %-14s : %s', $label, | |||
| 2467 | _sanitise_output($decoded ne $v ? "$decoded [encoded: $v]" : $v)); | |||||
| 2468 | } | |||||
| 2469 | 65 1 | 71 161 | push @out, ''; | |||
| 2470 | ||||||
| 2471 | # Risk assessment section | |||||
| 2472 | 63 1 | 105 6 | my $risk = $self->risk_assessment(); | |||
| 2473 | 63 0 | 145 0 | push @out, "[ RISK ASSESSMENT: $risk->{level} (score: $risk->{score}) ]"; | |||
| 2474 | 63 76 1 1 | 6511 106 1665 8 | if (@{ $risk->{flags} }) { | |||
| 2475 | 87 48 0 1 | 177 71 0 1377 | for my $f (@{ $risk->{flags} }) { | |||
| 2476 | 73 1 | 120 6 | push @out, " [$f->{severity}] " . _sanitise_output($f->{detail}); | |||
| 2477 | } | |||||
| 2478 | } else { | |||||
| 2479 | 44 0 | 87 0 | push @out, ' (no specific red flags detected)'; | |||
| 2480 | } | |||||
| 2481 | 76 1 | 94 1402 | push @out, ''; | |||
| 2482 | ||||||
| 2483 | # Originating host section | |||||
| 2484 | 76 1 | 74 4 | push @out, '[ ORIGINATING HOST ]'; | |||
| 2485 | 76 1 | 125 2 | if(my $orig = $self->originating_ip()) { | |||
| 2486 | 34 1 | 719 2 | push @out, ' IP : ' . _sanitise_output($orig->{ip}); | |||
| 2487 | 34 1 | 75 6 | push @out, ' Reverse DNS : ' . _sanitise_output($orig->{rdns}) if $orig->{rdns}; | |||
| 2488 | 34 0 | 51 0 | push @out, ' Country : ' . _sanitise_output($orig->{country}) if $orig->{country}; | |||
| 2489 | 47 1 | 90 569 | push @out, ' Organisation : ' . _sanitise_output($orig->{org}) if $orig->{org}; | |||
| 2490 | 47 1 | 505 4 | push @out, ' Abuse addr : ' . _sanitise_output($orig->{abuse}) if $orig->{abuse}; | |||
| 2491 | 34 1 | 50 2 | push @out, " Confidence : $orig->{confidence}"; | |||
| 2492 | 34 1 | 66 1 | push @out, ' Note : ' . _sanitise_output($orig->{note}) if $orig->{note}; | |||
| 2493 | } else { | |||||
| 2494 | 32 1 | 272 5 | push @out, ' (could not determine originating IP)'; | |||
| 2495 | } | |||||
| 2496 | 76 0 | 74 0 | push @out, ''; | |||
| 2497 | ||||||
| 2498 | # Sending software section (omitted if none found) | |||||
| 2499 | 76 1 | 177 493 | my @sw = $self->sending_software(); | |||
| 2500 | 63 1 | 79 7 | if (@sw) { | |||
| 2501 | 5 0 | 5 0 | push @out, '[ SENDING SOFTWARE / INFRASTRUCTURE CLUES ]'; | |||
| 2502 | 5 1 | 49 6331 | for my $s (@sw) { | |||
| 2503 | 5 1 | 8 1 | push @out, sprintf(' %-14s : %s', $s->{header}, _sanitise_output($s->{value})); | |||
| 2504 | 5 1 | 5 28 | push @out, " Note : $s->{note}"; | |||
| 2505 | 5 1 | 33 757 | push @out, ''; | |||
| 2506 | } | |||||
| 2507 | } | |||||
| 2508 | ||||||
| 2509 | # Received chain tracking IDs (only hops with id or for are shown) | |||||
| 2510 | 63 52 1 1 | 132 126 2 18 | my @trail = grep { defined $_->{id} || defined $_->{for} } | |||
| 2511 | $self->received_trail(); | |||||
| 2512 | 63 1 | 139 1655 | if (@trail) { | |||
| 2513 | 4 1 | 7 2 | push @out, '[ RECEIVED CHAIN TRACKING IDs ]'; | |||
| 2514 | 4 1 | 36 16 | push @out, ' (Supply these to the relevant ISP abuse team to trace the session)'; | |||
| 2515 | 17 1 | 80 2029 | push @out, ''; | |||
| 2516 | 17 1 | 20 2 | for my $hop (@trail) { | |||
| 2517 | 17 1 | 19 14 | push @out, ' IP : ' . (_sanitise_output($hop->{ip}) // '(unknown)'); | |||
| 2518 | 4 1 | 49 1011 | push @out, ' Envelope for : ' . _sanitise_output($hop->{for}) if $hop->{for}; | |||
| 2519 | 4 1 | 8 2 | push @out, ' Server ID : ' . _sanitise_output($hop->{id}) if $hop->{id}; | |||
| 2520 | 4 1 | 4 13 | push @out, ''; | |||
| 2521 | } | |||||
| 2522 | } | |||||
| 2523 | ||||||
| 2524 | # Embedded URLs section -- grouped by hostname | |||||
| 2525 | 63 1 | 285 3041 | push @out, '[ EMBEDDED HTTP/HTTPS URLs ]'; | |||
| 2526 | 63 1 | 98 2 | my @urls = $self->embedded_urls(); | |||
| 2527 | 63 1 | 78 16 | if (@urls) { | |||
| 2528 | 34 1 | 203 3682 | my (%host_order, %host_meta, %host_paths); | |||
| 2529 | 21 1 | 24 1 | my $seq = 0; | |||
| 2530 | 21 1 | 23 11 | for my $u (@urls) { | |||
| 2531 | 30 1 | 60 2060 | my $h = $u->{host}; | |||
| 2532 | 30 1 | 389 2 | unless (exists $host_order{$h}) { | |||
| 2533 | 22 1 | 41 14 | $host_order{$h} = $seq++; | |||
| 2534 | $host_meta{$h} = { | |||||
| 2535 | ip => $u->{ip}, | |||||
| 2536 | org => $u->{org}, | |||||
| 2537 | abuse => $u->{abuse}, | |||||
| 2538 | country => $u->{country}, | |||||
| 2539 | 19 1 | 68 1488 | }; | |||
| 2540 | } | |||||
| 2541 | 30 30 1 1 | 1175 61 1 14 | push @{ $host_paths{$h} }, $u->{url}; | |||
| 2542 | } | |||||
| 2543 | ||||||
| 2544 | # Output each host group in first-seen order | |||||
| 2545 | 18 4 1 1 | 38 1006 696 1 | for my $h (sort { $host_order{$a} <=> $host_order{$b} } keys %host_order) { | |||
| 2546 | 22 1 | 35 12 | my $m = $host_meta{$h}; | |||
| 2547 | 19 22 1 1 | 22 1017 1446 1 | my $bare = lc $h; $bare =~ s/^www\.//; | |||
| 2548 | push @out, ' Host : ' . _sanitise_output($h) . | |||||
| 2549 | 22 1 | 31 19 | (($URL_SHORTENERS{$bare} || $self->{url_shorteners}->{$bare}) | |||
| 2550 | ? ' *** URL SHORTENER -- real destination hidden ***' : ''); | |||||
| 2551 | 21 1 | 39 940 | push @out, ' IP : ' . _sanitise_output($m->{ip}) if $m->{ip}; | |||
| 2552 | 22 1 | 832 1 | push @out, ' Country : ' . _sanitise_output($m->{country}) if $m->{country}; | |||
| 2553 | 22 1 | 55 13 | push @out, ' Organisation : ' . _sanitise_output($m->{org}) if $m->{org}; | |||
| 2554 | 19 1 | 54 559 | push @out, ' Abuse addr : ' . _sanitise_output($m->{abuse}) if $m->{abuse}; | |||
| 2555 | 22 22 1 1 | 1438 29 1 8 | my @paths = @{ $host_paths{$h} }; | |||
| 2556 | 22 1 | 34 967 | if (@paths == 1) { | |||
| 2557 | 16 1 | 20 1 | push @out, ' URL : ' . _sanitise_output($paths[0]); | |||
| 2558 | } else { | |||||
| 2559 | 9 1 | 26 12 | push @out, ' URLs (' . scalar(@paths) . ') :'; | |||
| 2560 | 6 1 | 13 1094 | push @out, ' ' . _sanitise_output($_) for @paths; | |||
| 2561 | } | |||||
| 2562 | 22 1 | 963 1 | push @out, ''; | |||
| 2563 | } | |||||
| 2564 | } else { | |||||
| 2565 | 45 1 | 81 15 | push @out, ' (none found)'; | |||
| 2566 | 42 1 | 41 1286 | push @out, ''; | |||
| 2567 | } | |||||
| 2568 | ||||||
| 2569 | # Contact / reply-to domains section | |||||
| 2570 | 63 1 | 17813 1 | push @out, '[ CONTACT / REPLY-TO DOMAINS ]'; | |||
| 2571 | 63 1 | 85 16 | my @mdoms = $self->mailto_domains(); | |||
| 2572 | 63 1 | 157 814 | if (@mdoms) { | |||
| 2573 | 50 1 | 4259 1 | for my $d (@mdoms) { | |||
| 2574 | 54 1 | 82 13 | push @out, ' Domain : ' . _sanitise_output($d->{domain}); | |||
| 2575 | 54 1 | 145 1394 | push @out, ' Found in : ' . _sanitise_output($d->{source}); | |||
| 2576 | 54 1 | 4846 1 | if ($d->{recently_registered}) { | |||
| 2577 | 5 1 | 9 16 | push @out, ' *** WARNING: RECENTLY REGISTERED - possible phishing domain ***'; | |||
| 2578 | } | |||||
| 2579 | 54 1 | 118 1100 | push @out, ' Registered : ' . $d->{registered} if $d->{registered}; | |||
| 2580 | 54 1 | 6455 1 | push @out, ' Expires : ' . $d->{expires} if $d->{expires}; | |||
| 2581 | 54 1 | 108 18 | push @out, ' Registrar : ' . _sanitise_output($d->{registrar}) if $d->{registrar}; | |||
| 2582 | 54 1 | 110 2097 | push @out, ' Reg. abuse : ' . _sanitise_output($d->{registrar_abuse}) if $d->{registrar_abuse}; | |||
| 2583 | 54 1 | 3774 2 | if ($d->{web_ip}) { | |||
| 2584 | 19 1 | 31 12 | push @out, ' Web host IP : ' . _sanitise_output($d->{web_ip}); | |||
| 2585 | 19 1 | 80 1830 | push @out, ' Web host org : ' . _sanitise_output($d->{web_org}) if $d->{web_org}; | |||
| 2586 | 19 1 | 9830 1 | push @out, ' Web abuse : ' . _sanitise_output($d->{web_abuse}) if $d->{web_abuse}; | |||
| 2587 | } else { | |||||
| 2588 | 38 1 | 43 17 | push @out, ' Web host : (no A record / unreachable)'; | |||
| 2589 | } | |||||
| 2590 | 54 1 | 96 2207 | if ($d->{mx_host}) { | |||
| 2591 | 6 1 | 12950 2 | push @out, ' MX host : ' . _sanitise_output($d->{mx_host}); | |||
| 2592 | 6 1 | 29 13 | push @out, ' MX IP : ' . _sanitise_output($d->{mx_ip}) if $d->{mx_ip}; | |||
| 2593 | 6 1 | 52 976 | push @out, ' MX org : ' . _sanitise_output($d->{mx_org}) if $d->{mx_org}; | |||
| 2594 | 6 1 | 6500 1 | push @out, ' MX abuse : ' . _sanitise_output($d->{mx_abuse}) if $d->{mx_abuse}; | |||
| 2595 | } else { | |||||
| 2596 | 51 1 | 52 13 | push @out, ' MX host : (none found)'; | |||
| 2597 | } | |||||
| 2598 | 54 1 | 136 926 | if ($d->{ns_host}) { | |||
| 2599 | 5 1 | 7032 2 | push @out, ' NS host : ' . _sanitise_output($d->{ns_host}); | |||
| 2600 | 5 1 | 10 12 | push @out, ' NS IP : ' . _sanitise_output($d->{ns_ip}) if $d->{ns_ip}; | |||
| 2601 | 5 1 | 47 1938 | push @out, ' NS org : ' . _sanitise_output($d->{ns_org}) if $d->{ns_org}; | |||
| 2602 | 5 1 | 4387 1 | push @out, ' NS abuse : ' . _sanitise_output($d->{ns_abuse}) if $d->{ns_abuse}; | |||
| 2603 | } | |||||
| 2604 | 54 1 | 64 13 | push @out, ''; | |||
| 2605 | } | |||||
| 2606 | } else { | |||||
| 2607 | 16 1 | 51 1739 | push @out, ' (none found)'; | |||
| 2608 | 16 1 | 5039 1 | push @out, ''; | |||
| 2609 | } | |||||
| 2610 | ||||||
| 2611 | # Abuse contacts summary | |||||
| 2612 | 63 1 | 61 9 | push @out, '[ WHERE TO SEND ABUSE REPORTS ]'; | |||
| 2613 | 63 1 | 139 1638 | my @contacts = $self->abuse_contacts(); | |||
| 2614 | 63 1 | 4451 1 | if (@contacts) { | |||
| 2615 | 36 1 | 36 9 | for my $c (@contacts) { | |||
| 2616 | 51 1 | 109 2038 | push @out, ' Role : ' . _sanitise_output($c->{role}); | |||
| 2617 | 51 1 | 3987 1 | push @out, ' Send to : ' . _sanitise_output($c->{address}); | |||
| 2618 | 51 1 | 90 9 | push @out, ' Note : ' . _sanitise_output($c->{note}) if $c->{note}; | |||
| 2619 | 51 1 | 91 1482 | push @out, " Discovered : $c->{via}"; | |||
| 2620 | 51 1 | 4746 1 | push @out, ''; | |||
| 2621 | } | |||||
| 2622 | } else { | |||||
| 2623 | 30 1 | 35 9 | push @out, ' (no abuse contacts could be determined)'; | |||
| 2624 | 30 1 | 64 1207 | push @out, ''; | |||
| 2625 | } | |||||
| 2626 | ||||||
| 2627 | # Web-form contacts (providers that require manual form submission) | |||||
| 2628 | 63 1 | 4832 1 | my @form_cs = $self->form_contacts(); | |||
| 2629 | 63 1 | 75 10 | if (@form_cs) { | |||
| 2630 | 6 1 | 44 2035 | push @out, '[ WHERE TO FILE WEB-FORM REPORTS ]'; | |||
| 2631 | 6 1 | 6039 1 | push @out, ' The following parties require manual submission via a web form.'; | |||
| 2632 | 6 1 | 8 15 | push @out, ' Open each URL in a browser, then follow the instructions below it.'; | |||
| 2633 | 6 1 | 41 1334 | push @out, ''; | |||
| 2634 | 6 1 | 5200 1 | for my $c (@form_cs) { | |||
| 2635 | 6 1 | 9 9 | push @out, ' Role : ' . _sanitise_output($c->{role}); | |||
| 2636 | 6 1 | 42 1731 | push @out, ' Form URL : ' . _sanitise_output($c->{form}); | |||
| 2637 | 6 1 | 4047 1 | push @out, ' Domain/URL : ' . _sanitise_output($c->{form_domain}) if $c->{form_domain}; | |||
| 2638 | 6 1 | 11 46 | push @out, ' Note : ' . _sanitise_output($c->{note}) if $c->{note}; | |||
| 2639 | 6 1 | 46 740 | if ($c->{form_paste}) { | |||
| 2640 | # Word-wrap the paste hint at ROLE_WRAP_LEN characters | |||||
| 2641 | 6 1 | 4032 2 | my $hint = $c->{form_paste}; | |||
| 2642 | 6 1 | 17 10 | my @words = split /\s+/, $hint; | |||
| 2643 | 6 1 | 42 941 | my (@lines, $line); | |||
| 2644 | 6 1 | 5765 2 | for my $w (@words) { | |||
| 2645 | 93 1 | 103 10 | if (defined $line && length("$line $w") > $ROLE_WRAP_LEN) { | |||
| 2646 | 9 1 | 43 1507 | push @lines, $line; | |||
| 2647 | 9 1 | 4037 1 | $line = $w; | |||
| 2648 | } else { | |||||
| 2649 | 87 1 | 74 12 | $line = defined $line ? "$line $w" : $w; | |||
| 2650 | } | |||||
| 2651 | } | |||||
| 2652 | 6 1 | 53 1139 | push @lines, $line if defined $line; | |||
| 2653 | 6 1 | 4310 1 | push @out, ' Paste : ' . shift @lines if @lines; | |||
| 2654 | 6 1 | 15 11 | push @out, ' ' . $_ for @lines; | |||
| 2655 | } | |||||
| 2656 | 6 1 | 44 1063 | push @out, ' Upload : ' . _sanitise_output($c->{form_upload}) if $c->{form_upload}; | |||
| 2657 | 6 1 | 3823 1 | push @out, ''; | |||
| 2658 | } | |||||
| 2659 | } | |||||
| 2660 | ||||||
| 2661 | 63 1 | 68 8 | push @out, '=' x 72; | |||
| 2662 | 63 1 | 455 1028 | return join("\n", @out) . "\n"; | |||
| 2663 | } | |||||
| 2664 | ||||||
| 2665 | # ----------------------------------------------------------------------- | |||||
| 2666 | # Private: output sanitisation | |||||
| 2667 | # ----------------------------------------------------------------------- | |||||
| 2668 | ||||||
| 2669 | # _sanitise_output( $str ) -> $str | |||||
| 2670 | # | |||||
| 2671 | # Purpose: | |||||
| 2672 | # Strip control characters that could affect terminal rendering or HTML | |||||
| 2673 | # injection from any string that will appear in a report or abuse email. | |||||
| 2674 | # Preserves printable ASCII, high-bytes (for UTF-8 content), tabs, and | |||||
| 2675 | # line endings. | |||||
| 2676 | # | |||||
| 2677 | # Entry criteria: | |||||
| 2678 | # $str -- a defined or undef scalar. | |||||
| 2679 | # | |||||
| 2680 | # Exit status: | |||||
| 2681 | # Returns the sanitised string, or the empty string if $str is undef. | |||||
| 2682 | # | |||||
| 2683 | # Notes: | |||||
| 2684 | # Only strips C0 control characters below 0x20 (except \t) and the DEL | |||||
| 2685 | # character (0x7F). High bytes (0x80-0xFF) are preserved because they | |||||
| 2686 | # form valid UTF-8 multi-byte sequences in headers and body text. | |||||
| 2687 | ||||||
| 2688 | sub _sanitise_output :Private { | |||||
| 2689 | my $str = $_[0]; | |||||
| 2690 | return '' unless defined $str; | |||||
| 2691 | # Remove C0 controls (except tab) and DEL | |||||
| 2692 | $str =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F\x7F]//g; | |||||
| 2693 | return $str; | |||||
| 2694 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 40482 24 232 5 37 4962 2 12 743 1 12 2102 1 14 779 1789 2 15 2014 2 14 1029 2 14 | } | |||
| 2695 | ||||||
| 2696 | # ----------------------------------------------------------------------- | |||||
| 2697 | # Private: message parsing | |||||
| 2698 | # ----------------------------------------------------------------------- | |||||
| 2699 | ||||||
| 2700 | # _split_message( $text ) | |||||
| 2701 | # | |||||
| 2702 | # Purpose: | |||||
| 2703 | # Split a raw RFC 2822 email into headers and body, parse all headers, | |||||
| 2704 | # decode the body (including multipart), extract sending-software | |||||
| 2705 | # fingerprints, and populate per-hop tracking data. | |||||
| 2706 | # | |||||
| 2707 | # Entry criteria: | |||||
| 2708 | # $text -- defined scalar, already dereferenced by parse_email(). | |||||
| 2709 | # $self->{_sending_sw} and $self->{_rcvd_tracking} reset to [] by caller. | |||||
| 2710 | # | |||||
| 2711 | # Exit status: | |||||
| 2712 | # Returns undef silently if the header block is empty/whitespace-only. | |||||
| 2713 | # Otherwise all results are communicated via side effects on $self. | |||||
| 2714 | # | |||||
| 2715 | # Side effects: | |||||
| 2716 | # Populates _headers, _received, _body_plain, _body_html, _sending_sw, | |||||
| 2717 | # and _rcvd_tracking. | |||||
| 2718 | # | |||||
| 2719 | # Notes: | |||||
| 2720 | # Delegates to _decode_multipart() for multipart/* content types. | |||||
| 2721 | # Lines not matching the header pattern are silently discarded. | |||||
| 2722 | # Boundary extraction uses a simple regex; missing boundary causes the | |||||
| 2723 | # body to be skipped silently. | |||||
| 2724 | ||||||
| 2725 | sub _split_message :Private { | |||||
| 2726 | my ($self, $text) = @_; | |||||
| 2727 | ||||||
| 2728 | # Split at the first blank line (RFC 2822 header/body separator) | |||||
| 2729 | my ($header_block, $body_raw) = split /\r?\n\r?\n/, $text, 2; | |||||
| 2730 | ||||||
| 2731 | return unless defined $header_block && $header_block =~ /\S/; | |||||
| 2732 | $body_raw //= ''; | |||||
| 2733 | ||||||
| 2734 | # Unfold RFC 2822 continuation lines (s2.2.3) | |||||
| 2735 | $header_block =~ s/\r?\n([ \t]+)/ $1/g; | |||||
| 2736 | ||||||
| 2737 | # Parse each header line into a { name, value } pair | |||||
| 2738 | my @headers; | |||||
| 2739 | for my $line (split /\r?\n/, $header_block) { | |||||
| 2740 | if ($line =~ /^([\w-]+)\s*:\s*(.*)/) { | |||||
| 2741 | push @headers, { name => lc($1), value => $2 }; | |||||
| 2742 | } | |||||
| 2743 | } | |||||
| 2744 | $self->{_headers} = \@headers; | |||||
| 2745 | ||||||
| 2746 | # Collect all Received: header values (most-recent first, as in message) | |||||
| 2747 | $self->{_received} = [ | |||||
| 2748 | map { $_->{value} } | |||||
| 2749 | grep { $_->{name} eq 'received' } @headers | |||||
| 2750 | ]; | |||||
| 2751 | ||||||
| 2752 | # Determine content type and transfer encoding from top-level headers | |||||
| 2753 | my ($ct_h) = grep { $_->{name} eq 'content-type' } @headers; | |||||
| 2754 | my ($cte_h) = grep { $_->{name} eq 'content-transfer-encoding' } @headers; | |||||
| 2755 | my $ct = defined $ct_h ? $ct_h->{value} : ''; | |||||
| 2756 | my $cte = defined $cte_h ? $cte_h->{value} : ''; | |||||
| 2757 | ||||||
| 2758 | # Decode multipart or single-part body as appropriate | |||||
| 2759 | if ($ct =~ /multipart/i) { | |||||
| 2760 | my ($boundary) = $ct =~ /boundary="?([^";]+)"?/i; | |||||
| 2761 | # Pass depth=0 to enforce the MAX_MULTIPART_DEPTH recursion guard | |||||
| 2762 | $self->_decode_multipart($body_raw, $boundary, 0) if $boundary; | |||||
| 2763 | } else { | |||||
| 2764 | my $decoded = $self->_decode_body($body_raw, $cte); | |||||
| 2765 | if ($ct =~ /html/i) { $self->{_body_html} = $decoded } | |||||
| 2766 | else { $self->{_body_plain} = $decoded } | |||||
| 2767 | } | |||||
| 2768 | ||||||
| 2769 | $self->_debug(sprintf 'Parsed %d headers, %d Received lines', | |||||
| 2770 | scalar @headers, scalar @{ $self->{_received} }); | |||||
| 2771 | ||||||
| 2772 | # --- Sending software fingerprints --- | |||||
| 2773 | # These headers identify the mailer or shared-hosting script that sent | |||||
| 2774 | # the message; invaluable for shared-hosting abuse reports. | |||||
| 2775 | my %sw_notes = ( | |||||
| 2776 | 'x-php-originating-script' => 'PHP script on shared hosting -- report to hosting abuse team', | |||||
| 2777 | 'x-source' => 'Source file on shared hosting -- report to hosting abuse team', | |||||
| 2778 | 'x-source-host' => 'Sending hostname injected by shared hosting provider', | |||||
| 2779 | 'x-source-args' => 'Command-line args injected by shared hosting provider', | |||||
| 2780 | 'x-mailer' => 'Email client or bulk-mailer identifier', | |||||
| 2781 | 'user-agent' => 'Email client identifier', | |||||
| 2782 | ); | |||||
| 2783 | for my $sw_hdr (sort keys %sw_notes) { | |||||
| 2784 | my ($h) = grep { $_->{name} eq $sw_hdr } @headers; | |||||
| 2785 | next unless $h; | |||||
| 2786 | push @{ $self->{_sending_sw} }, { | |||||
| 2787 | header => $sw_hdr, | |||||
| 2788 | value => $h->{value}, | |||||
| 2789 | note => $sw_notes{$sw_hdr}, | |||||
| 2790 | }; | |||||
| 2791 | } | |||||
| 2792 | ||||||
| 2793 | # --- Per-hop tracking IDs from Received: chain --- | |||||
| 2794 | # Walk oldest-first (reverse) so _rcvd_tracking is oldest-first | |||||
| 2795 | for my $rcvd (reverse @{ $self->{_received} }) { | |||||
| 2796 | my $ip = $self->_extract_ip_from_received($rcvd); | |||||
| 2797 | my ($for_addr) = $rcvd =~ /\bfor\s+<?([^\s>]+\@[\w.-]+\.[\w]+)>?/i; | |||||
| 2798 | my ($srv_id) = $rcvd =~ /\bid\s+([\w.-]+)/i; | |||||
| 2799 | # Skip hops with no actionable tracking data | |||||
| 2800 | next unless defined $ip || defined $for_addr || defined $srv_id; | |||||
| 2801 | push @{ $self->{_rcvd_tracking} }, { | |||||
| 2802 | received => $rcvd, | |||||
| 2803 | ip => $ip, | |||||
| 2804 | for => $for_addr, | |||||
| 2805 | id => $srv_id, | |||||
| 2806 | }; | |||||
| 2807 | } | |||||
| 2808 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 15555 24 225 5 36 4809 2 12 556 1 19 1560 2 12 820 1068 2 12 962 1 18 1510 2 14 | } | |||
| 2809 | ||||||
| 2810 | # _decode_multipart( $body, $boundary, $depth ) | |||||
| 2811 | # | |||||
| 2812 | # Purpose: | |||||
| 2813 | # Recursively split a MIME multipart body on its boundary and decode each | |||||
| 2814 | # text/plain and text/html part. Nested multipart/* containers are | |||||
| 2815 | # recursed into up to MAX_MULTIPART_DEPTH levels deep. | |||||
| 2816 | # | |||||
| 2817 | # Entry criteria: | |||||
| 2818 | # $body -- the raw body text of the multipart container. | |||||
| 2819 | # $boundary -- the boundary string from the Content-Type header. | |||||
| 2820 | # $depth -- current recursion depth (starts at 0 from _split_message). | |||||
| 2821 | # | |||||
| 2822 | # Exit status: | |||||
| 2823 | # Returns undef if $depth >= MAX_MULTIPART_DEPTH (recursion guard). | |||||
| 2824 | # Otherwise all results via side effects. | |||||
| 2825 | # | |||||
| 2826 | # Side effects: | |||||
| 2827 | # Appends decoded text to $self->{_body_plain} and $self->{_body_html}. | |||||
| 2828 | # | |||||
| 2829 | # Notes: | |||||
| 2830 | # Whitespace-only MIME segments between boundaries are silently skipped. | |||||
| 2831 | # Decoding errors are silenced; raw bytes are used as fallback. | |||||
| 2832 | ||||||
| 2833 | sub _decode_multipart :Private { | |||||
| 2834 | my ($self, $body, $boundary, $depth) = @_; | |||||
| 2835 | $depth //= 0; | |||||
| 2836 | ||||||
| 2837 | # Enforce the recursion depth limit to prevent stack exhaustion on | |||||
| 2838 | # pathological crafted messages with deeply nested multipart structures. | |||||
| 2839 | if ($depth >= $MAX_MULTIPART_DEPTH) { | |||||
| 2840 | Carp::carp 'Email::Abuse::Investigator: multipart nesting depth limit', | |||||
| 2841 | "($MAX_MULTIPART_DEPTH) exceeded; stopping recursion"; | |||||
| 2842 | return; | |||||
| 2843 | } | |||||
| 2844 | ||||||
| 2845 | # Split on the boundary marker; the (?:--)? suffix handles closing boundary | |||||
| 2846 | my @parts = split /--\Q$boundary\E(?:--)?/, $body; | |||||
| 2847 | ||||||
| 2848 | for my $part (@parts) { | |||||
| 2849 | # Skip whitespace-only segments between boundaries | |||||
| 2850 | next unless $part =~ /\S/; | |||||
| 2851 | ||||||
| 2852 | $part =~ s/^\r?\n//; | |||||
| 2853 | ||||||
| 2854 | # Each MIME part has its own headers separated from body by a blank line | |||||
| 2855 | my ($phdr_block, $pbody) = split /\r?\n\r?\n/, $part, 2; | |||||
| 2856 | next unless defined $pbody; | |||||
| 2857 | ||||||
| 2858 | # Unfold continuation header lines within this part | |||||
| 2859 | $phdr_block =~ s/\r?\n([ \t]+)/ $1/g; | |||||
| 2860 | ||||||
| 2861 | # Parse this part's headers into a simple hash | |||||
| 2862 | my %phdr; | |||||
| 2863 | for my $line (split /\r?\n/, $phdr_block) { | |||||
| 2864 | $phdr{ lc($1) } = $2 if $line =~ /^([\w-]+)\s*:\s*(.*)/; | |||||
| 2865 | } | |||||
| 2866 | ||||||
| 2867 | my $pct = $phdr{'content-type'} // ''; | |||||
| 2868 | my $pcte = $phdr{'content-transfer-encoding'} // ''; | |||||
| 2869 | ||||||
| 2870 | # Nested multipart/* must be recursed into; without this URLs in | |||||
| 2871 | # multipart/alternative inside multipart/mixed would be missed. | |||||
| 2872 | if ($pct =~ /multipart/i) { | |||||
| 2873 | my ($inner_boundary) = $pct =~ /boundary\s*=\s*"?([^";]+)"?/i; | |||||
| 2874 | if ($inner_boundary) { | |||||
| 2875 | $inner_boundary =~ s/\s+$//; | |||||
| 2876 | # Increment depth counter for the recursion guard | |||||
| 2877 | $self->_decode_multipart($pbody, $inner_boundary, $depth + 1); | |||||
| 2878 | } | |||||
| 2879 | next; | |||||
| 2880 | } | |||||
| 2881 | ||||||
| 2882 | # Decode transfer encoding and accumulate by content type | |||||
| 2883 | my $decoded = $self->_decode_body($pbody, $pcte); | |||||
| 2884 | if ($pct =~ /text\/html/i) { $self->{_body_html} .= $decoded } | |||||
| 2885 | elsif ($pct =~ /text/i || !$pct) { $self->{_body_plain} .= $decoded } | |||||
| 2886 | } | |||||
| 2887 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 11409 20 204 251 42 5651 2 12 1359 2 18 864 2 12 1420 2563 1 11 3218 1 14 3079 2 11 | } | |||
| 2888 | ||||||
| 2889 | # _decode_body( $body, $cte ) -> string | |||||
| 2890 | # | |||||
| 2891 | # Purpose: | |||||
| 2892 | # Decode a MIME body part according to its Content-Transfer-Encoding. | |||||
| 2893 | # | |||||
| 2894 | # Entry criteria: | |||||
| 2895 | # $body -- raw body string (may be undef). | |||||
| 2896 | # $cte -- Content-Transfer-Encoding value string (may be undef). | |||||
| 2897 | # | |||||
| 2898 | # Exit status: | |||||
| 2899 | # Returns the decoded string, or the original string if the encoding is | |||||
| 2900 | # 7bit/8bit/binary or unrecognised. | |||||
| 2901 | # | |||||
| 2902 | # Notes: | |||||
| 2903 | # decode_qp and decode_base64 are imported from MIME:: modules; errors | |||||
| 2904 | # from malformed content are silenced by the eval wrappers they provide. | |||||
| 2905 | ||||||
| 2906 | sub _decode_body :Private { | |||||
| 2907 | my ($self, $body, $cte) = @_; | |||||
| 2908 | $cte //= ''; | |||||
| 2909 | return decode_qp($body) if $cte =~ /quoted-printable/i; | |||||
| 2910 | return decode_base64($body) if $cte =~ /base64/i; | |||||
| 2911 | return $body // ''; | |||||
| 2912 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 5376 20 188 3 41 3725 2 12 1464 1 10 1013 1 12 1243 3488 2 9 3763 2 16 2714 1 10 | } | |||
| 2913 | ||||||
| 2914 | # ----------------------------------------------------------------------- | |||||
| 2915 | # Private: Received-chain -> originating IP | |||||
| 2916 | # ----------------------------------------------------------------------- | |||||
| 2917 | ||||||
| 2918 | # _find_origin() | |||||
| 2919 | # | |||||
| 2920 | # Purpose: | |||||
| 2921 | # Walk the Received: chain (oldest-first) to find the first external IP, | |||||
| 2922 | # or fall back to X-Originating-IP. Enrich with rDNS and WHOIS. | |||||
| 2923 | # | |||||
| 2924 | # Entry criteria: | |||||
| 2925 | # $self->{_received} populated by _split_message(). | |||||
| 2926 | # $self->{trusted_relays} set by new(). | |||||
| 2927 | # | |||||
| 2928 | # Exit status: | |||||
| 2929 | # Returns { ip, rdns, org, abuse, country, confidence, note } on success. | |||||
| 2930 | # Returns undef if no usable IP can be identified. | |||||
| 2931 | # | |||||
| 2932 | # Side effects: | |||||
| 2933 | # Network I/O via _enrich_ip(): one PTR lookup, one RDAP/WHOIS query. | |||||
| 2934 | # Results are also stored in the CHI cross-message cache if available. | |||||
| 2935 | # | |||||
| 2936 | # Notes: | |||||
| 2937 | # confidence 'high' = 2+ distinct external IPs; | |||||
| 2938 | # 'medium' = exactly one external IP; | |||||
| 2939 | # 'low' = taken from X-Originating-IP. | |||||
| 2940 | ||||||
| 2941 | sub _find_origin :Private { | |||||
| 2942 | my $self = $_[0]; | |||||
| 2943 | ||||||
| 2944 | my @candidates; | |||||
| 2945 | ||||||
| 2946 | # Walk oldest-first (reverse) to collect external IPs | |||||
| 2947 | for my $hdr (reverse @{ $self->{_received} }) { | |||||
| 2948 | my $ip = $self->_extract_ip_from_received($hdr) // next; | |||||
| 2949 | next if $self->_is_private($ip); | |||||
| 2950 | next if $self->_is_trusted($ip); | |||||
| 2951 | push @candidates, $ip; | |||||
| 2952 | } | |||||
| 2953 | ||||||
| 2954 | # Fall back to X-Originating-IP if no external IPs in Received: chain | |||||
| 2955 | unless (@candidates) { | |||||
| 2956 | my $xoip = $self->_header_value('x-originating-ip'); | |||||
| 2957 | if ($xoip) { | |||||
| 2958 | $xoip =~ s/[\[\]\s]//g; | |||||
| 2959 | return $self->_enrich_ip($xoip, 'low', | |||||
| 2960 | 'Taken from X-Originating-IP (webmail, unverified)') | |||||
| 2961 | unless $self->_is_private($xoip); | |||||
| 2962 | } | |||||
| 2963 | return; | |||||
| 2964 | } | |||||
| 2965 | ||||||
| 2966 | # Report the oldest (first) external IP; confidence depends on count | |||||
| 2967 | return $self->_enrich_ip( | |||||
| 2968 | $candidates[0], | |||||
| 2969 | @candidates > 1 ? 'high' : 'medium', | |||||
| 2970 | 'First external hop in Received: chain', | |||||
| 2971 | ); | |||||
| 2972 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 7651 20 189 4 30 4605 4 15 1232 1 11 1331 2 15 1563 1643 1 12 2078 2 13 896 1 11 | } | |||
| 2973 | ||||||
| 2974 | # _extract_ip_from_received( $hdr ) -> ipv4_or_ipv6_string | undef | |||||
| 2975 | # | |||||
| 2976 | # Purpose: | |||||
| 2977 | # Extract the most-significant IP address from a raw Received: header | |||||
| 2978 | # value, trying patterns in priority order. Supports both IPv4 dotted- | |||||
| 2979 | # quad and IPv6 bracket notation. | |||||
| 2980 | # | |||||
| 2981 | # Entry criteria: | |||||
| 2982 | # $hdr -- a defined Received: header value string. | |||||
| 2983 | # | |||||
| 2984 | # Exit status: | |||||
| 2985 | # Returns the IP string on success, undef if no IP can be extracted. | |||||
| 2986 | # | |||||
| 2987 | # Notes: | |||||
| 2988 | # IPv4 addresses are validated (all octets <= 255). | |||||
| 2989 | # IPv6 addresses are returned as-is if they contain colons. | |||||
| 2990 | ||||||
| 2991 | sub _extract_ip_from_received :Private { | |||||
| 2992 | my ($self, $hdr) = @_; | |||||
| 2993 | for my $re (@RECEIVED_IP_RE) { | |||||
| 2994 | if ($hdr =~ $re) { | |||||
| 2995 | my $ip = $1; | |||||
| 2996 | ||||||
| 2997 | # Accept IPv6 addresses (contain colons) without further validation | |||||
| 2998 | return $ip if $ip =~ /:/; | |||||
| 2999 | ||||||
| 3000 | # Validate IPv4 format and octet range | |||||
| 3001 | next unless $ip =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/; | |||||
| 3002 | next if grep { $_ > 255 } split /\./, $ip; | |||||
| 3003 | return $ip; | |||||
| 3004 | } | |||||
| 3005 | } | |||||
| 3006 | return; | |||||
| 3007 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 6645 23 185 3 36 4508 1 13 1915 1 12 1197 1 12 1694 1726 1 13 1618 2 15 1141 2 10 | } | |||
| 3008 | ||||||
| 3009 | # _is_private( $ip ) -> bool | |||||
| 3010 | # | |||||
| 3011 | # Purpose: | |||||
| 3012 | # Test whether an IP address falls in any private, reserved, or special- | |||||
| 3013 | # use range (IPv4 or IPv6) that should never be reported as a spam origin. | |||||
| 3014 | # | |||||
| 3015 | # Entry criteria: | |||||
| 3016 | # $ip -- a scalar IP string (IPv4 or IPv6); may be undef. | |||||
| 3017 | # | |||||
| 3018 | # Exit status: | |||||
| 3019 | # Returns 1 (true) if the IP is private/reserved, 0 (false) otherwise. | |||||
| 3020 | # Returns 1 for undef or empty strings. | |||||
| 3021 | # | |||||
| 3022 | # Notes: | |||||
| 3023 | # Uses the module-level @PRIVATE_RANGES array of pre-compiled regexes. | |||||
| 3024 | # Covers all ranges listed in RFC 1122, 1918, 5737, 6598, and RFC 4193. | |||||
| 3025 | ||||||
| 3026 | sub _is_private :Private { | |||||
| 3027 | my ($self, $ip) = @_; | |||||
| 3028 | return 1 if !defined($ip) || $ip eq ''; | |||||
| 3029 | for my $re (@PRIVATE_RANGES) { return 1 if $ip =~ $re } | |||||
| 3030 | return 0; | |||||
| 3031 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 5329 25 194 6 34 3125 1 15 1133 1 11 2049 1 14 1016 753 2 9 800 2 15 1374 2 9 | } | |||
| 3032 | ||||||
| 3033 | # _is_trusted( $ip ) -> bool | |||||
| 3034 | # | |||||
| 3035 | # Purpose: | |||||
| 3036 | # Test whether an IP address matches any entry in the caller-supplied | |||||
| 3037 | # trusted_relays list (exact IP or CIDR block). | |||||
| 3038 | # | |||||
| 3039 | # Entry criteria: | |||||
| 3040 | # $ip -- a defined IPv4 address string. | |||||
| 3041 | # $self->{trusted_relays} -- arrayref of exact IPs or CIDR strings. | |||||
| 3042 | # | |||||
| 3043 | # Exit status: | |||||
| 3044 | # Returns 1 (true) if the IP matches any trusted relay, 0 otherwise. | |||||
| 3045 | ||||||
| 3046 | sub _is_trusted :Private { | |||||
| 3047 | my ($self, $ip) = @_; | |||||
| 3048 | for my $cidr (@{ $self->{trusted_relays} }) { | |||||
| 3049 | return 1 if $self->_ip_in_cidr($ip, $cidr); | |||||
| 3050 | } | |||||
| 3051 | return 0; | |||||
| 3052 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 4985 24 198 5 35 5254 2 13 970 2 11 2302 2 12 883 1393 1 17 1465 2 13 780 0 9 | } | |||
| 3053 | ||||||
| 3054 | # ----------------------------------------------------------------------- | |||||
| 3055 | # Private: HTTP/HTTPS URL extraction and resolution | |||||
| 3056 | # ----------------------------------------------------------------------- | |||||
| 3057 | ||||||
| 3058 | # _extract_and_resolve_urls() -> arrayref of url hashrefs | |||||
| 3059 | # | |||||
| 3060 | # Purpose: | |||||
| 3061 | # Extract all HTTP/HTTPS URLs from the decoded body, resolve each unique | |||||
| 3062 | # hostname to an IP, and enrich with WHOIS/RDAP data. Optionally uses | |||||
| 3063 | # AnyEvent::DNS to parallelise the DNS resolution step. | |||||
| 3064 | # | |||||
| 3065 | # Entry criteria: | |||||
| 3066 | # $self->{_body_plain} and $self->{_body_html} populated by _split_message(). | |||||
| 3067 | # | |||||
| 3068 | # Exit status: | |||||
| 3069 | # Returns an arrayref of url hashrefs (possibly empty). | |||||
| 3070 | # | |||||
| 3071 | # Side effects: | |||||
| 3072 | # Network I/O per unique hostname: one A/AAAA lookup, one RDAP/WHOIS. | |||||
| 3073 | # Results stored in the CHI cross-message cache if available. | |||||
| 3074 | ||||||
| 3075 | sub _extract_and_resolve_urls :Private { | |||||
| 3076 | my $self = $_[0]; | |||||
| 3077 | my (%url_seen, %host_cache); | |||||
| 3078 | my @results; | |||||
| 3079 | my $combined = $self->{_body_plain} . "\n" . $self->{_body_html}; | |||||
| 3080 | ||||||
| 3081 | # Collect unique URLs from body | |||||
| 3082 | my @urls = grep { !$url_seen{$_}++ } $self->_extract_http_urls($combined); | |||||
| 3083 | ||||||
| 3084 | # For URL-shortener and redirect-cloaker hosts, follow the redirect chain to | |||||
| 3085 | # discover the real destination (e.g. GCS bucket â phishing landing page). | |||||
| 3086 | # Done before DNS resolution so that destination hostnames can be parallelised. | |||||
| 3087 | # _follow_redirect_chain() is a :Protected seam that handles LWP availability | |||||
| 3088 | # internally â do not guard this block with $HAS_LWP so the seam can be | |||||
| 3089 | # stubbed unconditionally in tests regardless of whether LWP is installed. | |||||
| 3090 | for my $url (@urls) { | |||||
| 3091 | my ($host) = $url =~ m{https?://([^/:?\s#]+)}i; | |||||
| 3092 | next unless $host; | |||||
| 3093 | my $bare = lc $host; | |||||
| 3094 | $bare =~ s/^www\.//; | |||||
| 3095 | next unless $URL_SHORTENERS{$bare} | |||||
| 3096 | || ($self->{url_shorteners} && $self->{url_shorteners}{$bare}) | |||||
| 3097 | || $self->_is_redirect_cloaker($bare); | |||||
| 3098 | my $dest = $self->_follow_redirect_chain($url); | |||||
| 3099 | next unless defined $dest && !$url_seen{$dest}++; | |||||
| 3100 | push @urls, $dest; | |||||
| 3101 | } | |||||
| 3102 | ||||||
| 3103 | # Extract unique hostnames for parallel DNS resolution (including redirect destinations) | |||||
| 3104 | my %hostname_needed; | |||||
| 3105 | for my $url (@urls) { | |||||
| 3106 | my ($host) = $url =~ m{https?://([^/:?\s#]+)}i; | |||||
| 3107 | $hostname_needed{$host}++ if $host; | |||||
| 3108 | } | |||||
| 3109 | ||||||
| 3110 | # Parallelise DNS lookups if AnyEvent::DNS is available | |||||
| 3111 | if ($HAS_ANYEVENT_DNS && scalar(keys %hostname_needed) > 1) { | |||||
| 3112 | $self->_parallel_resolve_hosts(\%hostname_needed, \%host_cache); | |||||
| 3113 | } | |||||
| 3114 | ||||||
| 3115 | # Process each URL: resolve hostname and WHOIS-enrich | |||||
| 3116 | for my $url (@urls) { | |||||
| 3117 | my ($host) = $url =~ m{https?://([^/:?\s#]+)}i; | |||||
| 3118 | next unless $host; | |||||
| 3119 | ||||||
| 3120 | # Resolve and WHOIS once per unique hostname, then cache the result | |||||
| 3121 | unless (exists $host_cache{$host}) { | |||||
| 3122 | # Check the cross-message CHI cache first | |||||
| 3123 | my $cached = $_cache ? $_cache->get("url:$host") : undef; | |||||
| 3124 | if ($cached) { | |||||
| 3125 | $host_cache{$host} = $cached; | |||||
| 3126 | } else { | |||||
| 3127 | my $ip = $self->_resolve_host($host) // '(unresolved)'; | |||||
| 3128 | my $whois = $ip ne '(unresolved)' | |||||
| 3129 | ? $self->_whois_ip($ip) | |||||
| 3130 | : {}; | |||||
| 3131 | ||||||
| 3132 | # Fall back to domain WHOIS if IP lookup returned nothing | |||||
| 3133 | if (!$whois->{abuse}) { | |||||
| 3134 | my $reg = _registrable($host) // $host; | |||||
| 3135 | my $dw = $self->_parse_domain_whois_abuse($reg); | |||||
| 3136 | $whois = $dw if $dw->{abuse}; | |||||
| 3137 | } | |||||
| 3138 | ||||||
| 3139 | my $entry = { | |||||
| 3140 | ip => $ip, | |||||
| 3141 | org => $whois->{org} // '(unknown)', | |||||
| 3142 | abuse => $whois->{abuse} // '(unknown)', | |||||
| 3143 | country => $whois->{country} // undef, | |||||
| 3144 | }; | |||||
| 3145 | $host_cache{$host} = $entry; | |||||
| 3146 | ||||||
| 3147 | # Store in cross-message cache for reuse across messages | |||||
| 3148 | $_cache->set("url:$host", $entry) if $_cache; | |||||
| 3149 | } | |||||
| 3150 | } | |||||
| 3151 | ||||||
| 3152 | push @results, { url => $url, host => $host, %{ $host_cache{$host} } }; | |||||
| 3153 | } | |||||
| 3154 | return \@results; | |||||
| 3155 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 11883 33 217 5 40 4498 2 11 1912 7 18 870 1 13 1660 690 1 15 1020 1 12 1243 1 9 | } | |||
| 3156 | ||||||
| 3157 | # _is_redirect_cloaker( $bare_host ) -> bool | |||||
| 3158 | # | |||||
| 3159 | # Purpose: | |||||
| 3160 | # Return true if $bare_host is a known cloud-storage or CDN host that is | |||||
| 3161 | # commonly abused to serve client-side redirect pages hiding the real | |||||
| 3162 | # phishing destination. Checks the exact-match %REDIRECT_HOSTS table and | |||||
| 3163 | # the suffix patterns in @REDIRECT_HOST_SUFFIXES. | |||||
| 3164 | # | |||||
| 3165 | # Entry criteria: | |||||
| 3166 | # $bare_host -- lowercase hostname with any leading "www." already stripped. | |||||
| 3167 | # | |||||
| 3168 | # Exit status: | |||||
| 3169 | # Returns 1 (true) or empty string (false). | |||||
| 3170 | ||||||
| 3171 | sub _is_redirect_cloaker :Private { | |||||
| 3172 | my (undef, $host) = @_; | |||||
| 3173 | return 1 if $REDIRECT_HOSTS{$host}; | |||||
| 3174 | for my $suffix (@REDIRECT_HOST_SUFFIXES) { | |||||
| 3175 | return 1 if length($host) > length($suffix) | |||||
| 3176 | && substr($host, -length($suffix)) eq $suffix; | |||||
| 3177 | } | |||||
| 3178 | return ''; | |||||
| 3179 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 6350 40 188 4 41 3868 1 14 1126 2 12 1260 1202 14 813 1066 1 9 490 1 13 1599 1 9 | } | |||
| 3180 | ||||||
| 3181 | # _follow_redirect_chain( $url ) -> $final_url | undef | |||||
| 3182 | # | |||||
| 3183 | # Purpose: | |||||
| 3184 | # Follow up to $REDIRECT_MAX_HOPS HTTP hops for a given URL and return the | |||||
| 3185 | # final destination. Detects HTTP 3xx Location: redirects, HTML | |||||
| 3186 | # <meta http-equiv="refresh" content="...url=..."> tags, and | |||||
| 3187 | # window.location.replace() / window.location.href JavaScript patterns. | |||||
| 3188 | # Used to expose the real phishing landing page hidden behind a cloud | |||||
| 3189 | # object-store redirect page (e.g. a GCS bucket containing only a | |||||
| 3190 | # meta-refresh pointing to the attacker-controlled domain). | |||||
| 3191 | # | |||||
| 3192 | # Entry criteria: | |||||
| 3193 | # $url -- an https?:// URL string whose host has already been identified | |||||
| 3194 | # as a URL shortener or redirect cloaker. | |||||
| 3195 | # LWP::UserAgent must be installed ($HAS_LWP must be true). | |||||
| 3196 | # | |||||
| 3197 | # Exit status: | |||||
| 3198 | # Returns the first URL that differs from the input after following the | |||||
| 3199 | # chain, or undef if no redirect was found or LWP is unavailable. | |||||
| 3200 | # Never returns the input $url unchanged. | |||||
| 3201 | # | |||||
| 3202 | # Side effects: | |||||
| 3203 | # Up to $REDIRECT_MAX_HOPS HTTP GET requests. | |||||
| 3204 | # Successful result cached in the cross-message CHI cache keyed | |||||
| 3205 | # "redirect:<url>" to avoid re-fetching across messages. | |||||
| 3206 | ||||||
| 3207 | sub _follow_redirect_chain :Protected { | |||||
| 3208 | my ($self, $url) = @_; | |||||
| 3209 | return undef unless $HAS_LWP; | |||||
| 3210 | ||||||
| 3211 | # Serve from cache when available | |||||
| 3212 | if ($_cache) { | |||||
| 3213 | my $cached = $_cache->get("redirect:$url"); | |||||
| 3214 | return $cached if defined $cached; | |||||
| 3215 | } | |||||
| 3216 | ||||||
| 3217 | # Dedicated no-follow UA so we can inspect each redirect hop manually. | |||||
| 3218 | # Stored separately from the RDAP UA ($self->{ua}) which needs auto-follow. | |||||
| 3219 | unless (defined $self->{_ua_nofollow}) { | |||||
| 3220 | my $ua = LWP::UserAgent->new( | |||||
| 3221 | timeout => $self->{timeout}, | |||||
| 3222 | agent => "Email-Abuse-Investigator/$VERSION", | |||||
| 3223 | max_redirect => 0, | |||||
| 3224 | ); | |||||
| 3225 | if ($HAS_CONN_CACHE) { | |||||
| 3226 | my $cc = LWP::ConnCache->new(); | |||||
| 3227 | $cc->total_capacity(4); | |||||
| 3228 | $ua->conn_cache($cc); | |||||
| 3229 | } | |||||
| 3230 | $ua->env_proxy(1); | |||||
| 3231 | $self->{_ua_nofollow} = $ua; | |||||
| 3232 | } | |||||
| 3233 | my $ua = $self->{_ua_nofollow}; | |||||
| 3234 | ||||||
| 3235 | my $current = $url; | |||||
| 3236 | my $final; | |||||
| 3237 | for my $hop (1 .. $REDIRECT_MAX_HOPS) { | |||||
| 3238 | my $res = eval { $ua->get($current) }; | |||||
| 3239 | last unless $res; | |||||
| 3240 | ||||||
| 3241 | if ($res->is_redirect()) { | |||||
| 3242 | # HTTP 3xx: extract Location header | |||||
| 3243 | my $loc = $res->header('Location'); | |||||
| 3244 | last unless defined $loc; | |||||
| 3245 | ||||||
| 3246 | # Resolve relative Location URLs against the current base | |||||
| 3247 | if ($loc !~ m{^https?://}i) { | |||||
| 3248 | require URI; | |||||
| 3249 | $loc = URI->new_abs($loc, $current)->as_string(); | |||||
| 3250 | } | |||||
| 3251 | $final = $loc; | |||||
| 3252 | $current = $loc; | |||||
| 3253 | } elsif ($res->is_success()) { | |||||
| 3254 | # 2xx: inspect body for client-side redirect patterns | |||||
| 3255 | my $body = $res->decoded_content() // ''; | |||||
| 3256 | my $dest; | |||||
| 3257 | ||||||
| 3258 | # <meta http-equiv="refresh" content="N; url=https://..."> | |||||
| 3259 | if ($body =~ m{<meta[^>]+http-equiv\s*=\s*["']?refresh["']?[^>]+ | |||||
| 3260 | content\s*=\s*["'][^"']*url\s*=\s*(https?://[^"'\s>]+)}xi) { | |||||
| 3261 | $dest = $1; | |||||
| 3262 | } | |||||
| 3263 | # window.location.replace("...") or window.location.href = "..." | |||||
| 3264 | elsif ($body =~ m{window\.location(?:\.replace\s*\(\s*|\.href\s*=\s*) | |||||
| 3265 | ["'](https?://[^"']+)["']}xi) { | |||||
| 3266 | $dest = $1; | |||||
| 3267 | } | |||||
| 3268 | ||||||
| 3269 | last unless defined $dest; | |||||
| 3270 | $final = $dest; | |||||
| 3271 | $current = $dest; | |||||
| 3272 | } else { | |||||
| 3273 | last; | |||||
| 3274 | } | |||||
| 3275 | } | |||||
| 3276 | ||||||
| 3277 | # Cache for reuse across messages in this session | |||||
| 3278 | $_cache->set("redirect:$url", $final) if $_cache && defined $final; | |||||
| 3279 | ||||||
| 3280 | return $final; | |||||
| 3281 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 11716 22 244 5 40 4326 2 12 1487 1 14 455 1 12 1544 484 1 9 1073 1 12 1106 1 9 | } | |||
| 3282 | ||||||
| 3283 | # _parallel_resolve_hosts( \%hostnames, \%cache ) | |||||
| 3284 | # | |||||
| 3285 | # Purpose: | |||||
| 3286 | # Resolve multiple hostnames to IPs in parallel using AnyEvent::DNS. | |||||
| 3287 | # Populates the cache with resolved IPs so the sequential loop in | |||||
| 3288 | # _extract_and_resolve_urls() can skip the DNS step for pre-resolved hosts. | |||||
| 3289 | # | |||||
| 3290 | # Entry criteria: | |||||
| 3291 | # $hostnames_ref -- hashref keyed by hostname (values ignored). | |||||
| 3292 | # $cache_ref -- hashref to populate with { ip => '...' } results. | |||||
| 3293 | # AnyEvent::DNS must be installed ($HAS_ANYEVENT_DNS is true). | |||||
| 3294 | # | |||||
| 3295 | # Exit status: | |||||
| 3296 | # Returns undef; all results written to %$cache_ref via side effects. | |||||
| 3297 | # | |||||
| 3298 | # Notes: | |||||
| 3299 | # Errors (NXDOMAIN, timeout) are silently swallowed; the sequential | |||||
| 3300 | # resolution loop will return '(unresolved)' for those hosts. | |||||
| 3301 | ||||||
| 3302 | sub _parallel_resolve_hosts :Private { | |||||
| 3303 | my ($self, $hostnames_ref, $cache_ref) = @_; | |||||
| 3304 | # Guard both conditions together: an empty hash must never reach condvar | |||||
| 3305 | # creation because $cv->recv would block forever with $pending == 0. | |||||
| 3306 | return unless $HAS_ANYEVENT_DNS && %$hostnames_ref; | |||||
| 3307 | ||||||
| 3308 | # Build an AnyEvent condvar to wait for all lookups to complete | |||||
| 3309 | my $cv = AnyEvent->condvar; | |||||
| 3310 | my $pending = scalar keys %$hostnames_ref; | |||||
| 3311 | ||||||
| 3312 | # AnyEvent::DNS::resolve is a method, not a standalone function. | |||||
| 3313 | # Use the global resolver singleton; passing a bare string as the | |||||
| 3314 | # first arg would make Perl treat the hostname as the invocant. | |||||
| 3315 | my $resolver = AnyEvent::DNS::resolver(); | |||||
| 3316 | ||||||
| 3317 | for my $host (keys %$hostnames_ref) { | |||||
| 3318 | # Fire an async A query for each hostname | |||||
| 3319 | $resolver->resolve( | |||||
| 3320 | $host, 'a', | |||||
| 3321 | sub { | |||||
| 3322 | my @answers = @_; | |||||
| 3323 | if (@answers) { | |||||
| 3324 | # Cache the first A record result | |||||
| 3325 | $cache_ref->{$host} = { ip => $answers[0][4] }; | |||||
| 3326 | } | |||||
| 3327 | # Decrement the pending counter; signal when all done | |||||
| 3328 | $cv->send if --$pending <= 0; | |||||
| 3329 | }, | |||||
| 3330 | ); | |||||
| 3331 | } | |||||
| 3332 | ||||||
| 3333 | # Block until all DNS queries complete (subject to AnyEvent's own timeouts) | |||||
| 3334 | $cv->recv; | |||||
| 3335 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 6818 19 193 3 27 4899 2 11 719 1 8 1472 1 12 835 1148 2 13 987 2 10 1650 1 13 | } | |||
| 3336 | ||||||
| 3337 | # _extract_http_urls( $body ) -> list of url strings | |||||
| 3338 | # | |||||
| 3339 | # Purpose: | |||||
| 3340 | # Extract all HTTP and HTTPS URLs from a body string, using both | |||||
| 3341 | # structural HTML parsing (if HTML::LinkExtor is available) and a | |||||
| 3342 | # plain-text regex pass. Deduplicates and strips trailing punctuation. | |||||
| 3343 | # | |||||
| 3344 | # Entry criteria: | |||||
| 3345 | # $body -- combined plain+HTML body string. | |||||
| 3346 | # | |||||
| 3347 | # Exit status: | |||||
| 3348 | # Returns a list of URL strings (possibly empty), deduplicated. | |||||
| 3349 | ||||||
| 3350 | sub _extract_http_urls :Private { | |||||
| 3351 | my ($self, $body) = @_; | |||||
| 3352 | my @urls; | |||||
| 3353 | ||||||
| 3354 | # Structural HTML link extraction (handles quoted attributes correctly) | |||||
| 3355 | if ($HAS_HTML_LINKEXTOR) { | |||||
| 3356 | my $p = HTML::LinkExtor->new(sub { | |||||
| 3357 | my ($tag, %attrs) = @_; | |||||
| 3358 | for my $attr (qw(href src action)) { | |||||
| 3359 | my $val = $attrs{$attr} // ''; | |||||
| 3360 | if ($val =~ m{^https?://}i) { | |||||
| 3361 | push @urls, $val; | |||||
| 3362 | } elsif ($val =~ m{^//[\w.-]}) { | |||||
| 3363 | # Protocol-relative -- assume https | |||||
| 3364 | push @urls, 'https:' . $val; | |||||
| 3365 | } | |||||
| 3366 | } | |||||
| 3367 | }); | |||||
| 3368 | $p->parse($body); | |||||
| 3369 | } | |||||
| 3370 | ||||||
| 3371 | # Plain-text regex pass for bare URLs not in HTML attributes | |||||
| 3372 | while ($body =~ m{(https?://[^\s<>"'\)\]]+)}gi) { | |||||
| 3373 | push @urls, $1; | |||||
| 3374 | } | |||||
| 3375 | ||||||
| 3376 | # Protocol-relative URLs not caught above | |||||
| 3377 | while ($body =~ m{(?:^|[\s"'=])(//[\w.-][^\s<>"'\)\]]*)}gim) { | |||||
| 3378 | push @urls, 'https:' . $1; | |||||
| 3379 | } | |||||
| 3380 | ||||||
| 3381 | # Deduplicate and strip trailing punctuation | |||||
| 3382 | my %seen; | |||||
| 3383 | my @all = grep { !$seen{$_}++ } @urls; | |||||
| 3384 | s/[.,;:!?\)>\]]+$// for @all; | |||||
| 3385 | return @all; | |||||
| 3386 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 10784 20 318 3 36 3617 1 12 784 2 13 1522 1 13 645 1585 1 9 1173 1 12 832 1 9 | } | |||
| 3387 | ||||||
| 3388 | # ----------------------------------------------------------------------- | |||||
| 3389 | # Private: domain extraction and full analysis | |||||
| 3390 | # ----------------------------------------------------------------------- | |||||
| 3391 | ||||||
| 3392 | # _extract_and_analyse_domains() -> arrayref of domain hashrefs | |||||
| 3393 | # | |||||
| 3394 | # Purpose: | |||||
| 3395 | # Collect all non-infrastructure contact domains from headers and body, | |||||
| 3396 | # run the full domain intelligence pipeline on each, and return an arrayref | |||||
| 3397 | # suitable for storage in $self->{_mailto_domains}. | |||||
| 3398 | # | |||||
| 3399 | # Entry criteria: | |||||
| 3400 | # _split_message() must have been called. | |||||
| 3401 | # | |||||
| 3402 | # Exit status: | |||||
| 3403 | # Always returns an arrayref; never undef. | |||||
| 3404 | # | |||||
| 3405 | # Side effects: | |||||
| 3406 | # Network I/O per domain via _analyse_domain(). | |||||
| 3407 | # Results stored in $self->{_domain_info} and CHI cache. | |||||
| 3408 | ||||||
| 3409 | sub _extract_and_analyse_domains :Private { | |||||
| 3410 | my $self = $_[0]; | |||||
| 3411 | my (%seen, @domains_with_source); | |||||
| 3412 | ||||||
| 3413 | # Build a set of recipient domains to exclude (victims, not senders) | |||||
| 3414 | my %recipient_domains; | |||||
| 3415 | for my $hname (qw(to cc)) { | |||||
| 3416 | my $val = $self->_header_value($hname) // next; | |||||
| 3417 | for my $dom ($self->_domains_from_text($val)) { | |||||
| 3418 | my $reg = _registrable($dom) // $dom; | |||||
| 3419 | $recipient_domains{$dom}++; | |||||
| 3420 | $recipient_domains{$reg}++; | |||||
| 3421 | } | |||||
| 3422 | } | |||||
| 3423 | ||||||
| 3424 | # Also exclude domains from Received: "for" envelope recipients | |||||
| 3425 | for my $hop (@{ $self->{_rcvd_tracking} }) { | |||||
| 3426 | next unless $hop->{for} && $hop->{for} =~ /\@([\w.-]+)/; | |||||
| 3427 | my $dom = lc $1; | |||||
| 3428 | my $reg = _registrable($dom) // $dom; | |||||
| 3429 | $recipient_domains{$dom}++; | |||||
| 3430 | $recipient_domains{$reg}++; | |||||
| 3431 | } | |||||
| 3432 | ||||||
| 3433 | # Inner closure: record a domain if it passes all filters | |||||
| 3434 | my $record = sub { | |||||
| 3435 | my ($dom, $source) = @_; | |||||
| 3436 | $dom = lc $dom; | |||||
| 3437 | $dom =~ s/\.$//; | |||||
| 3438 | next if $self->{trusted_domains}->{$dom}; | |||||
| 3439 | return if $TRUSTED_DOMAINS{$dom}; | |||||
| 3440 | return if $recipient_domains{$dom}; | |||||
| 3441 | return if $recipient_domains{ _registrable($dom) // $dom }; | |||||
| 3442 | # Discard non-routable hostnames (single-label, pseudo-TLDs, etc.) | |||||
| 3443 | return unless $dom =~ /\.[a-zA-Z]{2,}$/; | |||||
| 3444 | return if $dom =~ /\.(?:local|internal|lan|localdomain|arpa)$/i; | |||||
| 3445 | return if $seen{$dom}++; | |||||
| 3446 | push @domains_with_source, { domain => $dom, source => $source }; | |||||
| 3447 | }; | |||||
| 3448 | ||||||
| 3449 | # Collect from standard sender/reply headers | |||||
| 3450 | my %header_sources = ( | |||||
| 3451 | 'from' => 'From: header', | |||||
| 3452 | 'reply-to' => 'Reply-To: header', | |||||
| 3453 | 'return-path' => 'Return-Path: header', | |||||
| 3454 | 'sender' => 'Sender: header', | |||||
| 3455 | ); | |||||
| 3456 | for my $hname (sort keys %header_sources) { | |||||
| 3457 | my $val = $self->_header_value($hname) // next; | |||||
| 3458 | $record->($_, $header_sources{$hname}) | |||||
| 3459 | for $self->_domains_from_text($val); | |||||
| 3460 | } | |||||
| 3461 | ||||||
| 3462 | # Message-ID domain often reveals the real bulk-sending platform | |||||
| 3463 | my $mid = $self->_header_value('message-id'); | |||||
| 3464 | if ($mid && $mid =~ /\@([\w.-]+)/) { | |||||
| 3465 | my $mid_dom = lc $1; | |||||
| 3466 | my $mid_reg = _registrable($mid_dom) // $mid_dom; | |||||
| 3467 | $record->($mid_dom, 'Message-ID: header') | |||||
| 3468 | unless $TRUSTED_DOMAINS{$mid_dom} || $TRUSTED_DOMAINS{$mid_reg} || $self->{trusted_domains}->{$mid_dom} || $self->{trusted_domains}->{$mid_reg}; | |||||
| 3469 | } | |||||
| 3470 | ||||||
| 3471 | # DKIM signing domain(s) -- the organisation that vouches for the message | |||||
| 3472 | my $auth = $self->_parse_auth_results_cached(); | |||||
| 3473 | for my $dkim_d (@{ $auth->{dkim_domains} // [] }) { | |||||
| 3474 | $record->($dkim_d, 'DKIM-Signature: d= (signing domain)'); | |||||
| 3475 | } | |||||
| 3476 | ||||||
| 3477 | # List-Unsubscribe identifies the ESP or bulk sender | |||||
| 3478 | my $unsub = $self->_header_value('list-unsubscribe'); | |||||
| 3479 | if ($unsub) { | |||||
| 3480 | while ($unsub =~ m{https?://([^/:?\s>]+)}gi) { | |||||
| 3481 | $record->(lc $1, 'List-Unsubscribe: header'); | |||||
| 3482 | } | |||||
| 3483 | while ($unsub =~ m{mailto:[^@\s>]+\@([\w.-]+)}gi) { | |||||
| 3484 | $record->(lc $1, 'List-Unsubscribe: header'); | |||||
| 3485 | } | |||||
| 3486 | } | |||||
| 3487 | ||||||
| 3488 | # Body email addresses (mailto: and bare user@domain forms) | |||||
| 3489 | my $combined = $self->{_body_plain} . "\n" . $self->{_body_html}; | |||||
| 3490 | $record->($_, 'email address / mailto in body') | |||||
| 3491 | for $self->_domains_from_text($combined); | |||||
| 3492 | ||||||
| 3493 | # Run the full intelligence pipeline on each collected domain | |||||
| 3494 | my @results; | |||||
| 3495 | for my $entry (@domains_with_source) { | |||||
| 3496 | my $info = $self->_analyse_domain($entry->{domain}); | |||||
| 3497 | push @results, { %$entry, %$info }; | |||||
| 3498 | } | |||||
| 3499 | return \@results; | |||||
| 3500 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 14716 22 214 4 32 5467 1 13 1099 1 15 1993 2 13 1341 1326 2 13 889 2 12 1907 5 14 | } | |||
| 3501 | ||||||
| 3502 | # _domains_from_text( $text ) -> list of domain strings | |||||
| 3503 | # | |||||
| 3504 | # Purpose: | |||||
| 3505 | # Extract unique domain names from mailto: links and bare user@domain | |||||
| 3506 | # addresses in a block of text. | |||||
| 3507 | # | |||||
| 3508 | # Entry criteria: | |||||
| 3509 | # $text -- a defined scalar of decoded body or header text. | |||||
| 3510 | # | |||||
| 3511 | # Exit status: | |||||
| 3512 | # Returns a list of lower-cased domain strings (possibly empty). | |||||
| 3513 | ||||||
| 3514 | sub _domains_from_text :Private { | |||||
| 3515 | my ($self, $text) = @_; | |||||
| 3516 | my (%seen, @out); | |||||
| 3517 | ||||||
| 3518 | # mailto: links (including HTML-entity-encoded @ signs from QP) | |||||
| 3519 | while ($text =~ /mailto:(?:[^@\s<>"]+)@([\w.-]+)/gi) { | |||||
| 3520 | my $dom = lc $1; $dom =~ s/\.$//; | |||||
| 3521 | push @out, $dom unless $seen{$dom}++; | |||||
| 3522 | } | |||||
| 3523 | ||||||
| 3524 | # Bare user@domain patterns | |||||
| 3525 | while ($text =~ /\b[\w.+%-]+@([\w.-]+\.[a-zA-Z]{2,})\b/g) { | |||||
| 3526 | my $dom = lc $1; $dom =~ s/\.$//; | |||||
| 3527 | push @out, $dom unless $seen{$dom}++; | |||||
| 3528 | } | |||||
| 3529 | return @out; | |||||
| 3530 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 10118 21 195 4 34 4139 3 12 914 1 10 1065 1 14 1378 1520 1 16 1324 1 11 769 2 8 | } | |||
| 3531 | ||||||
| 3532 | # _analyse_domain( $domain ) -> hashref | |||||
| 3533 | # | |||||
| 3534 | # Purpose: | |||||
| 3535 | # Run the complete intelligence pipeline for a single domain: A record | |||||
| 3536 | # (web hosting), MX record (mail hosting), NS record (DNS hosting), | |||||
| 3537 | # and WHOIS (registrar, creation/expiry dates, abuse contact). | |||||
| 3538 | # Each IP is enriched via RDAP/WHOIS. Results are cached per domain | |||||
| 3539 | # in $self->{_domain_info} and in the CHI cross-message cache. | |||||
| 3540 | # | |||||
| 3541 | # Entry criteria: | |||||
| 3542 | # $domain -- lower-cased, no trailing dot, not in TRUSTED_DOMAINS. | |||||
| 3543 | # $self->{timeout} used for all network operations. | |||||
| 3544 | # | |||||
| 3545 | # Exit status: | |||||
| 3546 | # Always returns a hashref reference; never undef; may be empty ({}). | |||||
| 3547 | # Possible keys: web_ip, web_org, web_abuse, mx_host, mx_ip, mx_org, | |||||
| 3548 | # mx_abuse, ns_host, ns_ip, ns_org, ns_abuse, registrar, | |||||
| 3549 | # registrar_abuse, registered, expires, recently_registered, whois_raw. | |||||
| 3550 | # | |||||
| 3551 | # Side effects: | |||||
| 3552 | # Network I/O; writes result to $self->{_domain_info}{$domain} and CHI. | |||||
| 3553 | # | |||||
| 3554 | # Notes: | |||||
| 3555 | # MX/NS lookups require Net::DNS; absent without it. | |||||
| 3556 | # recently_registered is set to 1 (not 0) when the threshold is met. | |||||
| 3557 | # whois_raw is truncated to WHOIS_RAW_MAX bytes. | |||||
| 3558 | ||||||
| 3559 | sub _analyse_domain :Private { | |||||
| 3560 | my ($self, $domain) = @_; | |||||
| 3561 | ||||||
| 3562 | # Return the per-message cached result if already analysed | |||||
| 3563 | return $self->{_domain_info}{$domain} | |||||
| 3564 | if $self->{_domain_info}{$domain}; | |||||
| 3565 | ||||||
| 3566 | # Check the cross-message CHI cache before hitting the network | |||||
| 3567 | if ($_cache) { | |||||
| 3568 | my $cached = $_cache->get("dom:$domain"); | |||||
| 3569 | if ($cached) { | |||||
| 3570 | $self->{_domain_info}{$domain} = $cached; | |||||
| 3571 | return $cached; | |||||
| 3572 | } | |||||
| 3573 | } | |||||
| 3574 | ||||||
| 3575 | $self->_debug("Analysing domain: $domain"); | |||||
| 3576 | my %info; | |||||
| 3577 | ||||||
| 3578 | # --- A record -> web hosting IP --- | |||||
| 3579 | my $web_ip = $self->_resolve_host($domain); | |||||
| 3580 | if ($web_ip) { | |||||
| 3581 | $info{web_ip} = $web_ip; | |||||
| 3582 | my $w = $self->_whois_ip($web_ip); | |||||
| 3583 | $info{web_org} = $w->{org} if $w->{org}; | |||||
| 3584 | $info{web_abuse} = $w->{abuse} if $w->{abuse}; | |||||
| 3585 | } | |||||
| 3586 | ||||||
| 3587 | # MX and NS lookups require Net::DNS | |||||
| 3588 | if ($HAS_NET_DNS) { | |||||
| 3589 | my $res = Net::DNS::Resolver->new( | |||||
| 3590 | tcp_timeout => $self->{timeout}, | |||||
| 3591 | udp_timeout => $self->{timeout}, | |||||
| 3592 | ); | |||||
| 3593 | ||||||
| 3594 | # --- MX record -> mail hosting --- | |||||
| 3595 | if(my $mxq = $res->search($domain, 'MX')) { | |||||
| 3596 | my ($best) = sort { $a->preference <=> $b->preference } | |||||
| 3597 | grep { $_->type eq 'MX' } $mxq->answer; | |||||
| 3598 | if ($best) { | |||||
| 3599 | (my $mx_host = lc $best->exchange) =~ s/\.$//; | |||||
| 3600 | $info{mx_host} = $mx_host; | |||||
| 3601 | my $mx_ip = $self->_resolve_host($mx_host); | |||||
| 3602 | if ($mx_ip) { | |||||
| 3603 | $info{mx_ip} = $mx_ip; | |||||
| 3604 | my $mw = $self->_whois_ip($mx_ip); | |||||
| 3605 | $info{mx_org} = $mw->{org} if $mw->{org}; | |||||
| 3606 | $info{mx_abuse} = $mw->{abuse} if $mw->{abuse}; | |||||
| 3607 | } | |||||
| 3608 | } | |||||
| 3609 | } | |||||
| 3610 | ||||||
| 3611 | # --- NS record -> DNS hosting --- | |||||
| 3612 | if(my $nsq = $res->search($domain, 'NS')) { | |||||
| 3613 | # Sort alphabetically so DNS round-robin ordering never changes which | |||||
| 3614 | # nameserver we record -- both runs of the same domain always agree. | |||||
| 3615 | my ($first) = sort { $a->nsdname cmp $b->nsdname } grep { $_->type eq 'NS' } $nsq->answer; | |||||
| 3616 | if ($first) { | |||||
| 3617 | (my $ns_host = lc $first->nsdname) =~ s/\.$//; | |||||
| 3618 | $info{ns_host} = $ns_host; | |||||
| 3619 | my $ns_ip = $self->_resolve_host($ns_host); | |||||
| 3620 | if ($ns_ip) { | |||||
| 3621 | $info{ns_ip} = $ns_ip; | |||||
| 3622 | my $nw = $self->_whois_ip($ns_ip); | |||||
| 3623 | $info{ns_org} = $nw->{org} if $nw->{org}; | |||||
| 3624 | $info{ns_abuse} = $nw->{abuse} if $nw->{abuse}; | |||||
| 3625 | } | |||||
| 3626 | } | |||||
| 3627 | } | |||||
| 3628 | } | |||||
| 3629 | ||||||
| 3630 | # --- Domain WHOIS -> registrar + dates --- | |||||
| 3631 | if(my $domain_whois = $self->_domain_whois($domain)) { | |||||
| 3632 | # Truncate raw WHOIS for storage but parse structured fields from full text | |||||
| 3633 | $info{whois_raw} = substr($domain_whois, 0, $WHOIS_RAW_MAX); | |||||
| 3634 | ||||||
| 3635 | # Registrar name | |||||
| 3636 | if ($domain_whois =~ /Registrar:\s*(.+)/i) { | |||||
| 3637 | ($info{registrar} = $1) =~ s/\s+$//; | |||||
| 3638 | } | |||||
| 3639 | ||||||
| 3640 | # Registrar abuse contact email (try multiple field names) | |||||
| 3641 | for my $pat ( | |||||
| 3642 | qr/Registrar Abuse Contact Email:\s*(\S+@\S+)/i, | |||||
| 3643 | qr/Abuse Contact Email:\s*(\S+@\S+)/i, | |||||
| 3644 | qr/abuse-contact:\s*(\S+@\S+)/i, | |||||
| 3645 | ) { | |||||
| 3646 | if (!$info{registrar_abuse} && $domain_whois =~ $pat) { | |||||
| 3647 | ($info{registrar_abuse} = $1) =~ s/\s+$//; | |||||
| 3648 | } | |||||
| 3649 | } | |||||
| 3650 | ||||||
| 3651 | # Domain creation date (multiple registrar field name variations) | |||||
| 3652 | for my $pat ( | |||||
| 3653 | qr/Creation Date:\s*(\S+)/i, | |||||
| 3654 | qr/Created(?:\s+On)?:\s*(\S+)/i, | |||||
| 3655 | qr/Registration Time:\s*(\S+)/i, | |||||
| 3656 | qr/^registered:\s*(\S+)/im, | |||||
| 3657 | ) { | |||||
| 3658 | if (!$info{registered} && $domain_whois =~ $pat) { | |||||
| 3659 | ($info{registered} = $1) =~ s/[TZ].*//; | |||||
| 3660 | } | |||||
| 3661 | } | |||||
| 3662 | ||||||
| 3663 | # Domain expiry date | |||||
| 3664 | for my $pat ( | |||||
| 3665 | qr/Registry Expiry Date:\s*(\S+)/i, | |||||
| 3666 | qr/Expir(?:y|ation)(?: Date)?:\s*(\S+)/i, | |||||
| 3667 | qr/paid-till:\s*(\S+)/i, | |||||
| 3668 | ) { | |||||
| 3669 | if (!$info{expires} && $domain_whois =~ $pat) { | |||||
| 3670 | ($info{expires} = $1) =~ s/[TZ].*//; | |||||
| 3671 | } | |||||
| 3672 | } | |||||
| 3673 | ||||||
| 3674 | # Flag recently-registered domains (< RECENT_REG_DAYS old) | |||||
| 3675 | if ($info{registered}) { | |||||
| 3676 | my $epoch = $self->_parse_date_to_epoch($info{registered}); | |||||
| 3677 | $info{recently_registered} = 1 | |||||
| 3678 | if $epoch && (time() - $epoch) < $RECENT_REG_DAYS * $SECS_PER_DAY; | |||||
| 3679 | } | |||||
| 3680 | } | |||||
| 3681 | ||||||
| 3682 | # Store in per-message and cross-message caches | |||||
| 3683 | $self->{_domain_info}{$domain} = \%info; | |||||
| 3684 | $_cache->set("dom:$domain", \%info) if $_cache; | |||||
| 3685 | ||||||
| 3686 | return \%info; | |||||
| 3687 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 18110 23 217 6 38 2659 1 13 1050 1 16 1296 1 10 1249 964 1 18 1121 1 14 1707 2 8 | } | |||
| 3688 | ||||||
| 3689 | # ----------------------------------------------------------------------- | |||||
| 3690 | # Private: DNS helpers | |||||
| 3691 | # ----------------------------------------------------------------------- | |||||
| 3692 | ||||||
| 3693 | # _resolve_host( $host ) -> ip_string | undef | |||||
| 3694 | # | |||||
| 3695 | # Purpose: | |||||
| 3696 | # Resolve a hostname to an IPv4 (or IPv6) address. Uses Net::DNS for | |||||
| 3697 | # both A and AAAA queries when available; falls back to inet_aton for | |||||
| 3698 | # pure IPv4 resolution. | |||||
| 3699 | # | |||||
| 3700 | # Entry criteria: | |||||
| 3701 | # $host -- hostname string or already-numeric IP. | |||||
| 3702 | # | |||||
| 3703 | # Exit status: | |||||
| 3704 | # Returns the first resolved IP string, or undef on failure. | |||||
| 3705 | # | |||||
| 3706 | # Notes: | |||||
| 3707 | # When the input is already a dotted-quad IPv4 it is returned immediately. | |||||
| 3708 | # AAAA records are tried if the A query fails and Net::DNS is available. | |||||
| 3709 | ||||||
| 3710 | sub _resolve_host :Protected { | |||||
| 3711 | 575 | 894 | my ($self, $host) = @_; | |||
| 3712 | 575 | 5310 | return $host if $host =~ /^\d{1,3}(?:\.\d{1,3}){3}$/; | |||
| 3713 | ||||||
| 3714 | # Check the CHI cache before hitting DNS | |||||
| 3715 | 649 | 527 | if ($_cache) { | |||
| 3716 | 1938 | 1862 | my $cached_ip = $_cache->get("resolve:$host"); | |||
| 3717 | 361 | 5486 | return $cached_ip if defined $cached_ip; | |||
| 3718 | } | |||||
| 3719 | ||||||
| 3720 | 159 | 276 | my $ip; | |||
| 3721 | ||||||
| 3722 | 523 | 785 | if ($HAS_NET_DNS) { | |||
| 3723 | my $res = Net::DNS::Resolver->new( | |||||
| 3724 | tcp_timeout => $self->{timeout}, | |||||
| 3725 | udp_timeout => $self->{timeout}, | |||||
| 3726 | 399 | 5487 | ); | |||
| 3727 | ||||||
| 3728 | # Try A record first, then AAAA for IPv6 | |||||
| 3729 | 153 | 186 | for my $type (qw(A AAAA)) { | |||
| 3730 | 94 | 148 | my $query = $res->search($host, $type); | |||
| 3731 | 152 | 3892 | if ($query) { | |||
| 3732 | 399 | 356 | for my $rr ($query->answer) { | |||
| 3733 | 149 | 164 | if ($rr->type eq 'A') { | |||
| 3734 | 517 | 3477 | $ip = $rr->address; | |||
| 3735 | 219 | 202 | last; | |||
| 3736 | } elsif ($rr->type eq 'AAAA') { | |||||
| 3737 | 459 | 373 | $ip = $rr->address; | |||
| 3738 | 100 | 4482 | last; | |||
| 3739 | } | |||||
| 3740 | } | |||||
| 3741 | } | |||||
| 3742 | 159 | 134 | last if defined $ip; | |||
| 3743 | } | |||||
| 3744 | } else { | |||||
| 3745 | # Fallback: gethostbyname (IPv4 only) | |||||
| 3746 | 101 87 | 133 72205 | my $packed = eval { inet_aton($host) }; | |||
| 3747 | 29 | 94 | $ip = $packed ? inet_ntoa($packed) : undef; | |||
| 3748 | } | |||||
| 3749 | ||||||
| 3750 | # Cache the result (including undef as '' to avoid repeated failed lookups) | |||||
| 3751 | 162 | 234 | if ($_cache) { | |||
| 3752 | 94 | 3948 | $_cache->set("resolve:$host", $ip // ''); | |||
| 3753 | } | |||||
| 3754 | ||||||
| 3755 | 85 | 104 | return $ip; | |||
| 3756 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 8658 26 196 3 30 5861 2 11 1139 1 10 1215 1 21 1138 1593 2 14 2130 2 12 1032 2 13 | } | |||
| 3757 | ||||||
| 3758 | # _reverse_dns( $ip ) -> hostname | undef | |||||
| 3759 | # | |||||
| 3760 | # Purpose: | |||||
| 3761 | # Perform a PTR (reverse DNS) lookup for an IP address. Supports both | |||||
| 3762 | # IPv4 and IPv6 via Net::DNS when available; falls back to gethostbyaddr. | |||||
| 3763 | # | |||||
| 3764 | # Entry criteria: | |||||
| 3765 | # $ip -- a defined IPv4 or IPv6 address string. | |||||
| 3766 | # | |||||
| 3767 | # Exit status: | |||||
| 3768 | # Returns the PTR hostname string, or undef if no record exists. | |||||
| 3769 | ||||||
| 3770 | sub _reverse_dns :Protected { | |||||
| 3771 | 112 | 154 | my ($self, $ip) = @_; | |||
| 3772 | 113 | 2705 | return unless $ip; | |||
| 3773 | ||||||
| 3774 | 98 | 217 | if ($HAS_NET_DNS) { | |||
| 3775 | 96 | 259 | my $res = Net::DNS::Resolver->new(tcp_timeout => $self->{timeout}); | |||
| 3776 | 96 | 3280 | my $query = $res->search($ip, 'PTR'); | |||
| 3777 | 468 | 334 | if ($query) { | |||
| 3778 | 2284 | 1617 | for my $rr ($query->answer) { | |||
| 3779 | 454 | 4951 | return $rr->ptrdname if $rr->type eq 'PTR'; | |||
| 3780 | } | |||||
| 3781 | } | |||||
| 3782 | 66 | 60 | return; | |||
| 3783 | } | |||||
| 3784 | ||||||
| 3785 | # Fallback for IPv4 only | |||||
| 3786 | 86 | 380520 | return scalar gethostbyaddr(inet_aton($ip), AF_INET); | |||
| 3787 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 6914 17 833 4 34 6395 2 16 1542 1 10 957 1 10 1796 1302 1 16 1750 1 12 617 1 9 | } | |||
| 3788 | ||||||
| 3789 | # ----------------------------------------------------------------------- | |||||
| 3790 | # Private: WHOIS / RDAP | |||||
| 3791 | # ----------------------------------------------------------------------- | |||||
| 3792 | ||||||
| 3793 | # _whois_ip( $ip ) -> hashref | |||||
| 3794 | # | |||||
| 3795 | # Purpose: | |||||
| 3796 | # Enrich an IP address with organisation name, abuse contact, and country | |||||
| 3797 | # code. Tries RDAP first (if LWP is available), then falls back to raw | |||||
| 3798 | # WHOIS via IANA referral. Results are cached in CHI if available. | |||||
| 3799 | # | |||||
| 3800 | # Entry criteria: | |||||
| 3801 | # $ip -- a defined IPv4 or IPv6 address string. | |||||
| 3802 | # | |||||
| 3803 | # Exit status: | |||||
| 3804 | # Returns { org, abuse, country } hashref; keys absent when unknown. | |||||
| 3805 | ||||||
| 3806 | sub _whois_ip :Protected { | |||||
| 3807 | 161 | 3214 | my ($self, $ip) = @_; | |||
| 3808 | ||||||
| 3809 | # Check CHI cache before going to the network | |||||
| 3810 | 114 | 155 | if ($_cache) { | |||
| 3811 | 93 | 166 | my $cached = $_cache->get("whois_ip:$ip"); | |||
| 3812 | 152 | 4014 | return $cached if $cached; | |||
| 3813 | } | |||||
| 3814 | ||||||
| 3815 | 158 | 296 | my $result = $HAS_LWP ? $self->_rdap_lookup($ip) : {}; | |||
| 3816 | ||||||
| 3817 | # Fall back to raw WHOIS if RDAP returned no organisation | |||||
| 3818 | 158 | 261 | unless ($result->{org}) { | |||
| 3819 | 158 | 3301 | my $raw = $self->_raw_whois($ip, 'whois.iana.org'); | |||
| 3820 | 158 | 528 | if ($raw) { | |||
| 3821 | 27 | 162 | my ($ref) = $raw =~ /whois:\s*([\w.-]+)/i; | |||
| 3822 | 84 | 5163 | my $detail = $ref ? $self->_raw_whois($ip, $ref) : $raw; | |||
| 3823 | 81 | 1148 | $result = $self->_parse_whois_text($detail) if $detail; | |||
| 3824 | } | |||||
| 3825 | } | |||||
| 3826 | ||||||
| 3827 | # Cache the enrichment result | |||||
| 3828 | 141 | 210 | $_cache->set("whois_ip:$ip", $result) if $_cache && $result; | |||
| 3829 | ||||||
| 3830 | 155 | 4728 | return $result; | |||
| 3831 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 8995 23 203 5 34 5271 2 12 1924 2 13 988 2 9 1538 1015 1 10 1673 1 14 1590 2 11 | } | |||
| 3832 | ||||||
| 3833 | # _domain_whois( $domain ) -> raw_whois_string | undef | |||||
| 3834 | # | |||||
| 3835 | # Purpose: | |||||
| 3836 | # Perform a two-step WHOIS lookup for a domain: first ask IANA for the | |||||
| 3837 | # TLD's authoritative WHOIS server, then query that server. | |||||
| 3838 | # | |||||
| 3839 | # Entry criteria: | |||||
| 3840 | # $domain -- a lower-cased domain name string. | |||||
| 3841 | # | |||||
| 3842 | # Exit status: | |||||
| 3843 | # Returns the raw WHOIS response string, or undef on failure. | |||||
| 3844 | ||||||
| 3845 | sub _domain_whois :Protected { | |||||
| 3846 | 85 | 159 | my ($self, $domain) = @_; | |||
| 3847 | 85 | 220 | my $iana = $self->_raw_whois($domain, 'whois.iana.org') // return; | |||
| 3848 | 137 | 3492 | my ($server) = $iana =~ /whois:\s*([\w.-]+)/i; | |||
| 3849 | 137 | 138 | return unless $server; | |||
| 3850 | 131 | 262 | return $self->_raw_whois($domain, $server); | |||
| 3851 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 5975 21 214 4 27 4592 1 14 895 0 10 1384 1 10 946 1083 2 13 732 1 11 1670 2 17 | } | |||
| 3852 | ||||||
| 3853 | # _parse_domain_whois_abuse( $domain ) -> hashref | |||||
| 3854 | # | |||||
| 3855 | # Purpose: | |||||
| 3856 | # Lightweight domain WHOIS lookup to extract only registrar name and | |||||
| 3857 | # abuse contact. Used as a fallback in _extract_and_resolve_urls() when | |||||
| 3858 | # a URL host cannot be resolved to an IP. | |||||
| 3859 | # | |||||
| 3860 | # Entry criteria: | |||||
| 3861 | # $domain -- a registrable domain name string. | |||||
| 3862 | # | |||||
| 3863 | # Exit status: | |||||
| 3864 | # Returns { org, abuse } hashref; empty hashref on failure. | |||||
| 3865 | ||||||
| 3866 | sub _parse_domain_whois_abuse :Private { | |||||
| 3867 | my ($self, $domain) = @_; | |||||
| 3868 | my $raw = $self->_domain_whois($domain) // return {}; | |||||
| 3869 | my %info; | |||||
| 3870 | if ($raw =~ /Registrar:\s*(.+)/i) { | |||||
| 3871 | ($info{org} = $1) =~ s/\s+$//; | |||||
| 3872 | } | |||||
| 3873 | # Try multiple field name patterns for the abuse email | |||||
| 3874 | for my $pat ( | |||||
| 3875 | qr/Registrar Abuse Contact Email:\s*(\S+\@\S+)/i, | |||||
| 3876 | qr/Abuse Contact Email:\s*(\S+\@\S+)/i, | |||||
| 3877 | qr/abuse-contact:\s*(\S+\@\S+)/i, | |||||
| 3878 | ) { | |||||
| 3879 | if (!$info{abuse} && $raw =~ $pat) { | |||||
| 3880 | ($info{abuse} = $1) =~ s/\s+$//; | |||||
| 3881 | } | |||||
| 3882 | } | |||||
| 3883 | return \%info; | |||||
| 3884 | 22 22 22 3 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 7176 25 231 5 28 4491 2 11 2233 1 9 941 1 12 1452 1089 3 14 530 2 12 1538 1 9 | } | |||
| 3885 | ||||||
| 3886 | # _rdap_lookup( $ip ) -> hashref | |||||
| 3887 | # | |||||
| 3888 | # Purpose: | |||||
| 3889 | # Query the ARIN RDAP API for IP block ownership information. RDAP is | |||||
| 3890 | # preferred over raw WHOIS because it returns structured JSON. | |||||
| 3891 | # | |||||
| 3892 | # Entry criteria: | |||||
| 3893 | # $ip -- a defined IPv4 or IPv6 address string. | |||||
| 3894 | # LWP::UserAgent must be installed. | |||||
| 3895 | # | |||||
| 3896 | # Exit status: | |||||
| 3897 | # Returns { org, abuse, country } hashref; empty hashref on failure. | |||||
| 3898 | ||||||
| 3899 | sub _rdap_lookup :Protected { | |||||
| 3900 | 134 | 4156 | my ($self, $ip) = @_; | |||
| 3901 | 75 | 52 | return {} unless $HAS_LWP; | |||
| 3902 | ||||||
| 3903 | 73 | 173 | my $ua = $self->{ua}; | |||
| 3904 | 12 | 2731 | if(!defined($ua)) { | |||
| 3905 | $ua = LWP::UserAgent->new( | |||||
| 3906 | timeout => $self->{timeout}, | |||||
| 3907 | 15 | 17 | agent => "Email-Abuse-Investigator/$VERSION", | |||
| 3908 | ); | |||||
| 3909 | ||||||
| 3910 | 15 | 91 | if($HAS_CONN_CACHE) { | |||
| 3911 | 12 | 23 | my $conn_cache = LWP::ConnCache->new(); | |||
| 3912 | 80 | 74 | $conn_cache->total_capacity(10); | |||
| 3913 | 87 | 228 | $ua->conn_cache($conn_cache); | |||
| 3914 | } | |||||
| 3915 | ||||||
| 3916 | 12 | 17 | $ua->env_proxy(1); | |||
| 3917 | 72 | 151 | $self->{ua} = $ua; | |||
| 3918 | } | |||||
| 3919 | ||||||
| 3920 | # Use the ARIN RDAP endpoint; it covers the ARIN region and redirects | |||||
| 3921 | # for RIPE/APNIC/LACNIC/AfriNIC allocations. | |||||
| 3922 | 15 72 | 28 6522 | my $res = eval { $ua->get("https://rdap.arin.net/registry/ip/$ip") }; | |||
| 3923 | 72 | 68 | return {} unless $res && $res->is_success(); | |||
| 3924 | ||||||
| 3925 | 12 | 124 | my $j = $res->decoded_content(); | |||
| 3926 | 12 | 23 | my %info; | |||
| 3927 | ||||||
| 3928 | # Extract organisation name from the JSON response | |||||
| 3929 | 12 87 | 16 121 | if ($j =~ /"name"\s*:\s*"([^"]+)"/) { $info{org} = $1 } | |||
| 3930 | 147 146 | 136 196 | if ($j =~ /"handle"\s*:\s*"([^"]+)"/) { $info{handle} = $1 } | |||
| 3931 | ||||||
| 3932 | # Extract abuse email from the vcardArray contact block | |||||
| 3933 | 80 | 76 | if ($j =~ /"abuse".*?"email"\s*:\s*"([^"]+)"/s) { | |||
| 3934 | 140 | 811 | $info{abuse} = $1; | |||
| 3935 | } elsif ($j =~ /"email"\s*:\s*"([^@"]+@[^"]+)"/) { | |||||
| 3936 | 78 | 109 | $info{abuse} = $1; | |||
| 3937 | } | |||||
| 3938 | ||||||
| 3939 | # Country code from the network's country field | |||||
| 3940 | 19 78 | 21 65 | if ($j =~ /"country"\s*:\s*"([A-Z]{2})"/) { $info{country} = $1 } | |||
| 3941 | ||||||
| 3942 | 85 | 435 | return \%info; | |||
| 3943 | 22 22 22 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 9784 24 234 3 29 2304 2 12 721 1 15 2220 1 9 2435 1648 2 17 1321 2 13 1072 1 9 | } | |||
| 3944 | ||||||
| 3945 | # _raw_whois( $query, $server ) -> string | undef | |||||
| 3946 | # | |||||
| 3947 | # Purpose: | |||||
| 3948 | # Open a TCP connection to a WHOIS server on port 43, send the query, | |||||
| 3949 | # and return the full response as a string. Uses IO::Select for read | |||||
| 3950 | # timeouts so that alarm() is never needed (alarm() is unreliable on | |||||
| 3951 | # Windows and in threaded Perl). Supports IPv6 WHOIS servers via | |||||
| 3952 | # IO::Socket::IP when that module is available. | |||||
| 3953 | # | |||||
| 3954 | # Entry criteria: | |||||
| 3955 | # $query -- the domain name or IP to query (defined, non-empty). | |||||
| 3956 | # $server -- the WHOIS server hostname (default: 'whois.iana.org'). | |||||
| 3957 | # $self->{timeout} -- seconds used for connect and per-read waits. | |||||
| 3958 | # | |||||
| 3959 | # Exit status: | |||||
| 3960 | # Returns the raw WHOIS response string, or undef on connection/write failure. | |||||
| 3961 | # | |||||
| 3962 | # Notes: | |||||
| 3963 | # Uses IO::Socket::IP (dual-stack) when available, falling back to | |||||
| 3964 | # IO::Socket::INET (IPv4 only) otherwise. The IO::Select loop reads | |||||
| 3965 | # until the server closes the connection or the per-read timeout expires. | |||||
| 3966 | ||||||
| 3967 | sub _raw_whois :Protected { | |||||
| 3968 | 123 | 397 | my ($self, $query, $server) = @_; | |||
| 3969 | 66 | 127 | $server //= 'whois.iana.org'; | |||
| 3970 | 62 | 490 | $self->_debug("WHOIS $server -> $query"); | |||
| 3971 | ||||||
| 3972 | # Choose the socket class based on what is installed. | |||||
| 3973 | # IO::Socket::IP supports both IPv4 and IPv6 WHOIS servers. | |||||
| 3974 | 75 | 160 | my $sock_class = $HAS_IO_SOCKET_IP ? 'IO::Socket::IP' : 'IO::Socket::INET'; | |||
| 3975 | ||||||
| 3976 | # Attempt TCP connection to port 43 on the WHOIS server | |||||
| 3977 | 79 | 157 | my $sock = eval { | |||
| 3978 | $sock_class->new( | |||||
| 3979 | PeerAddr => $server, | |||||
| 3980 | PeerPort => $WHOIS_PORT, | |||||
| 3981 | Proto => 'tcp', | |||||
| 3982 | Timeout => $self->{timeout}, | |||||
| 3983 | 77 | 363 | ); | |||
| 3984 | }; | |||||
| 3985 | 51 | 4218226 | return unless $sock; | |||
| 3986 | ||||||
| 3987 | # Send the WHOIS query in wire format (CRLF-terminated per RFC 3912) | |||||
| 3988 | 73 32 39 | 382 37 42 | $sock->print("$query\r\n") or do { $sock->close(); return }; | |||
| 3989 | ||||||
| 3990 | # Use IO::Select to implement per-read timeouts without alarm() | |||||
| 3991 | 71 | 2137 | my $sel = IO::Select->new($sock); | |||
| 3992 | 153 | 2152 | my $response = ''; | |||
| 3993 | 132 | 167 | my $buf = ''; | |||
| 3994 | ||||||
| 3995 | # Read until EOF (server closes) or timeout | |||||
| 3996 | 191 | 550 | while ($sel->can_read($self->{timeout})) { | |||
| 3997 | # Wrap in eval to catch 'Connection reset by peer' thrown by Fatal/autodie | |||||
| 3998 | 268 272 | 3457647 562 | my $n = eval { sysread($sock, $buf, $WHOIS_READ_CHUNK) }; | |||
| 3999 | ||||||
| 4000 | 281 | 9754 | if ($@ || !defined $n || $n <= 0) { | |||
| 4001 | 130 | 192 | $self->_debug("WHOIS read failed: $@") if $@; | |||
| 4002 | 365 | 357 | last; | |||
| 4003 | } | |||||
| 4004 | 217 | 510 | last if !defined($n) || $n <= 0; | |||
| 4005 | 137 | 423 | $response .= $buf; | |||
| 4006 | } | |||||
| 4007 | ||||||
| 4008 | 77 | 251 | $sock->close(); | |||
| 4009 | 76 | 2822 | return $response || undef; | |||
| 4010 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 7484 23 188 1 12 1 1 12 2 2 11 2 1 13 2 1427 2 10 1389 2 11 836 1 9 | } | |||
| 4011 | ||||||
| 4012 | # _parse_whois_text( $text ) -> hashref | |||||
| 4013 | # | |||||
| 4014 | # Purpose: | |||||
| 4015 | # Parse a raw WHOIS IP block response to extract organisation name, | |||||
| 4016 | # abuse contact email, and country code. | |||||
| 4017 | # | |||||
| 4018 | # Entry criteria: | |||||
| 4019 | # $text -- a defined WHOIS response string. | |||||
| 4020 | # | |||||
| 4021 | # Exit status: | |||||
| 4022 | # Returns { org, abuse, country } hashref; keys absent when not found. | |||||
| 4023 | ||||||
| 4024 | sub _parse_whois_text :Private { | |||||
| 4025 | my ($self, $text) = @_; | |||||
| 4026 | return {} unless $text; | |||||
| 4027 | my %info; | |||||
| 4028 | ||||||
| 4029 | # Try multiple field names for the organisation name | |||||
| 4030 | for my $pat ( | |||||
| 4031 | qr/^OrgName:\s*(.+)/mi, qr/^org-name:\s*(.+)/mi, | |||||
| 4032 | qr/^owner:\s*(.+)/mi, qr/^descr:\s*(.+)/mi, | |||||
| 4033 | ) { | |||||
| 4034 | if (!$info{org} && $text =~ $pat) { | |||||
| 4035 | ($info{org} = $1) =~ s/\s+$//; | |||||
| 4036 | } | |||||
| 4037 | } | |||||
| 4038 | ||||||
| 4039 | # Try multiple field names for the abuse email | |||||
| 4040 | for my $pat ( | |||||
| 4041 | qr/OrgAbuseEmail:\s*(\S+@\S+)/mi, | |||||
| 4042 | qr/abuse-mailbox:\s*(\S+@\S+)/mi, | |||||
| 4043 | ) { | |||||
| 4044 | if (!$info{abuse} && $text =~ $pat) { | |||||
| 4045 | ($info{abuse} = $1) =~ s/\s+$//; | |||||
| 4046 | } | |||||
| 4047 | } | |||||
| 4048 | ||||||
| 4049 | # Last-resort: any abuse@ address in the response | |||||
| 4050 | if (!$info{abuse} && $text =~ /(abuse\@[\w.-]+)/i) { $info{abuse} = $1 } | |||||
| 4051 | ||||||
| 4052 | # Country code (case-insensitive match, normalised to uppercase) | |||||
| 4053 | if ($text =~ /^country:\s*([A-Za-z]{2})\s*$/m) { | |||||
| 4054 | $info{country} = uc $1; | |||||
| 4055 | } | |||||
| 4056 | return \%info; | |||||
| 4057 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 10647 20 186 2 34 2 1 31 2 1 31 2 1 53 3 1679 1 15 1245 1 13 867 1 9 | } | |||
| 4058 | ||||||
| 4059 | # ----------------------------------------------------------------------- | |||||
| 4060 | # Private: authentication results parsing | |||||
| 4061 | # ----------------------------------------------------------------------- | |||||
| 4062 | ||||||
| 4063 | # _parse_auth_results_cached() -> hashref | |||||
| 4064 | # | |||||
| 4065 | # Purpose: | |||||
| 4066 | # Parse the Authentication-Results: header(s) from the message once, | |||||
| 4067 | # cache the result, and return it. Extracts SPF, DKIM, DMARC, ARC | |||||
| 4068 | # results and the DKIM signing domain(s). | |||||
| 4069 | # | |||||
| 4070 | # Entry criteria: | |||||
| 4071 | # $self->{_headers} populated by _split_message(). | |||||
| 4072 | # | |||||
| 4073 | # Exit status: | |||||
| 4074 | # Returns { spf, dkim, dmarc, arc, dkim_domain, dkim_domains } hashref. | |||||
| 4075 | # Keys absent when the corresponding header or field is not present. | |||||
| 4076 | ||||||
| 4077 | sub _parse_auth_results_cached :Private { | |||||
| 4078 | my $self = $_[0]; | |||||
| 4079 | return $self->{_auth_results} if $self->{_auth_results}; | |||||
| 4080 | ||||||
| 4081 | my %auth; | |||||
| 4082 | ||||||
| 4083 | # Concatenate all Authentication-Results: header values | |||||
| 4084 | my $raw = join('; ', | |||||
| 4085 | map { $_->{value} } | |||||
| 4086 | grep { $_->{name} eq 'authentication-results' } | |||||
| 4087 | @{ $self->{_headers} } | |||||
| 4088 | ); | |||||
| 4089 | ||||||
| 4090 | # Extract individual authentication mechanism results | |||||
| 4091 | if ($raw =~ /\bspf=(\S+)/i) { $auth{spf} = $1 } | |||||
| 4092 | if ($raw =~ /\bdkim=(\S+)/i) { $auth{dkim} = $1 } | |||||
| 4093 | if ($raw =~ /\bdmarc=(\S+)/i) { $auth{dmarc} = $1 } | |||||
| 4094 | if ($raw =~ /\barc=(\S+)/i) { $auth{arc} = $1 } | |||||
| 4095 | ||||||
| 4096 | # Strip trailing punctuation captured by the greedy \S+ | |||||
| 4097 | for my $k (qw(spf dkim dmarc arc)) { | |||||
| 4098 | $auth{$k} =~ s/[;,\s]+$// if defined $auth{$k}; | |||||
| 4099 | } | |||||
| 4100 | ||||||
| 4101 | # Extract DKIM signing domains from all DKIM-Signature: d= tags. | |||||
| 4102 | # Prefer the first domain that matches the provider table (identifies ESP). | |||||
| 4103 | my @dkim_domains; | |||||
| 4104 | for my $h (grep { $_->{name} eq 'dkim-signature' } @{ $self->{_headers} }) { | |||||
| 4105 | if ($h->{value} =~ /\bd=([^;,\s]+)/) { | |||||
| 4106 | push @dkim_domains, lc $1; | |||||
| 4107 | } | |||||
| 4108 | } | |||||
| 4109 | ||||||
| 4110 | if (@dkim_domains) { | |||||
| 4111 | # Check if any signing domain matches a known provider | |||||
| 4112 | my $preferred; | |||||
| 4113 | for my $d (@dkim_domains) { | |||||
| 4114 | if ($self->_provider_abuse_for_host($d)) { | |||||
| 4115 | $preferred = $d; | |||||
| 4116 | last; | |||||
| 4117 | } | |||||
| 4118 | } | |||||
| 4119 | $auth{dkim_domain} = $preferred // $dkim_domains[0]; | |||||
| 4120 | $auth{dkim_domains} = \@dkim_domains; | |||||
| 4121 | } | |||||
| 4122 | ||||||
| 4123 | $self->{_auth_results} = \%auth; | |||||
| 4124 | return \%auth; | |||||
| 4125 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 9639 23 196 1 3 2286 1 3 2215 1 4 2199 0 4 2283 1289 2 13 1887 2 14 781 2 11 | } | |||
| 4126 | ||||||
| 4127 | # ----------------------------------------------------------------------- | |||||
| 4128 | # Private: provider-table lookups | |||||
| 4129 | # ----------------------------------------------------------------------- | |||||
| 4130 | ||||||
| 4131 | # _provider_abuse_for_host( $host ) -> hashref | undef | |||||
| 4132 | # | |||||
| 4133 | # Purpose: | |||||
| 4134 | # Look up a hostname (and each of its parent domains, stripping one label | |||||
| 4135 | # at a time from the left) in the %PROVIDER_ABUSE table. | |||||
| 4136 | # | |||||
| 4137 | # Entry criteria: | |||||
| 4138 | # $host -- a defined hostname or domain string. | |||||
| 4139 | # | |||||
| 4140 | # Exit status: | |||||
| 4141 | # Returns the %PROVIDER_ABUSE entry hashref on match, undef otherwise. | |||||
| 4142 | ||||||
| 4143 | sub _provider_abuse_for_host :Private { | |||||
| 4144 | my ($self, $host) = @_; | |||||
| 4145 | $host = lc $host; | |||||
| 4146 | # Strip successive subdomains until we find a match or exhaust labels | |||||
| 4147 | while ($host =~ /\./) { | |||||
| 4148 | return $self->{provider_abuse}->{$host} if $self->{provider_abuse}->{$host}; | |||||
| 4149 | return $PROVIDER_ABUSE{$host} if $PROVIDER_ABUSE{$host}; | |||||
| 4150 | $host =~ s/^[^.]+\.//; | |||||
| 4151 | } | |||||
| 4152 | return; | |||||
| 4153 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 5666 22 227 1 33 3 1 36 2 1 36 3 1 38 2 657 1 12 1110 2 12 1094 2 12 | } | |||
| 4154 | ||||||
| 4155 | # _provider_abuse_for_ip( $ip, $rdns ) -> hashref | undef | |||||
| 4156 | # | |||||
| 4157 | # Purpose: | |||||
| 4158 | # Look up an IP's reverse-DNS hostname in the %PROVIDER_ABUSE table to | |||||
| 4159 | # identify well-known provider networks by rDNS pattern. | |||||
| 4160 | # | |||||
| 4161 | # Entry criteria: | |||||
| 4162 | # $ip -- IPv4 or IPv6 address string (used as fallback if $rdns absent). | |||||
| 4163 | # $rdns -- optional rDNS hostname string. | |||||
| 4164 | # | |||||
| 4165 | # Exit status: | |||||
| 4166 | # Returns the %PROVIDER_ABUSE entry on match, undef otherwise. | |||||
| 4167 | ||||||
| 4168 | sub _provider_abuse_for_ip :Private { | |||||
| 4169 | my ($self, $ip, $rdns) = @_; | |||||
| 4170 | return $self->_provider_abuse_for_host($rdns) if $rdns; | |||||
| 4171 | return; | |||||
| 4172 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 5678 57 174 1 13 2 0 16 1 1 15 2 1 15 2 1163 1 17 888 2 11 1614 2 12 | } | |||
| 4173 | ||||||
| 4174 | # ----------------------------------------------------------------------- | |||||
| 4175 | # Private: eTLD+1 normalisation | |||||
| 4176 | # ----------------------------------------------------------------------- | |||||
| 4177 | ||||||
| 4178 | # _registrable( $host ) -> string | undef | |||||
| 4179 | # | |||||
| 4180 | # Purpose: | |||||
| 4181 | # Return the registrable eTLD+1 form of a hostname. Uses | |||||
| 4182 | # Domain::PublicSuffix when installed for accurate results; falls back | |||||
| 4183 | # to a built-in heuristic for the common two-letter ccTLD+2 pattern. | |||||
| 4184 | # | |||||
| 4185 | # Entry criteria: | |||||
| 4186 | # $host -- a hostname string (may include subdomains). | |||||
| 4187 | # | |||||
| 4188 | # Exit status: | |||||
| 4189 | # Returns the registrable domain string, or undef for single-label | |||||
| 4190 | # hostnames (e.g. 'localhost'). | |||||
| 4191 | # | |||||
| 4192 | # Notes: | |||||
| 4193 | # The heuristic handles co.uk, com.au, net.jp, org.nz etc. but not | |||||
| 4194 | # uncommon second-level delegations like ltd.uk or plc.uk. | |||||
| 4195 | ||||||
| 4196 | sub _registrable :Private { | |||||
| 4197 | my $host = $_[0]; | |||||
| 4198 | return unless $host && $host =~ /\./; | |||||
| 4199 | ||||||
| 4200 | # Use Domain::PublicSuffix for accurate PSL-based normalisation | |||||
| 4201 | if ($HAS_PUBLIC_SUFFIX) { | |||||
| 4202 | my $psl = Domain::PublicSuffix->new(); | |||||
| 4203 | my $root = $psl->get_root_domain(lc $host); | |||||
| 4204 | return $root if $root; | |||||
| 4205 | } | |||||
| 4206 | ||||||
| 4207 | # Built-in heuristic fallback | |||||
| 4208 | my @labels = split /\./, lc $host; | |||||
| 4209 | return $host if @labels <= 2; | |||||
| 4210 | ||||||
| 4211 | # Detect common ccTLD second-level patterns (e.g. co.uk, com.au) | |||||
| 4212 | if ($labels[-1] =~ /^[a-z]{2}$/ && | |||||
| 4213 | $labels[-2] =~ /^(?:co|com|net|org|gov|edu|ac|me)$/) { | |||||
| 4214 | return join('.', @labels[-3..-1]); | |||||
| 4215 | } | |||||
| 4216 | return join('.', @labels[-2..-1]); | |||||
| 4217 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 7245 85 182 1 5 217 1 4 235 1 6 276 1 5 265 1324 1 14 1873 1 13 768 1 9 | } | |||
| 4218 | ||||||
| 4219 | # ----------------------------------------------------------------------- | |||||
| 4220 | # Private: utilities | |||||
| 4221 | # ----------------------------------------------------------------------- | |||||
| 4222 | ||||||
| 4223 | # _enrich_ip( $ip, $confidence, $note ) -> origin hashref | |||||
| 4224 | # | |||||
| 4225 | # Purpose: | |||||
| 4226 | # Perform rDNS and WHOIS/RDAP for a single IP and package the results | |||||
| 4227 | # into the standard origin hashref returned by originating_ip(). | |||||
| 4228 | # | |||||
| 4229 | # Entry criteria: | |||||
| 4230 | # $ip -- a defined, non-private IPv4 or IPv6 address string. | |||||
| 4231 | # $confidence -- 'high', 'medium', or 'low'. | |||||
| 4232 | # $note -- human-readable explanation of why this IP was chosen. | |||||
| 4233 | # | |||||
| 4234 | # Exit status: | |||||
| 4235 | # Returns { ip, rdns, org, abuse, country, confidence, note } hashref. | |||||
| 4236 | ||||||
| 4237 | sub _enrich_ip :Private { | |||||
| 4238 | my ($self, $ip, $confidence, $note) = @_; | |||||
| 4239 | my $rdns = $self->_reverse_dns($ip); | |||||
| 4240 | my $whois = $self->_whois_ip($ip); | |||||
| 4241 | return { | |||||
| 4242 | ip => $ip, | |||||
| 4243 | rdns => $rdns // '(no reverse DNS)', | |||||
| 4244 | org => $whois->{org} // '(unknown)', | |||||
| 4245 | abuse => $whois->{abuse} // '(unknown)', | |||||
| 4246 | country => $whois->{country} // undef, | |||||
| 4247 | confidence => $confidence, | |||||
| 4248 | note => $note, | |||||
| 4249 | }; | |||||
| 4250 | 22 22 22 14 14 14 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 4973 25 173 15 9 20 1 1 2 2 1 5 2 2 4 541 1 9 1787 2 12 1124 1 11 | } | |||
| 4251 | ||||||
| 4252 | # _header_value( $name ) -> value_string | undef | |||||
| 4253 | # | |||||
| 4254 | # Purpose: | |||||
| 4255 | # Return the value of the first header matching the given lower-cased | |||||
| 4256 | # header name. | |||||
| 4257 - 4311 | =head2 header_value( $name )
Returns the value of the first occurrence of a named header field, or
C<undef> if the header is absent. The name comparison is case-insensitive.
=head3 Usage
my $subj = $analyser->header_value('Subject');
my $from = $analyser->header_value('From');
my $msgid = $analyser->header_value('Message-ID');
=head3 Arguments
=over 4
=item C<$name> (string, required)
The header field name, e.g. C<'Subject'>, C<'From'>, C<'X-Mailer'>.
Comparison is case-insensitive.
=back
=head3 Returns
The raw header value string (not decoded), or C<undef> if the named header
is not present. When the same header appears more than once, only the value
of the first occurrence is returned.
=head3 Side Effects
None. Header data is pre-parsed during C<parse_email()>.
=head3 Notes
Header values are returned verbatim, including any MIME encoded-word sequences
(C<=?charset?B/Q?...?=>). Pass the result through C<_decode_mime_words()>
internally if human-readable output is needed.
=head3 API Specification
=head4 Input
{
name => { type => 'string', required => 1 },
}
=head4 Output
{ type => [ 'string', 'undef' ] }
=head3 Messages
None -- returns C<undef> on a missing header, never throws.
=cut | |||||
| 4312 | ||||||
| 4313 | sub header_value { | |||||
| 4314 | 94 1 | 13513 1 | my $self = shift; | |||
| 4315 | ||||||
| 4316 | 94 1 | 120 10 | my $params = Params::Validate::Strict::validate_strict({ | |||
| 4317 | args => Params::Get::get_params('name', \@_) || {}, | |||||
| 4318 | schema => { | |||||
| 4319 | name => { | |||||
| 4320 | 'type' => 'string', | |||||
| 4321 | 'optional' => 0, | |||||
| 4322 | } | |||||
| 4323 | } | |||||
| 4324 | }); | |||||
| 4325 | ||||||
| 4326 | 94 1 | 2899 1317 | return if((!defined($params)) || !defined($params->{name})); | |||
| 4327 | 94 1 | 5290 1 | return if ref($params->{name}); | |||
| 4328 | 130 1 | 146 10 | return $self->_header_value($params->{name}); | |||
| 4329 | } | |||||
| 4330 | ||||||
| 4331 | # | |||||
| 4332 | # _header_value( $name ) -> string | undef | |||||
| 4333 | # | |||||
| 4334 | # Purpose: | |||||
| 4335 | # Internal implementation for header_value(). Walks _headers list and | |||||
| 4336 | # returns the value of the first matching header. | |||||
| 4337 | # | |||||
| 4338 | # Entry criteria: | |||||
| 4339 | # $name -- a lower-cased header name string. | |||||
| 4340 | # $self->{_headers} populated by _split_message(). | |||||
| 4341 | # | |||||
| 4342 | # Exit status: | |||||
| 4343 | # Returns the value string, or undef if the header is not present. | |||||
| 4344 | ||||||
| 4345 | sub _header_value :Private { | |||||
| 4346 | my ($self, $name) = @_; | |||||
| 4347 | for my $h (@{ $self->{_headers} }) { | |||||
| 4348 | return $h->{value} if $h->{name} eq lc($name); | |||||
| 4349 | } | |||||
| 4350 | return; | |||||
| 4351 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 7564 174 177 130 2 3 120 1 4 183 1 5 140 1 5 1159 1 9 1469 1 9 658 2 12 | } | |||
| 4352 | ||||||
| 4353 | # _ip_in_cidr( $ip, $cidr ) -> bool | |||||
| 4354 | # | |||||
| 4355 | # Purpose: | |||||
| 4356 | # Test whether an IPv4 address falls within a CIDR block or is an exact | |||||
| 4357 | # match (when $cidr contains no '/' separator). | |||||
| 4358 | # | |||||
| 4359 | # Entry criteria: | |||||
| 4360 | # $ip -- a defined dotted-quad IPv4 address string. | |||||
| 4361 | # $cidr -- a CIDR string like '10.0.0.0/8' or an exact IP. | |||||
| 4362 | # | |||||
| 4363 | # Exit status: | |||||
| 4364 | # Returns 1 (true) if the IP is within the CIDR block, 0 otherwise. | |||||
| 4365 | ||||||
| 4366 | sub _ip_in_cidr :Private { | |||||
| 4367 | my ($self, $ip, $cidr) = @_; | |||||
| 4368 | return $ip eq $cidr unless $cidr =~ m{/}; | |||||
| 4369 | my ($net_addr, $prefix) = split m{/}, $cidr; | |||||
| 4370 | return 0 if !defined($prefix) || $prefix !~ /^\d+$/ || $prefix > 32; | |||||
| 4371 | ||||||
| 4372 | # Compute the network mask and compare masked network addresses | |||||
| 4373 | my $mask = ~0 << (32 - $prefix); | |||||
| 4374 | my $net_n = unpack 'N', (inet_aton($net_addr) // return 0); | |||||
| 4375 | my $ip_n = unpack 'N', (inet_aton($ip) // return 0); | |||||
| 4376 | return ($ip_n & $mask) == ($net_n & $mask); | |||||
| 4377 | 22 22 22 14 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 6341 23 179 85 1 23 72 0 26 86 1 28 75 1 27 1102 2 13 706 1 13 1630 2 12 | } | |||
| 4378 | ||||||
| 4379 | # _decode_mime_words( $str ) -> decoded_string | |||||
| 4380 | # | |||||
| 4381 | # Purpose: | |||||
| 4382 | # Decode MIME encoded-words (=?charset?B/Q?...?=) in a header value | |||||
| 4383 | # string for human-readable display in reports. | |||||
| 4384 | # | |||||
| 4385 | # Entry criteria: | |||||
| 4386 | # $str -- a defined header value string; may be undef. | |||||
| 4387 | # | |||||
| 4388 | # Exit status: | |||||
| 4389 | # Returns the decoded string, or '' if $str is undef. | |||||
| 4390 | ||||||
| 4391 | sub _decode_mime_words :Private { | |||||
| 4392 | my ($self, $str) = @_; | |||||
| 4393 | return '' unless defined $str; | |||||
| 4394 | # Replace each encoded-word with its decoded equivalent | |||||
| 4395 | $str =~ s/=\?([^?]+)\?([BbQq])\?([^?]*)\?=/_decode_ew($1,$2,$3)/ge; | |||||
| 4396 | return $str; | |||||
| 4397 | 22 22 22 1 14 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 4933 18 171 2 16 13 2 0 17 4 2 19 2 2 13 822 1 14 769 1 13 1547 1 11 | } | |||
| 4398 | ||||||
| 4399 | # _decode_ew( $charset, $enc, $text ) -> decoded_bytes | |||||
| 4400 | # | |||||
| 4401 | # Purpose: | |||||
| 4402 | # Decode a single MIME encoded-word component (base64 or quoted-printable). | |||||
| 4403 | # | |||||
| 4404 | # Notes: | |||||
| 4405 | # Non-UTF-8 charsets return raw bytes; good enough for display-name spoof | |||||
| 4406 | # detection which only needs ASCII matching. | |||||
| 4407 | ||||||
| 4408 | sub _decode_ew :Private { | |||||
| 4409 | my ($charset, $enc, $text) = @_; | |||||
| 4410 | my $raw; | |||||
| 4411 | if (uc($enc) eq 'B') { | |||||
| 4412 | $raw = decode_base64($text); | |||||
| 4413 | } else { | |||||
| 4414 | # Quoted-printable encoded-word uses underscore for space | |||||
| 4415 | $text =~ s/_/ /g; | |||||
| 4416 | $raw = decode_qp($text); | |||||
| 4417 | } | |||||
| 4418 | return $raw; | |||||
| 4419 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 5648 17 169 2 1 10 1 1 10 2 1 9 2 1 12 1259 1 10 1031 1 13 1804 3 11 | } | |||
| 4420 | ||||||
| 4421 | # _parse_date_to_epoch( $str ) -> epoch_int | undef | |||||
| 4422 | # | |||||
| 4423 | # Purpose: | |||||
| 4424 | # Parse common WHOIS date strings to a Unix epoch integer. | |||||
| 4425 | # Handles YYYY-MM-DD, YYYY-MM-DDThh:mm:ssZ, and DD-Mon-YYYY formats. | |||||
| 4426 | # | |||||
| 4427 | # Entry criteria: | |||||
| 4428 | # $str -- a defined date string; may be undef. | |||||
| 4429 | # | |||||
| 4430 | # Exit status: | |||||
| 4431 | # Returns epoch integer on success, undef if the string cannot be parsed. | |||||
| 4432 | ||||||
| 4433 | sub _parse_date_to_epoch :Private { | |||||
| 4434 | my ($self, $str) = @_; | |||||
| 4435 | return unless $str; | |||||
| 4436 | ||||||
| 4437 | # Clean the string of trailing whitespace/newlines | |||||
| 4438 | $str =~ s/^\s+|\s+$//g; | |||||
| 4439 | ||||||
| 4440 | # Guard Regex: Validates the strict YYYY-MM-DDThh:mm:ssZ format | |||||
| 4441 | if ($str =~ /^(\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2})(?:\.\d+)?Z$/) { | |||||
| 4442 | # Parse the string | |||||
| 4443 | # We use 'strptime' to create a Time::Piece object. | |||||
| 4444 | # The 'Z' indicates UTC (Zulu time). | |||||
| 4445 | my $epoch = eval { | |||||
| 4446 | my $t = Time::Piece->strptime($1, '%Y-%m-%dT%H:%M:%S'); | |||||
| 4447 | ||||||
| 4448 | # Return seconds since the epoch | |||||
| 4449 | # Time::Piece handles the timezone offset internally when calling ->epoch | |||||
| 4450 | ||||||
| 4451 | # strptime returns a local time object. | |||||
| 4452 | # We must subtract the local timezone offset to get the true UTC epoch. | |||||
| 4453 | return $t->epoch - $t->tzoffset->seconds; | |||||
| 4454 | }; | |||||
| 4455 | return $epoch if defined $epoch; | |||||
| 4456 | } | |||||
| 4457 | my ($y, $m, $d); | |||||
| 4458 | ||||||
| 4459 | if ($str =~ /^(\d{4})-(\d{2})-(\d{2})/) { ($y,$m,$d)=($1,$2,$3) } | |||||
| 4460 | elsif ($str =~ /^(\d{2})-([A-Za-z]{3})-(\d{4})/) { ($d,$m,$y)=($1,$Readonly::Values::Months::months{lc$2}//0,$3) } | |||||
| 4461 | elsif ($str =~ /^(\d{2})\/(\d{2})\/(\d{4})/) { ($m,$d,$y)=($1,$2,$3) } | |||||
| 4462 | ||||||
| 4463 | return unless $y && $m && $d; | |||||
| 4464 | ||||||
| 4465 | if (eval { require Time::Local; 1 }) { | |||||
| 4466 | return eval { Time::Local::timegm(0,0,0,$d,$m-1,$y-1900) }; | |||||
| 4467 | } | |||||
| 4468 | # Approximate fallback without Time::Local | |||||
| 4469 | return ($y-1970)*365.25*$SECS_PER_DAY + ($m-1)*30.5*$SECS_PER_DAY + ($d-1)*$SECS_PER_DAY; | |||||
| 4470 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 9610 22 782 2 1 16 2 1 18 1 1 23 1 1 18 680 1 8 955 1 13 1287 2 12 | } | |||
| 4471 | ||||||
| 4472 | # _parse_rfc2822_date( $str ) -> epoch_int | undef | |||||
| 4473 | # | |||||
| 4474 | # Purpose: | |||||
| 4475 | # Parse an RFC 2822 Date: header value to a Unix epoch integer. | |||||
| 4476 | # Timezone offsets are intentionally ignored; the function returns a | |||||
| 4477 | # UTC-equivalent value. For the 7-day suspicious_date window the | |||||
| 4478 | # maximum error is ~14 hours, well within the tolerance. | |||||
| 4479 | # | |||||
| 4480 | # Entry criteria: | |||||
| 4481 | # $str -- a defined Date: header value string. | |||||
| 4482 | # | |||||
| 4483 | # Exit status: | |||||
| 4484 | # Returns epoch integer on success, undef if the string cannot be parsed. | |||||
| 4485 | ||||||
| 4486 | sub _parse_rfc2822_date :Private { | |||||
| 4487 | my $str = $_[0]; | |||||
| 4488 | return unless $str; | |||||
| 4489 | ||||||
| 4490 | # Match: DD Mon YYYY HH:MM:SS (timezone offset ignored) | |||||
| 4491 | if ($str =~ /(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{2}):(\d{2}):(\d{2})/) { | |||||
| 4492 | my ($d, $m, $y, $H, $M, $S) = | |||||
| 4493 | ($1, $Readonly::Values::Months::months{ lc $2 } // 0, $3, $4, $5, $6); | |||||
| 4494 | return unless $m; | |||||
| 4495 | if (eval { require Time::Local; 1 }) { | |||||
| 4496 | return eval { Time::Local::timegm($S, $M, $H, $d, $m - 1, $y - 1900) }; | |||||
| 4497 | } | |||||
| 4498 | } | |||||
| 4499 | return; | |||||
| 4500 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 6987 22 187 2 12 14 2 12 14 2 13 14 2 13 18 574 1 8 982 2 11 1096 2 10 | } | |||
| 4501 | ||||||
| 4502 | # _country_name( $cc ) -> country_name_string | |||||
| 4503 | # | |||||
| 4504 | # Purpose: | |||||
| 4505 | # Return a human-readable country name for a two-letter ISO 3166-1 | |||||
| 4506 | # alpha-2 country code. Only the small set of statistically high-volume | |||||
| 4507 | # spam-originating countries is covered; other codes are returned as-is. | |||||
| 4508 | # | |||||
| 4509 | # Entry criteria: | |||||
| 4510 | # $cc -- a two-letter uppercase country code string. | |||||
| 4511 | # | |||||
| 4512 | # Exit status: | |||||
| 4513 | # Returns the country name string, or the code itself if not in the table. | |||||
| 4514 | ||||||
| 4515 | sub _country_name :Private { | |||||
| 4516 | my $cc = $_[0]; | |||||
| 4517 | my %names = ( | |||||
| 4518 | CN => 'China', RU => 'Russia', NG => 'Nigeria', | |||||
| 4519 | VN => 'Vietnam', IN => 'India', PK => 'Pakistan', | |||||
| 4520 | BD => 'Bangladesh', | |||||
| 4521 | ); | |||||
| 4522 | return $names{$cc} // $cc; | |||||
| 4523 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 5397 24 167 2 1 98 1 1 18 2 1 15 2 0 16 497 1 8 1094 1 12 1156 2 10 | } | |||
| 4524 | ||||||
| 4525 | # _debug( $msg ) | |||||
| 4526 | # | |||||
| 4527 | # Purpose: | |||||
| 4528 | # Write a diagnostic message to STDERR when verbose mode is enabled. | |||||
| 4529 | # | |||||
| 4530 | # Entry criteria: | |||||
| 4531 | # $msg -- a defined message string. | |||||
| 4532 | # | |||||
| 4533 | # Notes: | |||||
| 4534 | # Messages are prefixed with the class name for easy grepping. | |||||
| 4535 | ||||||
| 4536 | sub _debug :Private { | |||||
| 4537 | my ($self, $msg) = @_; | |||||
| 4538 | ||||||
| 4539 | if($self->{verbose}) { | |||||
| 4540 | if (my $logger = $self->{logger}) { # Set via Object::Configure | |||||
| 4541 | $logger->debug("[Email::Abuse::Investigator] $msg"); | |||||
| 4542 | } else { | |||||
| 4543 | print STDERR "[Email::Abuse::Investigator] $msg\n"; | |||||
| 4544 | } | |||||
| 4545 | } | |||||
| 4546 | 22 22 22 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 | 5725 22 169 2 1 104 1 1 70 2 1 79 2 1 74 2286 1 13 1372 1 12 1153 2 12 | } | |||
| 4547 | ||||||
| 4548 | 1; | |||||
| 4549 | ||||||