#!/usr/bin/perl -wT
use strict;

# Check the website <URL:http://people.oven.com/bet/pop-before-smtp/> for
# the latest version, and the mailing list for discussing this program
# and asking for help.

# pop-before-smtp 1.25 Bennett Todd <bet@rahul.net> Freely Redistributable

#
# Stig Hackvan <stig@hackvan.com> added support for syslog, set to not 
# read entire logfile upon startup...just wipe the relay database and 
# look for pop connections.
#

# 1.25 2000-11-15 Added commentary about DB_File prereq, from
#                 Mike Saunders <method@method.cx>, as well as the
#                 Solaris init script he fixed and tested.
#                 Justin <justin@inwa.com.au> contributed Courier
#                 support.
#                 Added PLATFORM-SPECIFIC NOTES to the top of README
#                 as a quick guide to help point people at bits they
#                 might find interesting, as the number of platform-
#                 and application-specific bits is climbing quick.
#                 Alexander Burke <alex@pdqsolutions.com> contributed the
#                 getfromcpan script, to pkg and install all the needed
#                 prerequisite perl modules in one go.
#                 Added references to the website in the above comment
#                 and DOWNLOAD and AUTHOR sections to the pod.
#                 Added popa3d support contributed by bartek
#		  marcinkiewicz <jr@rzeznia.eu.org>
#                 Separated out the contrib stuff into a contrib/
#                 directory, as the single flat directory was
#                 getting crowded
# 1.24 2000-11-01 Sanitize the environment a little harder
# 1.23 2000-10-30 Fixed GetOptions to match docs and handle --logfile
# 1.22 2000-10-11 Jeremy Shaffner <jer@jorsm.com> pointed out that
#                 several of the example $pats didn't have the needed
#                 terminal semicolons; fixed that.
# 1.21 2000-09-20 Olivier Castan <ocastan@cybercable.fr> reported a bug
#                 in the debugging code, it reported purges it wasn't
#                 acting on because the grace period hadn't expired
# 1.20 2000-09-18 Robert L Mathews pointed out that I'd neglected to
#                 skip the update of the db file if the client was already
#                 authorized; this update adds that optimization.
#                 And Robert L Mathews also gave another optimization,
#                 hoisting the syncs out of the purge loop and ensuring
#                 that all updates are covered by a single sync.
# 1.19 2000-09-18 Robert L Mathews performed benchmarks demonstrating that
#                 the performance cost of the flocks is negligible, so
#                 I switched them to default to on.
# 1.18 2000-09-17 added flocks from Robert L Mathews <rob@tigertech.com>
# 1.17 2000-09-17 Brian Duggan <bduggan@oven.com> and Jeff Moore <jbm@oven.com>
#                 worked out a fix for the sometimes-present nmsgs= at the end
#                 of the UW daemons' log entries.
#                 Kevin Lynn <klynn@santacruz.org> suggested I include
#                 instructions for running as a non-root user.
# 1.16 2000-08-10 William Yodlowsky <wyodlows@nj.devry.edu> provided the
#                 beautifully trivial patch for Taint support
#                 Darron Froese provided README.QUICKSTART.
#                 Added pattern for gnu-pop3d, as $pat2, for
#                 coexisting with UW (or some other) imapd;
#                 made $debug default in init script
# 1.15 2000-07-31 Changes requested by Daniel Roesen
#                 <dr@bofh.de>: renamed init script
#                 to a nice lengthy pop-before-smtp; yanked daemon
#                 start/stop on rpm -i/rpm -e; added a
#                 commented-out pattern for cucipop; added documentation
#                 for --nowrite and --debug; fixed init script to clean
#                 up msgs for restart, added status option to init script,
#                 added logic to remove the pidfile when the daemons is
#                 successfully killed.
#                 Also adopted regex tweak from wyodlows@nj.devry.edu so
#                 that Cyrus users can pop from unresolvable ip addrs
#                 (common w/ dialups).
#                 Back to Daniel Roesen, after a request from him, documented
#                 the trick of using a logger daemon to prod cleanups.
#                 Also from him, fixed typo "reset" -> "restart" in syntax
#                 msg in pop-before-smtp.init
#                 Attempted yet another desperate effort to perhaps accomodate
#                 all the different varients of qpopper in one $pat
# 1.14 2000-06-19 will the varient qpopper logfile formats never cease?
#                 this one from Nick Bauer <nickb@inc.net>
# 1.13 2000-06-13 yet another qpopper entry, this time from Chris
#                 D.Halverson <cdh@CompleteIS.com>; matches a
#                 logfile format he collected on a Solaris 2.6
#                 system w/ Qpopper 3.0b29.
# 1.12 2000-06-09 added popper entry to match logfile rec from Alex
#                 Burke <alex@pdqsolutions.com>
# 1.11 2000-06-08 added qpopper support thanks to Daniel Meredith
#                 <dman@madcat.investimg.com>
# 1.10 2000-04-05 added regexp for qmail's pop3d thanks to Frank Auciello
#                 <frank@torontowired.com>
# 1.9 2000-03-21 added support for files in mynetworks, tested by Andy Dills
# 1.8 2000-03-21 tweaked UW regexp based on further feedback from Andy Dills
# 1.7 2000-03-20 added regexp for courier-imap
# 1.6 2000-03-13 added installation notes on prerequisites to the readme
# 1.5 2000-02-21 added comment pointing to File::Tail for description of
#                the options with which I'm initializing it
# 1.4 2000-02-21 added comment describing pattern for Cyrus logfile entries,
#                from Kenn Martin <kmartin@infoteam.com>.
# 1.3 2000-02-07 fixed log-watching pattern to correctly recognize imap 
#                authentications.  -- Stig Hackvan <stig@hackvan.com>
# 1.2 2000-01-25 added discussion of possible problems with File::Tail using
#                tail => -1, thanks to Andy Dills <andy@xecu.net>. Also thanks
#                to Andy, fixed regexp to work right with clients who don't
#                have reverse DNS set up properly.
# 1.1 2000-01-21 added mention of Time::HiRes as prereq for File::Tail, thanks
#                to Stig Hackvan <stig@hackvan.com>
# 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] [--[no]flock] \
	[--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.

It contains support for protecting writes to the db file by flock.
As far as I know, the consequences of a collision (corrupt read in
an smtpd) are relatively mild, and the likelihood of one is remote,
but the performance impact of the locking seems to be negligible, so
it's enabled by default. To disable the flocking, invoke with
--noflock. Please let me know if you feel the default should be
changed, and if so why.

If invoked with --debug, it will emit a fair amount of nattering on
stdout, which may be helpful in diagnosing problems, then again it
may not. If invoked with --nowrite, it won't actually attempt to
write the db hash file; if your maillog is world-readable this might
allow you to try it out (with --debug) running as a non-privileged
user.

Edit the source to change the wired-in logfile format, tail parameters, 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.

=head1 INSTALLATION

This daemon directly requires three modules from CPAN, which are not
included in the base Perl release as of this writing, and one of
those depends on another, so make sure you've downloaded and
installed suitably recent versions of

	File::Tail
	Time::HiRes (required by File::Tail)
	Net::Netmask
	Date::Parse (from TimeDate)

In addition, it depends on the DB_File module; if you don't have it
included in your perl build already (presumably because Berkeley DB
wasn't available when your Perl was configured and built) then you
can provide it by downloading the CPAN DB_File module, available
from http://www.cpan.org/authors/id/PMQS/DB_File-1.73.tar.gz.
Alternatively, if your Postfix supports some other on-disk-hash
table type (check supported map types with "postconf -m") then you
can just change from "use DB_File" to the appropriate module for
that hash type (listed in the AnyDBM_File pod documentation) and use
that instead, remembering also to change the map type from "hash" in
the below postfix main.cf config change. And if you change the map
type, you'll also need to adjust the "tie" statement that uses it in
this script, changing at least the second arg from DB_File to the
name of the module you're using, and probably dropping the $DB_HASH
argument out.

This daemon likes a couple of helpers. Here's a nice init script:

	#!/bin/sh
	progname=`basename $0`
	pgm=/usr/sbin/$progname
	log=/var/log/$progname
	pid=/var/run/$progname.pid
	die(){ echo "$progname: $*">&2; exit 1; }
	case "$1" in
	 start) $pgm >$log 2>&1 & echo $! >$pid;;
	  stop) p=`cat $pid`; test -n "$p" || exit 0
		kill $p || exit 0; sleep 1
		kill -9 $p 2>/dev/null || exit 0; sleep 1
		kill -0 $p && die "$pid won't die"
		;;
	esac

The integration in /etc/postfix/main.cf might look like this:

  smtpd_recipient_restrictions = permit_mynetworks,reject_non_fqdn_recipient,
	check_client_access hash:/etc/postfix/pop-before-smtp,
	check_relay_domains

A minor issue in the design of this daemon is that for simplicity
and performance, it makes no attempt to provide a select loop, or
to otherwise allow periodic checking to clean out old entries even
if no new ones come in. The $grace interval cleanups of old entries
only occur when this daemon has just logged a new entry successfully
--- it passed all the pattern and postconf mynetworks checks. If
you get very few users checking their email with pop, an entry
could stay in the db file for far longer than $grace. Of course
it would still require a remarkable coincidence for a spammer to
exploit this, but if you want to prevent this, you can run another
daemon that's just a trivial shell loop. Compose a string that
looks like a valid POP login entry from your daemon, for someone
coming from the (impossible, but won't get weeded by mynetworks)
255.255.255.255 addr. Arrange for it to be logged once a minute,
or however often you want, to ensure that the daemon enters the
grace-period check/clean loop at least that often. E.g. using Daniel
Roesen's cucipop format, you could have:

        pat='x 255.255.255.255 0, 0 (0), 0 (0)'
        while true; do
                sleep 60 # or however long
                logger -p mail.info -t cucipop -i "$pat"
        done

=head1 TROUBLESHOOTING

Andy Dills <andy@xecu.net> reports that on his Solaris system,
File::Tail was hanging in the middle of reading a 15MB logfile. When
he removed "tail => -1" from the options (so the tail would start at
the end of the file, rather than at the beginning) that fixed it.

=head1 DOWNLOAD

See the website http://people.oven.com/bet/pop-before-smtp/ for the
latest version, and the mailing list for support.

=head1 AUTHOR

Bennett Todd, <bet@rahul.net>

=cut

use File::Tail;
use DB_File;
use Net::Netmask;
use Date::Parse;
use Getopt::Long;
use Sys::Syslog;
use Fcntl ':flock';

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

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

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

my $me = getpwuid($<); # real me
# Build complete sanitary environment
# If postconf isn't somewhere on this PATH, do fix the PATH so it is
%ENV = (
	PATH => '/usr/sbin:/usr/bin:/sbin:/bin:/usr/local/sbin:/usr/local/bin',
	HOME => '/tmp',
	SHELL => '/bin/sh',
	LOGNAME => $me,
);

# This regex pull the lines I'm interested in out of $logfile, and yanks out
# the timestamp and IP address

# For UW ipop3d/imapd, pattern tweaked by Stig Hackvan <stig@hackvan.com>
my $pat = '^(... .. ..:..:..) \S+ (?:ipop3d|imapd)\[\d+\]: ' .
          '(?:Login|Authenticated|Auth) user=\S+ host=(?:\S+ )?\[(\d+\.\d+\.\d+\.\d+)\](?: nmsgs=\d+/\d+)?$';

# Bennett Todd to add support for GNU pop3d
my $pat2 = '^(... .. ..:..:..) \S+ gnu-pop3d\[\d+\]: ' .
	  'User .* logged in with mailbox .* from (\d+\.\d+\.\d+\.\d+)$';

# There are many, many different logfile formats emitted by various
# qpoppers. Here's an attempt to match any of them, but for all
# I know it might also match failed logins, or something else.
# my $pat = '^(... .. ..:..:..) \S+ q?popper\S+\[\d+\]: .*\s(\d+.\d+.\d+.\d+)$';

# For Cyrus, Kenn Martin <kmartin@infoteam.com>, with tweak
# from William Yodlowsky for IP addrs that don't resolve:
# my $pat = '^(... .. ..:..:..) \S+ (?:pop3d|imapd)\[\d+\]: ' .
#           'login: \S*\[(\d+\.\d+\.\d+\.\d+)\] \S+ \S+';

# For Courier-IMAP:
#my $pat = '^(... .. ..:..:..) \S+ imaplogin: ' .
#          'LOGIN, user=\S+, ip=\[(\d+\.\d+\.\d+\.\d+)\]$';

# For qmail's pop3d:
#my $pat = '^(... .. ..:..:..) \S+ vpopmail\[\d+\]: ' .
#          'vchkpw: login \[\S+\] from (\d+\.\d+\.\d+\.\d+)$';

# For Qpopper POP/APOP Server
# my $pat = '^(... .. ..:..:..) \S+ (?:qpopper)\[\d+\]: Stats: \S+ ' .
#           '(?:\d+ ){4}(\d+.\d+.\d+.\d+)';

# Alex Burke's popper install
# my $pat = '^(... .. ..:..:..) \S+ popper\[\d+\]: Stats: \S+ ' .
#           '(?:\d+ ){4}(?:\S+ )?(\d+.\d+.\d+.\d+)$';

# Chris D.Halverson's pattern for Qpopper 3.0b29 on Solaris 2.6
# my $pat = '^(\w{3} \w{3} \d{2} \d{2}:\d{2}:\d{2} \d{4}) \[\d+\] ' .
#           ' Stats:\s+\w+ \d \d \d \d [\w\.]+ (\d+\.\d+\.\d+\.\d+)';

# Nick Bauer <nickb@inc.net> has something completely different as
# a qpopper logfile format
# my $pat = '^(... .. ..:..:..) \S+ qpopper\S+\[\d+\]: \([^)]*\) POP login ' .
#           'by user "[^"]+" at \([^)]+\) (\d+.\d+.\d+.\d+)$';

# For cucipop, matching a sample from Daniel Roesen:
# my $pat = '^(... .. ..:..:..) \S+ cucipop\[\d+\]: \S+ ' .
#           '(\d+\.\d+\.\d+\.\d+) \d+, \d+ \(\d+\), \d+ \(\d+\)';

# For popa3d with the patch from bartek marcinkiewicz <jr@rzeznia.eu.org>
# (available in contrib/popa3d/):
# my $pat = '^(... .. ..:..:..) \S+ popa3d\[\d+\]: Authentication passed for \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,
	"flock!" => \$flock,
	"logfile=s" => \$logfile,
	"dbfile=s" => \$dbfile,
	"grace=i" => \$grace,
) or die "syntax: $0 [--[no]write] [--[no]debug] [--[no]flock] " .
	"[--logfile=filename] [--dbfile=filename] [--grace=seconds]\n";

$flock = 0 unless $write; # flocking makes no sense if you're not writing

# 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.
# They are documented in the File::Tail pod; run "perldoc File::Tail" to
# find out details. I guessed at these to try and get this daemon to follow
# the logfile pretty closely (to avoid users having to wait too long
# after a pop before they can relay) without wasting too much CPU
# needlessly.
my $fi = File::Tail->new(
	name => $logfile,
	maxinterval => 10,
	interval => 5,
	adjustafter => 3,
	tail => 0,
);

# Daniel Roesen prefers this one; he feels that it does a better job
# of being suitably prompt about noticing new logins, and that the
# tuning that I chose is too likely to cause users to fail to be
# able to send email.
#
# my $fi = File::Tail->new(
#         name => $logfile,
#         maxinterval => 2,
#         interval => 1,
#         adjustafter => 3,
#         resetafter => 30,
#         tail => -1,
# );

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

openlog ('pop-before-smtp', 'pid', 'mail');

sub say_goodbye {
  syslog('crit', "exiting on signal %s", $_[0]);
  closelog();
  exit(1);
}
$SIG{'INT'} = sub { say_goodbye('INT'); };
$SIG{'TERM'} = sub { say_goodbye('TERM'); };

$SIG{__DIE__} = sub { 
  syslog('crit', "fatal error %s (%m)", $_[0]);
  closelog();
  # perl will perform the exit...
};
syslog('info','starting...');

sub cleanup_nets {
	my @r;
	for (@_) {
		s/^\s+//;
		s/\s+$//;
		s/\s+/ /g;
		s/^mynetworks\s*=\s*//;
		push @r, split /[,\s]+/, $_;
	}
	return @r;
}
my @mynets = cleanup_nets(`postconf mynetworks`);
while (my @tmp = grep { $mynets[$_] =~ m#^/# } 0..$#mynets) {
	for (reverse @tmp) {
		splice @mynets, $_, 1, cleanup_nets(`cat $mynets[$_]`);
	}
}
	
Net::Netmask->new($_)->storeNetblock() for @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;
my $fd = $dbh->fd;
open(DB_FH, "+<&=$fd") or die "$0: cannot open $dbfile filehandle: $!\n" if $write;
flock(DB_FH, LOCK_EX) or die "$0: flock LOCK_EX failed: $!\n" if $flock;
delete $db{$_} for keys %db;
flock(DB_FH, LOCK_UN) or die "$0: flock LOCK_UN failed: $!\n" if $flock;

$| = 1 if $debug;

while (1) {
	$_ = $fi->read;
	m/$pat/o or m/$pat2/o or next;
	my ($timestamp, $ipaddr) = ($1, $2);
	my $ts = str2time($timestamp) or next;
	$ts += $grace;
	next if $ts < time;
	syslog('debug', "read ts=$timestamp ip=$ipaddr") if $debug;
	next if findNetblock($ipaddr);
	syslog('debug', "accepted $ipaddr --- not in mynetworks") if $debug;
	push @q, [$ipaddr, $ts];
	my $already_enabled = exists($t{$ipaddr});
	$t{$ipaddr} = $ts;
	next if $already_enabled;
	syslog('info', "opening relay for $ipaddr --- not in mynetworks");
	flock(DB_FH, LOCK_EX) or die "$0: flock LOCK_EX failed: $!\n" if $flock;
	$db{$ipaddr} = "ok" if $write;
	print "\twritten ok\n" if $write and $debug;
	while ($q[0][1] < time) {
		if ($q[0][1] == $t{$q[0][0]}) {
			syslog('info', "closing relay for $q[0][0]".
				       ($debug? 
                                        " (ts=".localtime($q[0][1]).")" : 
        				"")
				);
			delete $t{$q[0][0]};
			delete $db{$q[0][0]} if $write;
		}
		shift @q;
	}
	$dbh->sync and die "$0: sync $dbfile: $!\n" if $write;
	flock(DB_FH, LOCK_UN) or die "$0: flock LOCK_UN failed: $!\n" if $flock;
}
