qpsmtpd/log/summarize

#!/usr/bin/perl

use strict;
use warnings;

use Cwd;
use Data::Dumper;
use File::Tail;
use Getopt::Std;

$Data::Dumper::Sortkeys = 1;

our $opt_l = 0;
getopts('l');

my (%plugins, %plugin_aliases, %seen_plugins, %pids);
my %hide_plugins = map { $_ => 1 } qw/ hostname /;

my $qpdir = get_qp_dir();
my $file  = "$qpdir/log/main/current";
populate_plugins_from_registry();
my @sorted_plugins =
  sort { $plugins{$a}{id} <=> $plugins{$b}{id} } keys %plugins;

my $fh = File::Tail->new(
                         name        => $file,
                         interval    => 1,
                         maxinterval => 1,
                         debug       => 1,
                         tail        => 1000
                        );
my $printed = 0;
my $has_cleanup;

my %formats = (
               ip                          => "%-15.15s",
               hostname                    => "%-20.20s",
               distance                    => "%5.5s",
               'ident::geoip'              => $opt_l ? "%-20.20s" : "%-6.6s",
               'ident::p0f'                => "%-10.10s",
               count_unrecognized_commands => "%-5.5s",
               unrecognized_commands       => "%-5.5s",
               dnsbl                       => "%-3.3s",
               rhsbl                       => "%-3.3s",
               relay                       => "%-3.3s",
               karma                       => "%-3.3s",
               fcrdns                      => "%-3.3s",
               earlytalker                 => "%-3.3s",
               check_earlytalker           => "%-3.3s",
               helo                        => "%-3.3s",
               tls                         => "%-3.3s",
               'auth::auth_vpopmail'       => "%-3.3s",
               'auth::auth_vpopmaild'      => "%-3.3s",
               'auth::auth_vpopmail_sql'   => "%-3.3s",
               'auth::auth_checkpassword'  => "%-3.3s",
               badmailfrom                 => "%-3.3s",
               check_badmailfrom           => "%-3.3s",
               sender_permitted_from       => "%-3.3s",
               resolvable_fromhost         => "%-3.3s",
               dont_require_anglebrackets  => "%-3.3s",
               'queue::qmail-queue'        => "%-3.3s",
               connection_time             => "%-4.4s",
              );

my %formats3 = (
                %formats,
                badrcptto          => "%-3.3s",
                check_badrcptto    => "%-3.3s",
                qmail_deliverable  => "%-3.3s",
                rcpt_ok            => "%-3.3s",
                check_basicheaders => "%-3.3s",
                headers            => "%-3.3s",
                uribl              => "%-3.3s",
                bogus_bounce       => "%-3.3s",
                check_bogus_bounce => "%-3.3s",
                domainkeys         => "%-3.3s",
                dkim               => "%-3.3s",
                dmarc              => "%-3.3s",
                spamassassin       => "%-3.3s",
                dspam              => "%-3.3s",
                'virus::clamdscan' => "%-3.3s",
               );

while (defined(my $line = $fh->read)) {
    chomp $line;
    $line =~ s/[^[ -~]]//g;   # strip out binary/unprintable
    next if !$line;
    my ($type, $pid, $hook, $plugin, $message) = parse_line($line);
    next if !$type;
    next if $type =~ /^(info|unknown|response|tcpserver)$/;
    next if $type eq 'init';    # doesn't occur in all deployment models

    if (!$pids{$pid}) {         # haven't seen this pid
        next if $type ne 'connect';    # ignore unless connect
        my ($host, $ip) = split /\s/, $message;
        $ip = substr $ip, 1, -1;
        foreach (keys %seen_plugins, qw/ helo_host from to /) {
            $pids{$pid}{$_} = '';
        }
        $pids{$pid}{ip} = $ip;
        $pids{$pid}{hostname} = $host if $host ne 'Unknown';
    }

    if ($type eq 'close') {
        next if $has_cleanup;          # it'll get handled later
        print_auto_format($pid, $line);
        delete $pids{$pid};
    }
    elsif ($type eq 'cleanup') {
        print_auto_format($pid, $line);
        delete $pids{$pid};
    }
    elsif ($type eq 'plugin') {
        next if $plugin eq 'naughty';    # housekeeping only
        if (!$pids{$pid}{$plugin}) {     # first entry for this plugin
            $pids{$pid}{$plugin} = $message;
        }
        else {                           # subsequent log entry for this plugin
            if ($pids{$pid}{$plugin} !~ /^(?:pass|fail|skip)/i) {
                $pids{$pid}{$plugin} = $message;    # overwrite 1st
            }
            else {
                #print "ignoring subsequent hit on $plugin: $message\n";
            }
        }

        if ($plugin eq 'ident::geoip') {
            if (length $message < 3) {
                $formats{'ident::geoip'}  = "%-3.3s";
                $formats3{'ident::geoip'} = "%-3.3s";
            }
            else {
                my ($gip, $distance) = $message =~ /(.*?),\s+([\d]+)\skm/;
                if ($distance) {
                    $pids{$pid}{$plugin} = $gip;
                    $pids{$pid}{distance} = $distance;
                }
            }
        }
    }
    elsif ($type eq 'reject')  { }
    elsif ($type eq 'connect') { }
    elsif ($type eq 'dispatch') {
        if ($message =~ /^dispatching MAIL FROM/i) {
            my ($from) = $message =~ /<(.*?)>/;
            $pids{$pid}{from} = $from;
        }
        elsif ($message =~ /^dispatching RCPT TO/i) {
            my ($to) = $message =~ /<(.*?)>/;
            $pids{$pid}{to} = $to;
        }
        elsif ($message =~ m/dispatching (EHLO|HELO) (.*)/) {
            $pids{$pid}{helo_host} = $2;
        }
        elsif ($message eq 'dispatching DATA')     { }
        elsif ($message eq 'dispatching QUIT')     { }
        elsif ($message eq 'dispatching STARTTLS') { }
        elsif ($message eq 'dispatching RSET') {
            print_auto_format($pid, $line);
        }
        else {
            # anything here is likely an unrecognized command
            #print "$message\n";
        }
    }
    else {
        print "$type $pid $hook $plugin $message\n";
    }
}

sub parse_line {
    my $line = shift;
    my ($tai, $pid, $message) = split /\s+/, $line, 3;
    return if !$message;    # garbage in the log file

    # lines seen many times per connection
    return parse_line_plugin($line) if substr($message, 0, 1) eq '(';
    return ('dispatch', $pid, undef, undef, $message)
      if substr($message, 0, 12) eq 'dispatching ';
    return ('response', $pid, undef, undef, $message)
      if $message =~ /^[2|3]\d\d/;
    return ('tcpserver', $pid, undef, undef, undef)
      if substr($pid, 0, 10) eq 'tcpserver:';

    # lines seen about once per connection
    return ('init', $pid, undef, undef, $message)
      if substr($message, 0, 19) eq 'Accepted connection';
    return ('connect', $pid, undef, undef, substr($message, 16))
      if substr($message, 0, 15) eq 'Connection from';
    return ('close', $pid, undef, undef, $message)
      if substr($message, 0, 6) eq 'close ';
    return ('close', $pid, undef, undef, $message)
      if substr($message, 0, 20) eq 'click, disconnecting';
    return parse_line_cleanup($line)
      if substr($message, 0, 11) eq 'cleaning up';

    # lines seen less than once per connection
    return ('info', $pid, undef, undef, $message)
      if $message eq 'spooling message to disk';
    return ('reject', $pid, undef, undef, $message) if $message =~ /^[4|5]\d\d/;
    return ('reject', $pid, undef, undef, $message)
      if substr($message, 0, 14) eq 'deny mail from';
    return ('reject', $pid, undef, undef, $message)
      if substr($message, 0, 18) eq 'denysoft mail from';
    return ('info', $pid, undef, undef, $message)
      if substr($message, 0, 15) eq 'Lost connection';
    return ('info', $pid, undef, undef, $message)
      if $message eq 'auth success cleared naughty';
    return ('info', $pid, undef, undef, $message)
      if substr($message, 0, 15) eq 'Running as user';
    return ('info', $pid, undef, undef, $message)
      if substr($message, 0, 16) eq 'Loaded Qpsmtpd::';
    return ('info', $pid, undef, undef, $message)
      if substr($message, 0, 24) eq 'Permissions on spool_dir';
    return ('info', $pid, undef, undef, $message)
      if substr($message, 0, 13) eq 'Listening on ';

    return ('err', $pid, undef, undef, $message)
      if $line =~ /at [\S]+ line \d/;    # generic perl error
    print "UNKNOWN LINE: $line\n";
    return ('unknown', $pid, undef, undef, $message);
}

sub parse_line_plugin {
    my ($line) = @_;

# @tai 13486 (connect) ident::p0f: Windows (XP/2000 (RFC1323+, w, tstamp-))
# @tai 13681 (connect) dnsbl: fail, NAUGHTY
# @tai 15787 (connect) karma: pass, no penalty (0 naughty, 3 nice, 3 connects)
# @tai 77603 (queue) queue::qmail_2dqueue: (for 77590) Queuing to /var/qmail/bin/qmail-queue
    my ($tai, $pid, $hook, $plugin, $message) = split /\s/, $line, 5;
    $plugin =~ s/:$//;
    if ($plugin =~ /_3a/) {
        ($plugin) = split /_3a/, $plugin;    # trim :N off the plugin log entry
    }
    $plugin =~ s/_2d/-/g;

    $plugin = $plugin_aliases{$plugin}
      if $plugin_aliases{$plugin};           # map alias to master
    if ($hook eq '(queue)') {
        ($pid) = $message =~ /\(for ([\d]+)\)\s/;
        $message = 'pass';
    }

    return ('plugin', $pid, $hook, $plugin, $message);
}

sub parse_line_cleanup {
    my ($line) = @_;

    # @tai 85931 cleaning up after 3210
    my $pid = (split /\s+/, $line)[-1];
    $has_cleanup++;
    return ('cleanup', $pid, undef, undef, $line);
}

sub print_auto_format {
    my ($pid, $line) = @_;

    my $format;
    my @headers;
    my @values;

    foreach my $plugin (qw/ ip hostname distance /, @sorted_plugins) {
        if (defined $pids{$pid}{$plugin}) {
            if (!$seen_plugins{$plugin}) {    # first time seeing this plugin
                $printed = 0;                 # force header print
            }
            $seen_plugins{$plugin}++;
        }

        next if !$seen_plugins{$plugin};      # hide unused plugins
        if ($hide_plugins{$plugin}) {         # user doesn't want to see
            delete $pids{$pid}{$plugin};
            next;
        }

        my $wide = $opt_l ? 20 : 8;

        if (defined $pids{$pid}{helo_host} && $plugin =~ /helo/) {
            $format .= " %-$wide.${wide}s";
            push @values, substr(delete $pids{$pid}{helo_host}, -$wide, $wide);
            push @headers, 'HELO';
        }
        elsif (defined $pids{$pid}{from} && $plugin =~ /from/) {
            $format .= " %-$wide.${wide}s";
            push @values, substr(delete $pids{$pid}{from}, -$wide, $wide);
            push @headers, 'MAIL FROM';
        }
        elsif (defined $pids{$pid}{to} && $plugin =~ /to|rcpt|recipient/) {
            $format .= " %-$wide.${wide}s";
            push @values,  delete $pids{$pid}{to};
            push @headers, 'RCPT TO';
        }

        $format .= $formats3{$plugin} ? " $formats3{$plugin}" : " %-10.10s";

        if (defined $pids{$pid}{$plugin}) {
            push @values, show_symbol(delete $pids{$pid}{$plugin});
        }
        else {
            push @values, '';
        }
        push @headers,
          ($plugins{$plugin}{abb3} ? $plugins{$plugin}{abb3} : $plugin);
    }
    $format .= "\n";
    printf("\n$format", @headers) if (!$printed || $printed % 20 == 0);
    printf($format, @values);
    #print Data::Dumper::Dumper($pids{$pid}) if keys %{$pids{$pid}};
    $printed++;
}

sub show_symbol {
    my $mess = shift;
    return ' o' if $mess eq 'TLS setup returning';
    return ' o' if $mess eq 'pass';
    return ' -' if $mess eq 'skip';
    return ' x' if 'fail, tolerated' eq substr($mess, 0, 15);
    return ' X' if $mess eq 'fail';
    return ' -' if $mess =~ /^skip[,:\s]/i;
    return ' o' if $mess =~ /^pass[,:\s]/i;
    return ' X' if $mess =~ /^fail[,:\s]/i;
    return ' x' if $mess =~ /^negative[,:\s]/i;
    return ' o' if $mess =~ /^positive[,:\s]/i;
    return ' !' if $mess =~ /^error[,:\s]/i;
    $mess =~ s/\s\s/ /g;
    return $mess;
}

sub get_qp_dir {
    foreach my $user (qw/ qpsmtpd smtpd /) {
        my ($homedir) = (getpwnam($user))[7] or next;

        if (-d "$homedir/plugins") {
            return "$homedir";
        }
        foreach my $s (qw/ smtpd qpsmtpd qpsmtpd-dev /) {
            if (-d "$homedir/$s/plugins") {
                return "$homedir/$s";
            }
        }
    }
    if (-d "./plugins") {
        return Cwd::getcwd();
    }
}

sub populate_plugins_from_registry {

    my $file = "$qpdir/plugins/registry.txt";
    if (!-f $file) {
        die "unable to find plugin registry\n";
    }

    open my $F, '<', $file;
    while (defined(my $line = <$F>)) {
        next if $line =~ /^#/;    # discard comments
        chomp $line;
        next if ! $line;
        my ($id, $name, $abb3, $abb5, $aliases) = split /\s+/, $line;
        next if !defined $name;
        $plugins{$name} = {id => $id, abb3 => $abb3, abb5 => $abb5};

        next if !$aliases;
        $aliases =~ s/\s+//g;
        $plugins{$name}{aliases} = $aliases;
        foreach my $a (split /,/, $aliases) {
            $plugin_aliases{$a} = $name;
        }
    }
}