Parse and display a RFC 8460 (SMTP-TLS) report

tlsrpt-report-display.pl

#!/usr/bin/env perl
#=============================================================================
#
#         FILE: tlsrpt-report-display.pl
#
#        USAGE: ./tlsrpt-report-display.pl REPORT
#
#  DESCRIPTION: Parse and display a TLS-RPT report
#
# REQUIREMENTS: Perl 5.10; Term::ANSIColor; JSON
#         BUGS: none known
#       AUTHOR: Pierre-Olivier Mercier <[email protected]>
#      CREATED: 04/15/2019 15:09:00 PM
#=============================================================================

use v5.10;
use strict;
use warnings;

use Getopt::Long;
use Pod::Usage;
use Term::ANSIColor;
use Socket;
use JSON;
use File::LibMagic;
use Time::Piece;

use Data::Dumper;

### GLOBALS #############################################################

our $VERSION = 1.0;

### COMMAND-LINE #############################################################

my $HELP        = 0;
my $NUMERIC     = 0;
my @REPORTS;
my $LIBMAGIC = File::LibMagic->new;

GetOptions(
    'help|?'            => \$HELP,
    'numeric'           => \$NUMERIC,
    ) or pod2usage(2);

pod2usage( -exitval => 0, -verbose => 2 ) if $HELP;


### FUNCTIONS ################################################################

sub format_daterange($) {
    my $dr = shift;

    my $begin = localtime(Time::Piece->strptime($dr->{"start-datetime"}, "%Y-%m-%dT%TZ"));
    my $end = localtime(Time::Piece->strptime($dr->{"end-datetime"}, "%Y-%m-%dT%TZ"));

    "from $begin to $end"
}

sub format_ipaddress($) {
    my $ip = shift;

    return $ip if $NUMERIC;

    my $pip = inet_aton($ip);

    # IPv6
    return gethostbyaddr(Socket::inet_pton(AF_INET6, $ip), AF_INET6) // $ip if not $pip;

    # IPv4
    gethostbyaddr($pip, AF_INET) // $ip;
}

sub format_metadata($) {
    my $rp = shift;

    colored("Report ID: ", "yellow") . $rp->{"report-id"} . "\n" .
    colored("Organization: ", "yellow") .
        colored($rp->{"organization-name"}, "bold") .
        " (" . $rp->{"contact-info"} . ")\n" .
    colored("Period: ", "yellow") .
        format_daterange( $rp->{"date-range"} ) . "\n";
}

sub format_policy($) {
    my $pp = shift;

    my $ret = "";

    $ret .= colored("Policy domain: ", "yellow") .
	$pp->{"policy-domain"} . "\n" if $pp->{"policy-domain"};
    $ret .= colored("Policy type: ", "yellow") .
	$pp->{"policy-type"} . "\n" if $pp->{"policy-type"};
    $ret .= colored("Policy string: ", "yellow") .
        Dumper($pp->{"policy-string"}) if $pp->{"policy-string"};

    $ret;
}

sub format_summary($) {
    my $ps = shift;

    my $ret = "";
    $ret .= colored("Total successful session count:", "yellow") . "\t" .
        colored($ps->{"total-successful-session-count"}, "green") . "\n" if $ps->{"total-successful-session-count"};
    $ret .= colored("Total failure session count:", "yellow") . "\t" .
        colored($ps->{"total-failure-session-count"}, "red") . "\n" if $ps->{"total-failure-session-count"};

    $ret;
}

sub format_failure_details($) {
    my $pf = shift;

    my $ret = "";
    if ($pf) {
	for my $fd (@{ $pf }) {
	    $ret .= colored("Result type: ", "yellow") . colored($fd->{"result-type"}, "red") if $fd->{"result-type"} ;
	    $ret .= " ×" . $fd->{"failed-session-count"} if $fd->{"result-type"} && $fd->{"failed-session-count"} ;
	    $ret .= "\n" if $fd->{"result-type"} ;
	    $ret .= "    " . colored("Sending MTA: ", "yellow") . format_ipaddress( $fd->{"sending-mta-ip"} ) . "\n" if $fd->{"sending-mta-ip"} ;

	    my $recv = "";
	    $recv .= $fd->{"receiving-mx-hostname"} if $fd->{"receiving-mx-hostname"};
	    $recv .= " (" . $fd->{"receiving-ip"} if $fd->{"receiving-ip"};
	    $recv .= " - HELO: " . $fd->{"receiving-mx-helo"} if $fd->{"receiving-mx-helo"};
	    $recv .= ")" if $fd->{"receiving-ip"};

	    $ret .= "    " . colored("Receiving MX: ", "yellow") . $recv . "\n" if $recv ;

	    $ret .= "    " . colored("Failed session count: ", "yellow") . $fd->{"failed-session-count"} . "\n" if $fd->{"failed-session-count"} && !$fd->{"result-type"} ;
	    $ret .= "    " . colored("Additional information: ", "yellow") . $fd->{"additional-information"} . "\n" if $fd->{"additional-information"} ;
	    $ret .= "    " . colored("Failure reason code: ", "yellow") . $fd->{"failure-reason-code"} . "\n" if $fd->{"failure-reason-code"} ;
	    $ret .= "\n" ;
	}
    }

    $ret;
}

sub format_policy_item($) {
    my $p = shift;

    format_policy( $p->{"policy"} ) . "\n" .
    format_failure_details( $p->{"failure-details"} ) .
    format_summary( $p->{"summary"} ) . "\n";
}

sub treat_report($) {
    my $report = shift;

    say format_metadata $report;

    if ($report->{"policies"}) {
	my $idx = 0;
	for my $policy (@{ $report->{"policies"} }) {
	    $idx += 1;
	    print "-" x 34 . " Policy #" . $idx . " " . "-" x 34 . "\n";
	    $_ = format_policy_item $policy;
	    chomp;
	    print;
	}
    }
}

sub treat_data($);
sub treat_data($) {
    my $data     = shift;
    my $mimetype = $LIBMAGIC->checktype_contents($data);
    for ($mimetype) {
        if (/gzip/) {
	    use IO::Uncompress::Gunzip qw(gunzip $GunzipError);
            open my $dh, '<', \$data;
	    my $buffer;
	    gunzip $dh => \$buffer or die "gunzip failed: $GunzipError\n";
	    treat_data( $buffer );
        } elsif (/zip/) {
            require Archive::Zip;
            open my $dh, '<', \$data;
            my $zip   = Archive::Zip->new();
            my $errno = $zip->readFromFileHandle($dh);
            die "Can't open zip archive (error code $errno)\n" if $errno != 0;
            for my $zipped ( $zip->memberNames ) {
                treat_data( $zip->contents($zipped) );
            }
        } elsif (/rfc822/) {
            require Email::MIME;
            my $email = Email::MIME->new($data);
            for my $part ( $email->parts ) {
                my $ct = $part->header('Content-Type');
                next if $ct =~ m{^text/plain};
                treat_data( $part->body );
            }
        } elsif (/\b json \b/x) {
            treat_report( decode_json(  $data ) );
        } else {
            warn "Sorry! $mimetype not yet supported!\n";
            return;
        }
    }
}

### MAIN ################################################################

my @reports = map { open my $fh, '<', $_; local $/; <$fh> } @ARGV;
push @reports, do { local $/; <STDIN> } if !@reports;
for my $report (@reports) {
    treat_data($report);
} continue { print "#" x 79 . "\n" }

__END__

=head1 NAME

SMTP-TLS report display - Parse and display a RFC 8460 report

=head1 SYNOPSIS

    ./tlsrpt-report-display.pl [OPTIONS] [REPORT [REPORT ...]]

=head1 OPTIONS

=over

=item B<-help>

Displays the help.

=item B<-numeric>

IP addresses will be printed in numeric format. By default, the program will try
to display them as host names, network names, or services (whenever applicable).

=back

=head1 EXIT STATUS

This script should always return 0.

=head1 DEPENDENCIES

=over

=item

perl >= 5.10

=item

File::LibMagic

=item

Email::MIME v1.910+ (only required for opening mailed reports)

=item

Archive::Zip (only required for opening zipped reports)

=item

Term::ANSIColor v5.001+

=item

JSON

=back

=head1 AUTHOR

Pierre-Olivier Mercier <[email protected]>

=head1 CHANGELOG

=over

=item v1.0

=over

=item

Initial release.

=back

=back

=head1 VERSION

This is B<tlsrpt-report-display.pl> version 1.0.

=head1 LICENSE AND COPYRIGHT

B<The GNU GPLv3 License>

Copyright (C) 2019  Pierre-Olivier Mercier <[email protected]>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.