File Coverage

File:bin/submit_abuse_report
Coverage:49.4%

linestmtbrancondsubtimecode
1#!/usr/bin/env perl
2# -----------------------------------------------------------------------
3# submit_abuse_report -- analyse a spam/phishing email and send abuse
4#                           reports to all relevant parties.
5#
6# Usage:
7#   submit_abuse_report [options] spam.eml
8#   submit_abuse_report [options] < spam.eml
9#
10# Options:
11#   --dry-run              Show what would be sent and to whom; do not
12#                          actually connect to any mail server.
13#   -i, --interactive      Prompt for confirmation before each send.
14#   --bcc                  Send a copy to the --from address for monitoring.
15#   --bcc-to ADDRESS       Send a copy to an explicit address.
16#   --from ADDRESS         Envelope / From: address for the outgoing
17#                          reports (required unless --dry-run).
18#   --smtp HOST[:PORT]     SMTP relay to use (default: localhost:25).
19#   --trusted CIDR         Trusted relay CIDR to skip in Received: chain.
20#                          May be repeated for multiple relays.
21#   --timeout SECS         Network timeout in seconds (default: 15).
22#   --verbose              Print analysis progress to STDERR.
23#   --help                 Show this help text.
24#
25# Examples:
26#   # Dry run -- see what would be sent without sending anything
27#   submit_abuse_report --dry-run spam.eml
28#
29#   # Send reports via the local MTA
30#   submit_abuse_report --from postmaster@myisp.example spam.eml
31#
32#   # Send via a specific SMTP relay, skipping our own outbound IP
33#   submit_abuse_report \
34#       --from abuse-reporter@example.com \
35#       --smtp mail.example.com:587 \
36#       --trusted 203.0.113.0/24 \
37#       spam.eml
38# -----------------------------------------------------------------------
39
7
7
7
14463
10
use 5.010;
40
7
7
7
7
11
7
64
use strict;
41
7
7
7
7
10
6
109
use warnings;
42
7
7
7
7
1241
701
17
use utf8;
43
7
7
7
7
1373
3479
18
use open qw(:std :encoding(UTF-8));
44
45
7
7
7
7
57559
32379
13
use Getopt::Long qw(GetOptions);
46
7
7
7
7
1951
134381
1381
use Pod::Usage   qw(pod2usage);
47
7
7
7
7
3864
333099
235
use Net::SMTP;
48
7
7
7
7
1322
2113
229
use MIME::Base64 qw(encode_base64);
49
7
7
7
7
22
5
21
use POSIX        qw(strftime);
50
7
7
7
7
200
6
218
use File::Basename qw(basename);
51
7
7
7
7
1248
2079
16
use lib '.';     # find Email/Abuse/Investigator.pm in development tree
52
7
7
7
7
3402
16
17411
use Email::Abuse::Investigator;
53
54# -----------------------------------------------------------------------
55# Command-line options
56# -----------------------------------------------------------------------
57
7
734579
my $dry_run     = 0;
58
7
10
my $interactive = 0;
59
7
8
my $bcc      = 0;      # --bcc flag: copy to --from address
60
7
8
my $bcc_to   = '';     # --bcc-to ADDRESS: copy to explicit address
61
7
12
my $from     = '';
62
7
101
my $smtp_arg = 'localhost:25';
63
7
55
my $timeout  = 15;
64
7
6
my $verbose  = 0;
65
7
27
my $help     = 0;
66
7
7
my @trusted;
67
68
7
50
31
GetOptions(
69    'dry-run'    => \$dry_run,
70    'interactive|i' => \$interactive,
71    'bcc'        => \$bcc,
72    'bcc-to=s'   => \$bcc_to,
73    'from=s'     => \$from,
74    'smtp=s'     => \$smtp_arg,
75    'trusted=s'  => \@trusted,
76    'timeout=i'  => \$timeout,
77    'verbose'    => \$verbose,
78    'help'       => \$help,
79) or pod2usage(2);
80
81
7
100
3745
pod2usage( -exitval => 0, -verbose => 2 ) if $help;
82
83
5
50
33
11
unless ($dry_run || $from) {
84
0
0
    die basename($0) . ": --from ADDRESS is required unless --dry-run is used.\n"
85      . "Run with --help for usage.\n";
86}
87
88
5
50
67
12
if ($from && $from !~ /\@/) {
89
0
0
    die basename($0) . ": --from value '$from' does not look like an email address.\n";
90}
91
92
5
30
my ($smtp_host, $smtp_port) = split /:/, $smtp_arg, 2;
93
94# Resolve BCC address.
95# --bcc alone copies to --from; --bcc-to ADDRESS uses an explicit address.
96
5
6
my $bcc_addr = undef;
97
5
50
50
10
if ($bcc_to) {
98
0
0
0
    die basename($0) . ": --bcc-to value '$bcc_to' does not look like an email address.\n"
99        unless $bcc_to =~ /\@/;
100
0
0
    $bcc_addr = $bcc_to;
101} elsif ($bcc) {
102
0
0
0
    die basename($0) . ": --bcc requires --from to be set.\n"
103        unless $from;
104
0
0
    $bcc_addr = $from;
105}
106
5
50
10
$smtp_port //= 25;
107
108# -----------------------------------------------------------------------
109# Read the raw email
110# -----------------------------------------------------------------------
111
5
6
my $raw;
112
5
50
8
if (@ARGV) {
113        # Validate path: reject NUL bytes, bare newlines, and directory-traversal
114        # sequences before opening.  This also makes the path taint-safe under -T.
115
5
50
15
        my ($safe_path) = $ARGV[0] =~ /\A([^\x00\r\n]+)\z/
116                or die basename($0) . ": invalid characters in path '$ARGV[0]'\n";
117
5
100
96
        die basename($0) . ": path traversal attempt in '$safe_path'\n"
118                if $safe_path =~ m{(?:^|/)\.\.(?:/|$)};
119
4
50
102
        open my $fh, '<:raw', $safe_path or die basename($0) . ": cannot open '$safe_path': $!";
120
4
8
        local $/;
121
4
64
        $raw = <$fh>;
122
4
23
        close $fh;
123} else {
124
0
0
        binmode STDIN, ':raw';
125
0
0
        local $/;
126
0
0
        $raw = <STDIN>;
127}
128
129
4
50
33
14
die basename($0) . ": no email data supplied.\n"
130    unless defined $raw && length $raw;
131
132# -----------------------------------------------------------------------
133# Analyse
134# -----------------------------------------------------------------------
135
4
50
7
print STDERR "Analysing message...\n" if $verbose;
136
137
4
23
my $inv = Email::Abuse::Investigator->new(
138    timeout        => $timeout,
139    trusted_relays => \@trusted,
140    verbose        => $verbose,
141);
142
4
13
$inv->parse_email(\$raw);
143
144
4
12
my @contacts = $inv->abuse_contacts();
145
146
4
100
7
unless (@contacts) {
147
2
9
    print STDERR "No abuse contacts could be determined.  Nothing to send.\n";
148
149    # List any domains and URL hosts that were found but could not be
150    # resolved to an abuse contact, so the user knows where to look.
151
2
6
    _print_unresolved($inv, \*STDERR);
152
2
46
    exit 0;
153}
154
155# -----------------------------------------------------------------------
156# _print_unresolved( $inv, $fh )
157#
158# Print a list of domains and URL hosts found in the message that could
159# not be resolved to an abuse contact, so the user knows where to look.
160# -----------------------------------------------------------------------
161sub _print_unresolved {
162
4
4
6
    my ($inv, $fh) = @_;
163
164    # Delegate to the module's unresolved_contacts() method which handles
165    # all the filtering logic (spoofable headers, already-covered domains).
166
4
27
    my @unresolved = $inv->unresolved_contacts();
167
4
50
8
    return unless @unresolved;
168
169
4
7
    print $fh "\nDomains found in this message with no abuse contact determined\n";
170
4
6
    print $fh "(consider investigating or reporting manually):\n\n";
171
4
10
    for my $u (@unresolved) {
172
4
100
7
        if ($u->{type} eq 'url_host') {
173
3
6
            print $fh "  URL host : $u->{domain}\n";
174        } else {
175
1
3
            print $fh "  Domain   : $u->{domain}\n";
176        }
177    }
178
4
9
    print $fh "\n";
179}
180
181
2
6
my $report_text = $inv->abuse_report_text();
182
183# Append a note to the human-readable part so recipients know the
184# original message is attached and why.
185
2
4
$report_text .= join("\n",
186    "",
187    "-" x 72,
188    "The original spam/phishing message is attached below as a",
189    "message/rfc822 MIME part.  Please use the full Received: headers",
190    "to locate the relevant SMTP session in your mail logs.",
191    "-" x 72,
192    "");
193
194
2
2
my $orig        = $inv->originating_ip();
195
2
4
my $risk        = $inv->risk_assessment();
196
197# Build a consistent subject line for all outgoing reports
198
2
5
my $subject = _build_subject($orig, $risk);
199
200# -----------------------------------------------------------------------
201# Dry run: describe what would be sent
202# -----------------------------------------------------------------------
203
2
50
4
if ($dry_run) {
204
2
5
    _dry_run_report(\@contacts, $subject, $report_text, \$raw, $inv, $bcc_addr);
205
2
22
    exit 0;
206}
207
208# -----------------------------------------------------------------------
209# Live run: send one email per unique abuse contact
210# -----------------------------------------------------------------------
211
0
0
my $sent  = 0;
212
0
0
my $failed = 0;
213
214
0
0
for my $contact (@contacts) {
215
0
0
    my $to   = $contact->{address};
216
0
0
    my $role = $contact->{role};
217
218
0
0
0
    if ($interactive) {
219
0
0
        printf "\nSend abuse report to: %s\n", $to;
220
0
0
        printf "Reason             : %s\n", $role;
221
0
0
        print  "Send? [y/N] ";
222
0
0
        my $ans = _read_tty();
223
0
0
0
0
        unless (defined $ans && lc($ans) eq 'y') {
224
0
0
            printf "Skipped: %-45s  %s\n", $to, $role;
225
0
0
            next;
226        }
227    }
228
229
0
0
0
    print STDERR "Sending to $to ($role)...\n" if $verbose;
230
231
0
0
    my $ok = _send_report(
232        smtp_host   => $smtp_host,
233        smtp_port   => $smtp_port,
234        from        => $from,
235        to          => $to,
236        bcc         => $bcc_addr,
237        subject     => $subject,
238        body        => $report_text,
239        original    => \$raw,
240        inv         => $inv,
241        timeout     => $timeout,
242    );
243
244
0
0
0
    if ($ok) {
245
0
0
        printf "Sent   : %-45s  %s\n", $to, $role;
246
0
0
        $sent++;
247    } else {
248
0
0
        printf "FAILED : %-45s  %s\n", $to, $role;
249
0
0
        $failed++;
250    }
251}
252
253
0
0
printf "\nDone: %d sent, %d failed.\n", $sent, $failed;
254
0
0
_print_unresolved($inv, \*STDOUT);
255
0
0
0
exit( $failed ? 1 : 0 );
256
257# -----------------------------------------------------------------------
258# _dry_run_report( \@contacts, $subject, $report_text, \$raw, $inv )
259#
260# Print a full description of what would be sent without sending anything.
261# -----------------------------------------------------------------------
262sub _dry_run_report {
263
2
2
4
    my ($contacts, $subject, $body, $raw_ref, $inv, $bcc) = @_;
264
265
2
2
    my $bar = '=' x 72;
266
2
7
    print "$bar\n";
267
2
2
    print "  DRY RUN -- no email will be sent\n";
268
2
4
    print "$bar\n\n";
269
270
2
5
    printf "Subject  : %s\n\n", $subject;
271
2
2
    print  "Envelope sender: <> (null reverse-path per RFC 6650 s.3)\n";
272
2
50
4
    printf "BCC copy to    : %s\n", $bcc if $bcc;
273
2
2
    print  "\n";
274
275
2
4
    printf "%-3s  %-45s  %s\n", '#', 'Recipient', 'Role';
276
2
3
    printf "%-3s  %-45s  %s\n", '-' x 3, '-' x 45, '-' x 24;
277
278
2
3
    my $n = 1;
279
2
2
0
3
    for my $c (@{$contacts}) {
280
2
5
        printf "%-3d  %-45s  %s\n", $n++, $c->{address}, $c->{role};
281        printf "     via: %-42s  note: %s\n",
282
2
50
6
            $c->{via}, ($c->{note} || '');
283
2
2
        print "\n";
284    }
285
286    # Part 1
287
2
2
    print "$bar\n";
288
2
2
    print "  PART 1: HUMAN-READABLE REPORT (text/plain)\n";
289
2
2
    print "  (identical text sent to every recipient above)\n";
290
2
2
    print "$bar\n\n";
291
2
59
    print $body;
292
293    # Part 2: feedback-report fields
294
2
7
    print "\n$bar\n";
295
2
3
    print "  PART 2: ARF METADATA (message/feedback-report)\n";
296
2
3
    print "  RFC 5965 s.3 -- machine-readable fields for automated processing\n";
297
2
17
    print "$bar\n\n";
298
2
6
    my $fbr = _build_feedback_report($inv);
299
2
16
    print "  $_\n" for split /\r?\n/, $fbr;
300
301    # Part 3: original message preview
302
2
2
    print "\n$bar\n";
303
2
3
    print "  PART 3: ORIGINAL MESSAGE (message/rfc822)\n";
304
2
2
    print "  RFC 5965 s.2 -- verbatim original; MUST be included\n";
305
2
3
    print "$bar\n";
306
2
50
33
8
    if (defined $raw_ref && length $$raw_ref) {
307
2
11
        my @lines = split /\r?\n/, $$raw_ref;
308
2
2
        my $preview = 20;
309
2
2
        my $total   = scalar @lines;
310
2
50
6
        printf "  [Showing first %d of %d lines]\n\n",
311            ($total < $preview ? $total : $preview), $total;
312
2
50
39
        print "  $_\n" for @lines[ 0 .. ($total < $preview ? $total - 1 : $preview - 1) ];
313
2
50
8
        print "  ...\n" if $total > $preview;
314    } else {
315
0
0
        print "  (no original message available)\n";
316    }
317
318
2
5
    print "\n$bar\n";
319
320    # abuse_contacts() now merges duplicate addresses, so @contacts has one
321    # entry per unique address with 'role' already set to the combined string.
322    # Count the total discovery routes (sum of all roles arrays) to show
323    # in the annotation when merging occurred.
324
2
2
3
4
    my $n_contacts = scalar @{$contacts};
325
2
3
    my $n_routes   = 0;
326
2
2
2
50
3
5
5
    $n_routes += scalar @{ $_->{roles} // [$_->{role}] } for @{$contacts};
327
328
2
50
4
    if ($n_routes > $n_contacts) {
329        # Some addresses cover more than one discovery route -- note the merge
330
0
0
0
0
        printf "  Total: %d recipient%s (%d contact route%s merged)\n",
331            $n_contacts, $n_contacts == 1 ? '' : 's',
332            $n_routes,   $n_routes   == 1 ? '' : 's';
333    } else {
334
2
50
28
        printf "  Total: %d recipient%s\n",
335            $n_contacts, $n_contacts == 1 ? '' : 's';
336    }
337
2
4
    print "\n";
338
339    # One line per recipient; 'role' is already the merged string
340
2
2
2
12
    for my $c (@{$contacts}) {
341
2
6
        printf "  %s (%s)\n", $c->{address}, $c->{role};
342    }
343
344    # Web-form contacts -- providers that do not accept email
345
2
5
    my @form_cs = $inv->form_contacts();
346
2
50
3
    if (@form_cs) {
347
0
0
        print "\n$bar\n";
348
0
0
        print "  MANUAL ACTION REQUIRED -- WEB FORM SUBMISSION\n";
349
0
0
        print "  The following parties do not accept email abuse reports.\n";
350
0
0
        print "  Open each URL in a browser and complete the form as instructed.\n";
351
0
0
        print "$bar\n\n";
352
0
0
        for my $c (@form_cs) {
353
0
0
            printf "  Role     : %s\n", $c->{role};
354
0
0
            printf "  Form URL : %s\n", $c->{form};
355
0
0
0
            printf "  Domain   : %s\n", $c->{form_domain} if $c->{form_domain};
356
0
0
0
            if ($c->{form_paste}) {
357
0
0
                printf "  Paste    : %s\n", $c->{form_paste};
358            }
359
0
0
0
            if ($c->{form_upload}) {
360
0
0
                printf "  Upload   : %s\n", $c->{form_upload};
361            }
362
0
0
            print "\n";
363        }
364    }
365
366
2
6
    print "$bar\n";
367
368
2
8
    _print_unresolved($inv, \*STDOUT);
369}
370
371# -----------------------------------------------------------------------
372# _read_tty() -> string | undef
373#
374# Read a single line from the controlling terminal.  Extracted into its
375# own sub so tests can override it without spawning a pseudo-terminal.
376# Returns the chomped input string, or undef if /dev/tty is unavailable.
377# -----------------------------------------------------------------------
378sub _read_tty {
379
0
0
0
    my $tty;
380
0
0
0
    unless (open $tty, '<', '/dev/tty') {
381
0
0
        warn "Cannot open /dev/tty for interactive prompt; skipping\n";
382
0
0
        return undef;
383    }
384
0
0
    my $ans = <$tty>;
385
0
0
    close $tty;
386
0
0
0
    chomp $ans if defined $ans;
387
0
0
    return $ans;
388}
389
390# -----------------------------------------------------------------------
391# _send_report( %args ) -> bool
392#
393# Send a single ARF-compliant abuse report via SMTP.
394# Returns 1 on success, 0 on failure.
395# Errors are printed to STDERR; the caller continues to the next recipient.
396#
397# Envelope sender is the null reverse-path (<>) per RFC 6650 s.3, which
398# requires this to prevent mail loops and DSN storms.  The From: header
399# still carries the reporter's address for human reply purposes.
400# -----------------------------------------------------------------------
401sub _send_report {
402
0
0
0
    my (%a) = @_;
403
404
0
0
    my $date = strftime('%a, %d %b %Y %H:%M:%S +0000', gmtime);
405    my $msg_id = sprintf '<%s.%d@%s>',
406        strftime('%Y%m%d%H%M%S', gmtime),
407        $$,
408
0
0
0
0
0
0
        do { (my $h = $a{from}) =~ s/.*\@//; $h };
409
410    my $mail = _build_mime_message(
411        date     => $date,
412        from     => $a{from},
413        to       => $a{to},
414        bcc      => $a{bcc},
415        subject  => $a{subject},
416        msg_id   => $msg_id,
417        body     => $a{body},
418        original => $a{original},
419        inv      => $a{inv},
420
0
0
    );
421
422    # Developer aid: set SUBMIT_ABUSE_DUMP_MIME=path to write the raw MIME
423    # message to a file for inspection (e.g. SUBMIT_ABUSE_DUMP_MIME=/tmp/out.eml).
424
0
0
0
    if (my $dump = $ENV{SUBMIT_ABUSE_DUMP_MIME}) {
425
0
0
0
        if (open my $fh, '>', $dump) {
426
0
0
            print $fh $mail;
427
0
0
            close $fh;
428
0
0
            warn "MIME message written to $dump\n";
429        }
430    }
431
432
0
0
    my $smtp = eval {
433        Net::SMTP->new(
434            $a{smtp_host},
435            Port    => $a{smtp_port},
436            Timeout => $a{timeout},
437
0
0
        );
438    };
439
440
0
0
0
    unless ($smtp) {
441
0
0
        warn "SMTP connect to $a{smtp_host}:$a{smtp_port} failed: $@\n";
442
0
0
        return 0;
443    }
444
445
0
0
    my $ok = eval {
446        # Null reverse-path per RFC 6650 s.3 -- prevents DSN/mail loops
447
0
0
0
        $smtp->mail( '' )         or die "MAIL FROM failed\n";
448
0
0
0
        $smtp->to(   $a{to} )     or die "RCPT TO failed\n";
449        $smtp->to(   $a{bcc} )    or die "RCPT TO (bcc) failed\n"
450
0
0
0
0
            if $a{bcc};
451
0
0
0
        $smtp->data()             or die "DATA failed\n";
452
0
0
0
        $smtp->datasend($mail)    or die "datasend failed\n";
453
0
0
0
        $smtp->dataend()          or die "dataend failed\n";
454
0
0
        $smtp->quit();
455
0
0
        1;
456    };
457
458
0
0
0
    unless ($ok) {
459
0
0
0
        my $err = $@ || 'unknown SMTP error';
460
0
0
        $err =~ s/\s+$//;
461
0
0
        warn "SMTP error sending to $a{to}: $err\n";
462
0
0
        return 0;
463    }
464
465
0
0
    return 1;
466}
467
468# -----------------------------------------------------------------------
469# _build_feedback_report( $inv ) -> string
470#
471# Constructs the body of the message/feedback-report MIME part (Part 2)
472# as defined in RFC 5965 s.3.  The returned string uses CRLF line endings
473# and contains only 7-bit ASCII, as required by the RFC.
474#
475# Fields included:
476#   Feedback-Type        -- always "abuse"
477#   User-Agent           -- module name and version
478#   Version              -- always "1" (RFC 5965 version)
479#   Source-IP            -- originating IP from Received: chain analysis
480#   Original-Mail-From   -- Return-Path: or From: of the spam
481#   Original-Rcpt-To     -- To: of the spam
482#   Arrival-Date         -- Date: header of the spam (as received)
483#   Reported-Domain      -- primary contact domain (first of all_domains())
484#   Reported-Uri         -- each HTTP/HTTPS URL found in the spam body
485#   Authentication-Results -- forwarded from the spam's own header
486# -----------------------------------------------------------------------
487sub _build_feedback_report {
488
2
2
6
    my ($inv) = @_;
489
490
2
2
    my @fields;
491
492    # Required fields (RFC 5965 s.3.1)
493
2
4
    push @fields, 'Feedback-Type: abuse';
494
2
4
    push @fields, 'User-Agent: Email::Abuse::Investigator/'
495                . $Email::Abuse::Investigator::VERSION;
496
2
2
    push @fields, 'Version: 1';
497
498    # Source-IP -- the identified originating address
499
2
6
    my $orig = $inv->originating_ip();
500
2
0
33
3
    push @fields, "Source-IP: $orig->{ip}" if $orig && $orig->{ip};
501
502    # Original-Mail-From -- envelope sender of the spam
503    # Prefer Return-Path (true envelope sender); fall back to From:
504
2
50
33
6
    my $mail_from = $inv->header_value('return-path')
505                 // $inv->header_value('from')
506                 // '';
507
2
35
    $mail_from =~ s/^\s*<?\s*|\s*>?\s*$//g;   # strip angle brackets and whitespace
508
2
50
4
    push @fields, "Original-Mail-From: <$mail_from>" if $mail_from;
509
510    # Original-Rcpt-To -- envelope recipient(s) of the spam
511    # Use the To: header; for each distinct address found
512
2
50
4
    my $rcpt_to = $inv->header_value('to') // '';
513    # Extract individual addresses (bare addr@domain or <addr@domain>)
514
2
2
    my %rcpt_seen;
515
2
9
    while ($rcpt_to =~ /<?([^\s<>,;]+\@[\w.-]+)>?/g) {
516
2
3
        my $addr = lc $1;
517
2
50
12
        push @fields, "Original-Rcpt-To: <$addr>" unless $rcpt_seen{$addr}++;
518    }
519
520    # Arrival-Date -- when we (the reporter) received the spam
521
2
50
4
    my $arrival = $inv->header_value('date') // '';
522
2
50
5
    push @fields, "Arrival-Date: $arrival" if $arrival;
523
524    # Reported-Domain -- the primary contact domain
525
2
4
    my ($rdomain) = $inv->all_domains();
526
2
50
4
    push @fields, "Reported-Domain: $rdomain" if $rdomain;
527
528    # Reported-Uri -- each distinct URL in the spam body
529
2
2
    my %uri_seen;
530
2
4
    for my $u ($inv->embedded_urls()) {
531        push @fields, "Reported-Uri: $u->{url}"
532
2
50
6
            unless $uri_seen{ $u->{url} }++;
533    }
534
535    # Authentication-Results -- forwarded verbatim from the spam headers
536
2
50
3
    my $auth_res = $inv->header_value('authentication-results') // '';
537
2
50
3
    push @fields, "Authentication-Results: $auth_res" if $auth_res;
538
539
2
7
    return join("\r\n", @fields) . "\r\n";
540}
541
542# -----------------------------------------------------------------------
543# _build_mime_message( %args ) -> string
544#
545# Constructs a fully RFC 5965 compliant multipart/report MIME message
546# suitable for transmission via Net::SMTP->datasend().
547#
548# Three-part structure per RFC 5965 s.2:
549#   Part 1  text/plain; charset=UTF-8  -- human-readable abuse report
550#   Part 2  message/feedback-report    -- ARF machine-readable metadata
551#   Part 3  message/rfc822             -- original spam message verbatim
552#
553# All line endings in the returned string are CRLF (\r\n).
554# Part 2 uses 7bit encoding (required by RFC 5965 s.3).
555# -----------------------------------------------------------------------
556sub _build_mime_message {
557
0
0
0
    my (%a) = @_;
558
559    # Boundary unique per message; must not appear in any part body
560
0
0
    my $boundary = sprintf 'arf_report_%s_%d',
561        strftime('%Y%m%d%H%M%S', gmtime), $$;
562
563    # Normalise line endings to CRLF throughout, then encode to raw UTF-8
564    # bytes.  Net::SMTP->datasend() calls syswrite() on a raw socket and
565    # cannot handle Perl strings with the Unicode flag set (wide characters).
566    # The body may contain non-ASCII characters (e.g. emoji in decoded subject
567    # lines) so we must encode explicitly rather than rely on the socket layer.
568
0
0
    (my $body_crlf     = $a{body}) =~ s/\r?\n/\r\n/g;
569
0
0
    my $original_crlf  = '';
570
0
0
0
0
0
0
    if (defined $a{original} && length ${ $a{original} }) {
571
0
0
0
0
        ($original_crlf = ${ $a{original} }) =~ s/\r?\n/\r\n/g;
572    }
573
0
0
    my $feedback_report = _build_feedback_report($a{inv});
574
575    # ---- Outer envelope headers ----
576
0
0
    my @msg;
577
0
0
    push @msg, "Date: $a{date}";
578
0
0
    push @msg, "From: $a{from}";
579
0
0
    push @msg, "To: $a{to}";
580
0
0
    push @msg, "Subject: $a{subject}";
581
0
0
    push @msg, "Message-ID: $a{msg_id}";
582
0
0
    push @msg, "MIME-Version: 1.0";
583    # multipart/report with report-type=feedback-report per RFC 5965 s.2
584
0
0
    push @msg, "Content-Type: multipart/report;";
585
0
0
    push @msg, "    report-type=feedback-report;";
586
0
0
    push @msg, "    boundary=\"$boundary\"";
587
0
0
    push @msg, "X-Mailer: Email::Abuse::Investigator submit_abuse_report";
588
0
0
0
    push @msg, "X-Report-Monitor: $a{bcc}" if $a{bcc};
589
0
0
    push @msg, "";
590
591    # Preamble for non-MIME clients
592
0
0
    push @msg, "This is an ARF (Abuse Reporting Format) feedback report.";
593
0
0
    push @msg, "See https://datatracker.ietf.org/doc/html/rfc5965";
594
0
0
    push @msg, "";
595
596    # ---- Part 1: human-readable summary (RFC 5965 s.2 "first part") ----
597
0
0
    push @msg, "--$boundary";
598
0
0
    push @msg, "Content-Type: text/plain; charset=UTF-8";
599
0
0
    push @msg, "Content-Transfer-Encoding: 8bit";
600
0
0
    push @msg, "Content-Disposition: inline";
601
0
0
    push @msg, "";
602
0
0
    push @msg, $body_crlf;
603
604    # ---- Part 2: ARF machine-readable metadata (RFC 5965 s.3) ----
605
0
0
    push @msg, "--$boundary";
606
0
0
    push @msg, "Content-Type: message/feedback-report";
607
0
0
    push @msg, "Content-Transfer-Encoding: 7bit";   # required by RFC 5965
608
0
0
    push @msg, "";
609
0
0
    push @msg, $feedback_report;
610
611    # ---- Part 3: original spam message (RFC 5965 s.2 "third part") ----
612    # Use base64 encoding so Outlook and other clients reliably show
613    # it as a downloadable .eml attachment rather than rendering it
614    # inline or discarding it.
615
0
0
    my $original_b64 = MIME::Base64::encode_base64($original_crlf, "\r\n");
616
0
0
    push @msg, "--$boundary";
617
0
0
    push @msg, "Content-Type: application/octet-stream; name=\"original_message.eml.txt\"";
618
0
0
    push @msg, "Content-Transfer-Encoding: base64";
619
0
0
    push @msg, "Content-Disposition: attachment;";
620
0
0
    push @msg, "    filename=\"original_message.eml.txt\"";
621
0
0
    push @msg, "Content-Description: Original spam/phishing message";
622
0
0
    push @msg, "";
623
0
0
    push @msg, $original_b64;
624
625    # Closing boundary
626
0
0
    push @msg, "--${boundary}--";
627
0
0
    push @msg, "";
628
629
0
0
    require Encode;
630
0
0
    my $result = join("\r\n", @msg);
631
0
0
    return Encode::encode('UTF-8', $result);
632}
633
634# -----------------------------------------------------------------------
635# _build_subject( $orig_hashref, $risk_hashref ) -> string
636#
637# Build a concise, informative subject line for the abuse report.
638# -----------------------------------------------------------------------
639sub _build_subject {
640
2
2
2
    my ($orig, $risk) = @_;
641
642
2
50
5
    my $ip_part   = $orig ? $orig->{ip} : 'unknown origin';
643
2
5
    my $level     = $risk->{level};
644
2
62
    my $date_part = strftime('%Y-%m-%d', gmtime);
645
646
2
5
    return "Abuse report [$level]: spam/phishing from $ip_part ($date_part)";
647}
648