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

# Check the website <URL:http://popbsmtp.sf.net/> for the latest version,
# and the mailing list for discussing this program and asking for help at
# <URL:http://lists.sourceforge.net/lists/listinfo/popbsmtp-users>

# pop-before-smtp 1.31
# Copyright (C) 1999, 2000, 2001 Bennett Todd.
# Also Copyright (C) 2002 Wayne Davison. Freely Redistributable.

=head1 NAME

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

=head1 SYNOPSIS

 nohup pop-before-smtp [--config=FILE] [--[no]write] [--[no]debug] \
     [--[no]flock] [--reprocess] [--watchlog=FILE] [--dbfile=FILE] \
     [--logto=FILE] [--grace=SECONDS] [--dumpconfig] [--daemon=PIDFILE]

=head1 DESCRIPTION

pop-before-smtp watches your mail log file (e.g. /var/log/maillog) for lines
written by your POP/IMAP software (e.g. UW popd/imapd) that indicate a
successful login. When found, pop-before-smtp installs an entry for the IP in
an on-disk hash (DB) that is watched by your SMTP software (e.g. Postfix,
sendmail, qmail, etc.). It then expires these entries when 30 minutes have
elapsed after the last POP/IMAP access from that IP.

=head1 OPTIONS

=over 4

=item --config=FILE

Specify the config file to read instead of /etc/pop-before-smtp-conf.pl.
Useful for testing a new configuration before you install it. This option
must occur first on the command-line since it will be processed before
reading the config file, and all other options will be processed after
reading the config file.

=item --[no]write

Specify --nowrite if you don't want the DB file to be even opened, let alone
updated. Useful for trying out pattern-matching rules, especially when used
with --debug and --reprocess.  (If your maillog is world-readable, you can
even run the test as a non-privileged user.)

=item --[no]debug

If you specify --debug, logging to stdout will be enabled, plus extra
debug messages will be generated to help you diagnose local/remote IP
distinctions. Specify --logto after this option if you want the messages
to go somewhere other than stdout.  Often combined with --reprocess.

=item --[no]flock

Using --noflock will turn off the default file-locking used on the DB file.

=item --reprocess

Parse the whole maillog file, pretending that each line is happening again.
Useful for testing, especially when combined with --debug and possibly
--nowrite.

=item --watchlog=FILE

You can specify what maillog to watch for POP/IMAP events. The default in the
script is /var/log/maillog, but the provided config file searches for an
existing log file, also checking for /var/log/mail/info, /var/log/mail.log,
/var/log/messages, or /var/adm/messages.

=item --dbfile=FILE

You can specify what DB file to update. The default value is
"/etc/postfix/pop-before-smtp" which creates/updates a file with the same name
but with ".db" appended (since the default tie function appends a ".db" onto
the specified name for you). If your config file supersedes the tie function,
you can choose to append a different suffix or no suffix at all.

=item --logto=FILE

Turns on logging to the specified file (use "-" for stdout).

=item --grace=SECONDS

Set the number of seconds that an IP address is authorized after it
successfully signs in via POP or IMAP.

=item --dumpconfig

Output some config info and exit. This makes it easy to see what things like
the dbfile, logto, and watchlog values are being set to in the config file.

=item --daemon=PIDFILE

Become a daemon by forking, redirecting STDIN/STDOUT/STDERR to /dev/null,
calling setsid, calling chdir('/'), and writing out the process ID of the
forked process into the specified PIDFILE.

=back

=head1 INSTALLATION

This daemon directly requires four 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 & Date::Format (both in 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.803.tar.gz.
Alternatively, if your SMTP software supports some other on-disk-hash
table type (you can check Postfix's supported map types with "postconf -m")
then you can just add an appropriate "use" statement for your hash type to the
config file (look in the AnyDBM_File pod documentation) and then setup your own
tie/sync/flock subroutines (see the BerkeleyDB example in the config file).
Also remember that if you're using Postfix, the example main.cf section we
include below will need you to change the "hash:" prefix to the appropriate
prefix for your DB type.

You should edit the supplied pop-before-smtp-conf.pl file to customize things
for your local system, such as scanning for the right POP/IMAP authorization,
setting various options, etc.

When starting up, pop-before-smtp builds an internal table of all netblocks
natively permitted by your SMTP software (for Postfix it looks at the output of
"postconf mynetworks"). This allows us to filter out local IP addresses that
are already authorized and thus need no special help from us.

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 --logto=$log --daemon=$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

For those using Postfix, 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

For those using a recent sendmail (at least version 8.9), you can add this
to your cf file:

    HACK(`popauth')

and then enable the sendmail SMTP section in the config file.

=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, SUPPORT, etc.

See the website http://popbsmtp.sf.net/ for the latest version.
See the mailing list (referenced on the website) for support.

=head1 INTERNALS

pop-before-smtp 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 when
the timestamp of the record there has expired (is > 30 minutes old) it tosses
it, and if the timestamp in the hash equals the timestamp in the queue, it
deletes the hash entry and the on-disk db file entry.

pop-before-smtp protects the 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 or set "$flock = 0" in the
config file.

=head1 AUTHORS

Pop-before-smtp was created by Bennett Todd <bet@rahul.net>.  It is
currently being maintained by Wayne Davison <wayned@users.sourceforge.net>.

=cut

use File::Tail;
use DB_File;
use Net::Netmask;
use Date::Parse;
use Date::Format;
use Getopt::Long;
use Fcntl ':flock';
use POSIX 'setsid';

use vars qw(
    $pat $write $flock $debug $reprocess $grace $logto %file_tail
    @mynets %db $dbfile $dbvalue
    $mynet_func $tie_func $sync_func $flock_func $log_func
);

# Default values, possibly overridden in the config file.

$pat = '^(... .. ..:..:..) \S+ (?:ipop3s?d|imaps?d)\[\d+\]: ' .
    '(?:Login|Authenticated|Auth) user=\S+ ' .
    'host=(?:\S+ )?\[(\d+\.\d+\.\d+\.\d+)\](?: nmsgs=\d+/\d+)?$';
$write = 1; # open and change the DB
$flock = 1; # we do the exclusive file-locking when updating
$debug = 0; # no debug messages
$reprocess = 0; # no debug reprocessing of watchlog
$dbfile = '/etc/postfix/pop-before-smtp'; # DB hash to write
$dbvalue = 'ok';
$grace = 30*60; # 30-minute grace period
my($daemon_pidfile, $dump_config);

$mynet_func = \&mynet_postfix;
$tie_func = \&tie_DB;
$sync_func = \&sync_DB;
$flock_func = \&flock_DB;

# See the pop-before-smtp-conf.pl file for what these values mean.
%file_tail = (
    name => '/var/log/maillog',
    maxinterval => 10,
    interval => 5,
    adjustafter => 3,
    tail => -1,
);

# Build complete sanitary environment.
%ENV = (
    PATH => '/usr/sbin:/usr/bin:/sbin:/bin:/usr/local/sbin:/usr/local/bin',
    HOME => '/tmp',
    SHELL => '/bin/sh',
    LOGNAME => scalar getpwuid($<), # real me
);

my $config_file = '/etc/pop-before-smtp-conf.pl';

# Kludge the parsing of the --config=FILE option so we can parse the
# rest of our options after reading the config file.
if (@ARGV && $ARGV[0] =~ /^--config=(.*)/) {
    require $1;
    shift;
}
elsif (-f $config_file) {
    require $config_file;
}

GetOptions(
    'config=s' => sub { die "--config=$_[1] must be the first option.\n" },
    'daemon=s' => \$daemon_pidfile,
    'write!' => \$write,
    'debug!' => sub { $debug = $_[1]; $logto = '-' if $debug },
    'flock!' => \$flock,
    'reprocess!' => \$reprocess,
    'watchlog|logfile=s' => \$file_tail{'name'},
    'dbfile=s' => \$dbfile,
    'logto=s' => \$logto,
    'grace=i' => \$grace,
    'dumpconfig' => \$dump_config,
) or die <<EOT;
Usage: $0 [--config=FILE] [--[no]write] [--[no]debug]
    [--[no]flock] [--reprocess] [--watchlog=FILE] [--dbfile=FILE]
    [--logto=FILE] [--grace=SECONDS] [--dumpconfig] [--daemon=PIDFILE]
EOT

if ($dump_config) {
    print "watchlog: $file_tail{'name'}\n";
    print "dbfile: $dbfile\n";
    print "logto: $logto\n" if defined $logto;
    exit;
}
if (defined $daemon_pidfile) {
    chdir('/') or die "Can't chdir to /: $!";
    open(STDIN, '/dev/null') or die "Can't read /dev/null: $!";
    open(STDOUT, '>/dev/null') or die "Can't write to /dev/null: $!";
    my $pid = fork;
    die "Can't fork: $!" unless defined $pid;
    if ($pid) {
	open(PF, ">$daemon_pidfile")
	    or die "Can't write to $daemon_pidfile: $!";
	print PF "$pid\n";
	close PF;
	exit;
    }
    open(STDERR, '>&STDOUT');
    setsid;
}

$file_tail{'tail'} = -1 if $reprocess;

if (defined $logto) {
    set_output_log($logto);
    $SIG{'HUP'} = sub { set_output_log($logto); }
}

$sync_func = sub { } if !$write;
$flock_func = sub { } if !$flock || !$write;
$log_func = sub { } if !$log_func;

my $fi = File::Tail->new(%file_tail);

$SIG{'INT'} = \&sig_handler;
$SIG{'TERM'} = \&sig_handler;
$SIG{__DIE__} = \&mydie;

$| = 1;

my $now = time;
$log_func->('info', 'starting up');

@mynets = cleanup_nets($mynet_func->());
Net::Netmask->new($_)->storeNetblock() for @mynets;

my (%t, @q);

if ($write) {
    # If we're not re-reading the log file, set the existing DB entries
    # to expire in $grace seconds from our startup time.
    my $expire_old_at = $file_tail{'tail'}? 0 : $now + $grace;
    $tie_func->();
    $flock_func->(1);
    foreach (keys %db) {
	if ($expire_old_at) {
	    push @q, [$_, $expire_old_at];
	    $t{$_} = $expire_old_at;
	    $log_func->('debug', "initialized old ip=$_") if $debug;
	}
	else {
	    delete $db{$_};
	    $log_func->('debug', "removed old ip=$_ from DB") if $debug;
	}
    }
    $flock_func->(0);
}

my $db_changed = 0;
my $expire_check_time = 0;

while (1) {
    $_ = $fi->read;
    if ($reprocess) {
	# To assist with debugging, pretend the current time is when this
	# line's event happened.
	/^(... .. ..:..:..)/ and $now = str2time($1);
    }
    else {
	$now = time;
    }

    my($timestamp, $ipaddr);
    if (defined(&custom_match)) {
	($timestamp, $ipaddr) = &custom_match;
	next unless defined($ipaddr);
    }
    else {
	next unless ($timestamp, $ipaddr) = /$pat/o;
    }

    my $ts = str2time($timestamp) or next;
    $ts += $grace;
    next if $ts < $now;

    if (findNetblock($ipaddr)) {
	$log_func->('debug', "ignoring local-net ip=$ipaddr") if $debug;
	next;
    }
    $log_func->('debug', "found ip=$ipaddr") if $debug;
    push @q, [$ipaddr, $ts];
    my $already_enabled = exists($t{$ipaddr});
    $t{$ipaddr} = $ts;
    next if $already_enabled;

    $flock_func->(1);
    $db{$ipaddr} = $dbvalue;
    $log_func->('info', "added $ipaddr to DB");
    $db_changed = 1;
}
continue {
    if ($db_changed || $now >= $expire_check_time) {
	while (@q && $q[0][1] <= $now) {
	    my($ipaddr,$ts) = @{shift @q};
	    $log_func->('debug', "expiration event for ip=$ipaddr") if $debug;
	    if ($ts == $t{$ipaddr}) {
		if (!$db_changed) {
		    $flock_func->(1);
		    $db_changed = 1;
		}
		delete $t{$ipaddr};
		delete $db{$ipaddr};
		$log_func->('info', "removed $ipaddr from DB");
	    }
	}
	if ($db_changed) {
	    $sync_func->();
	    $flock_func->(0);
	    $db_changed = 0;
	}
	$expire_check_time = $now + $grace / 2 + 60;
    }
}

exit;


sub cleanup_nets
{
    my @nets;
    foreach (@_) {
	# Detaint.  Also remove leading/trailing spaces.
	($_) = /^\s*(.*?)\s*$/s;
	foreach (split /[,\s]+/) {
	    if (m#^/#) {
		# Slurp the whole file into $_.
		undef $/;
		open(IN, $_) or die "Unable to open $_: $!";
		$_ = <IN>;
		close IN;
		$/ = "\n";
		# Remove any comments from the file's data.
		s/#.*//mg;
		push @nets, cleanup_nets($_);
	    }
	    elsif (m#^hash:#) {
		# Just ignore hash files for now.
	    }
	    else {
		push @nets, $_;
	    }
	}
    }
    @nets;
}

# --- START --- The default Postfix/DB_File support functions

sub mynet_postfix
{
    $_ = `postconf mynetworks`;
    s/^mynetworks\s*=\s*//;
    $_;
}

my $dbh;

# We set the global %db to the opened database hash.  We also set $dbh for
# our sync_DB function, and DB_FH for our flock_DB function.
sub tie_DB
{
    $dbh = tie %db, 'DB_File', "$dbfile.db", O_CREAT|O_RDWR, 0666, $DB_HASH
	or die "$0: cannot dbopen $dbfile: $!\n";
    if ($flock) {
	my $fd = $dbh->fd;
	open(DB_FH,"+<&=$fd") or die "$0: cannot open $dbfile filehandle: $!\n";
    }
}

sub sync_DB
{
    $dbh->sync and die "$0: sync $dbfile: $!\n";
}

sub flock_DB
{
    flock(DB_FH, $_[0]? LOCK_EX : LOCK_UN)
	or die "$0: flock_DB($_[0]) failed: $!\n";
}

# --- END --- The default Postfix/DB_File support functions

sub log_to_stdout
{
    my $level = shift;
    print time2str('%b %e %T ', $now), @_, "\n";
}

sub set_output_log
{
    my($file) = @_;
    open(LOG, ">>$file") or die "Unable to append to $file: $!";
    $log_func = \&log_to_stdout;
    select(LOG);
}

sub sig_handler
{
    my($sig) = @_;
    $log_func->('crit', "caught SIG$sig -- exiting");
    exit 1;
}

sub mydie
{ 
    my($msg) = @_;
    $log_func->('crit', "fatal error: $msg") if defined $log_func;
}
