[FWP] CPAN _Rules_!

[Bennett Todd <bet@rahul.net>]

I really love it when I can build on the work of others, and accomplish
something hairy and complex with negligible effort. I attach one that
is about the most fun with perl I've had in a long, long time. It does
pop-before-smtp auth for UW popd/imapd -> Postfix, with no mods required to
either, efficiently.

It uses File::Tail, Net::Netmask, and Date::Parse from CPAN, as well as
DB_File and Getopt::Long as shipped with perl. After a little nice simple
setup, it does the job with a loop that comes down to:

    while (1) {
        $_ = $fi->read;
        my ($timestamp, $ipaddr) = m/$pat/o or next;
        my $ts = str2time($timestamp) or next;
        $ts += $grace;
        next if $ts < time;
        next if findNetblock($ipaddr);
        push @q, [$ipaddr, $ts];
        $t{$ipaddr} = $ts;
        $db{$ipaddr} = "ok";
        $dbh->sync and die "$0: sync $dbfile: $!\n";
        while ($q[0][1] < time) {
            if ($q[0][1] == $t{$q[0][0]}) {
                delete $t{$q[0][0]};
                delete $db{$q[0][0]};
                $dbh->sync and die "$0: sync $dbfile: $!\n";
            }
            shift @q;
        }
    }

(debugging print statements and options for not writing omitted).

So where's the fun? Well, it took me nearly the entire time to design it;
coding it took almost no time, and (wait for it) debugging took essentially
none at all --- there were compilation errors for typos, and I initially
reversed the sense of the test for the return value of dbh->sync, but those
documented themselves instantly; the thing remained simple enough that the
logic was correct by inspection[*], and the CPAN modules successfully handled
the real hair --- efficiently tailing a logfile and following across logfile
rotation, parsing timestamps, and doing IPV4 router logic (building a table of
CIDR netblocks, and looking up IP addresses in it).

On our mail server, a PC running Linux, it waltzes through 20MB of backlogged
maillog --- a couple days worth --- in well under a minute, then stays
caught up without ever eating enough CPU to show up on top(1). It tracks in
effectively realtime, and since it's doing the netblock optimization, the db
hash doesn't grow large.

-Bennett

[*] If I'm wrong, I'm sure I'll be hearing about it for some time:-).
#!/usr/bin/perl -w
use strict;

# pop-before-smtp 1.0 Bennett Todd <bet@rahul.net> Freely Redistributable
# 1.0 2000-01-04 first public release

=head1 NAME

  pop-before-smtp --- watch log for POP/IMAP auth, update map allowing SMTP

=head1 SYNOPSIS

  nohup pop-before-smtp [--[no]write] [--[no]debug] \
	[--logfile=filename] \
	[--dbfile=filename] \
	[--grace=seconds] &

=head1 DESCRIPTION

pop-before-smtp watches /var/log/maillog for lines written by UW popd/imapd
describing successful login attempts, and installs entries for them in an
on-disk hash (DB) that is watched by postfix. It expires the entries after a
half-hour. The hash is named /etc/postfix/pop-before-smtp.db. The name, as
specified in the dbfile option, does not include the .db on the end, that's
tacked on to satisfy a wired-in assumption in postfix.

Internally, it keeps two data structures for all currently-allowed hosts; a
queue, and a hash. The queue contains [ipaddr, time] records, while the hash
contains ipaddr => time. Every time the daemon wakes up to deal with something
else from the File::Tail handle, it peeks a the front of the queue, and while
the timestamp of the record there has expired (is > 1800 seconds old) it
tosses it, and if the timestamp in the hash is also expired and equals the
timestamp in the queue it deletes the hash entry and the on-disk db file
entry.

Edit the source to change the wired-in filenames, grace period, logfile
format, etc.

When starting up, it builds an internal table of all netblocks natively
permitted by Postfix (it looks at the output of "postconf mynetworks"); before
adding each entry it checks to see if it would be permitted by that rule.

=cut

use File::Tail;
use DB_File;
use Net::Netmask;
use Date::Parse;
use Getopt::Long;

##################################
#                                #
# Tuneable parameters start here #
#                                #
##################################

# Flags
my $write = 1;
my $debug = 0;

# File to watch for pop3d/imapd records
my $logfile = '/var/log/maillog';

# This regex pull the lines I'm interested in out of $logfile, and yanks out
# the timestamp and IP address
my $pat = '^(... .. ..:..:..) \S+ (?:ipop3d|imapd)\[\d+\]: ' .
          'Login user=\S+ host=\S+ \[(\d+\.\d+\.\d+\.\d+)\]';

my $dbfile = '/etc/postfix/pop-before-smtp'; # DB hash to write
my $grace = 1800; # 30 minutes --- grace period

GetOptions(
	"write!" => \$write,
	"debug!" => \$debug,
	"dbfile=s" => \$dbfile,
	"grace=i" => \$grace,
) or die "syntax: $0 [--[no]write] [--[no]debug] [--logfile=filename] " .
	"[--dbfile=filename] [--grace=seconds]\n";

# These parameters control how closely the watcher tries to follow the
# logfile, which affects how much resources it consumes, and how quickly
# people can smtp after they have popped.
my $fi = File::Tail->new(
	name => $logfile,
	maxinterval => 10,
	interval => 5,
	adjustafter => 3,
	tail => -1,
);

################################
#                              #
# Tuneable parameters end here #
#                              #
################################

my $mynets = `postconf mynetworks`;
for ($mynets) {
	s/^\s+//; s/\s+$//; s/\s+/ /g;
	s/^mynetworks\s*=\s*//;
}
Net::Netmask->new($_)->storeNetblock() for split /[,\s]+/, $mynets;

my (%t, @q);

use vars qw(%db);
my $dbh = tie %db, 'DB_File', "$dbfile.db", O_CREAT|O_RDWR, 0666, $DB_HASH or
	die "$0: cannot dbopen $dbfile: $!\n" if $write;
delete $db{$_} for keys %db;

$| = 1 if $debug;

while (1) {
	$_ = $fi->read;
	my ($timestamp, $ipaddr) = m/$pat/o or next;
	my $ts = str2time($timestamp) or next;
	$ts += $grace;
	next if $ts < time;
	print "read ts=$timestamp ip=$ipaddr\n" if $debug;
	next if findNetblock($ipaddr);
	print "\taccepted --- not in mynetworks\n" if $debug;
	push @q, [$ipaddr, $ts];
	$t{$ipaddr} = $ts;
	$db{$ipaddr} = "ok" if $write;
	$dbh->sync and die "$0: sync $dbfile: $!\n" if $write;
	print "\twritten ok\n" if $write and $debug;
	while ($q[0][1] < time) {
		print "purging ts=".localtime($q[0][1])." ip=$q[0][0]\n" if $debug;
		if ($q[0][1] == $t{$q[0][0]}) {
			delete $t{$q[0][0]};
			delete $db{$q[0][0]} if $write;
			$dbh->sync and die "$0: sync $dbfile: $!\n" if $write;
		}
		shift @q;
	}
}

PGP signature