374 lines
13 KiB
Perl
Executable File
374 lines
13 KiB
Perl
Executable File
#!/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;
|
|
}
|
|
}
|
|
}
|
|
|