#!/usr/bin/perl 
##
##  pb4sd -- POP-before-SMTP Daemon
##  Copyright (c) 2001 Ralf S. Engelschall <rse@engelschall.com> 
##
##  This program is derived from Bennett Todd <bet@rahul.net>'s 
##  pop-before-smtp 1.28 (http://people.oven.com/bet/pop-before-smtp/)
##

use File::Tail;
use DB_File;
use Net::Netmask;
use Date::Parse;
use Getopt::Long;
use Fcntl ':flock';
use POSIX qw(getpid setsid);
use IO;

#   logfile parsing patters
my $pattern = {
    #   QPopper 4.0.x (OpenPKG)
    'qpopper' => 
        '^(... .. ..:..:..) (?:<\S+>|\S+) (?:/\S+?)?q?popper\S*\[\d+\]: ' .
        '\([^)]*\) POP login by user "[^"]+" at \([^)]+\) (\d+.\d+.\d+.\d+)$',
    #   Qpopper 3.x
    'popper3' => 
        '^(\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+)',
    #   UW ipop3d/imapd
    'ipop3d' =>
        '^(... .. ..:..:..) \S+ (?:ipop3d|imapd)\[\d+\]: ' .
        '(?:Login|Authenticated|Auth) user=\S+ host=(?:\S+)?\[(\d+\.\d+\.\d+\.\d+)\](?: nmsgs=\d+/\d+)?$',
    #   GNU pop3d
    'popd3d' => 
        '^(... .. ..:..:..) \S+ gnu-pop3d\[\d+\]: ' .
        'User .* logged in with mailbox .* from (\d+\.\d+\.\d+\.\d+)$',
    #   Cyrus
    'cyrus' => 
        '^(... .. ..:..:..) \S+ (?:pop3d|imapd)\[\d+\]: ' .
        'login: \S*\[(\d+\.\d+\.\d+\.\d+)\] \S+ \S+',
    #   Courier-IMAP
    'courier' => 
        '^(... .. ..:..:..) \S+ imaplogin: ' .
        'LOGIN, user=\S+, ip=\[(\d+\.\d+\.\d+\.\d+)\]$',
    #   Qmail pop3d
    'pop3d' => 
        '^(... .. ..:..:..) \S+ vpopmail\[\d+\]: ' .
        'vchkpw: login \[\S+\] from (\d+\.\d+\.\d+\.\d+)$',
    #   cucipop
    'cucipop' => 
        '^(... .. ..:..:..) \S+ cucipop\[\d+\]: \S+ ' .
        '(\d+\.\d+\.\d+\.\d+) \d+, \d+ \(\d+\), \d+ \(\d+\)',
    #   popa3d 
    'popa3d' => 
        '^(... .. ..:..:..) \S+ popa3d\[\d+\]: Authentication passed for \S+ -- \[(\d+.\d+.\d+.\d+)\]$',
};

#   parameters and their defaults
my $daemon     = 0;
my $infile     = 'qpopper.log';
my $dbfile     = 'qpopper';
my $popserver  = 'qpopper';
my @exclude    = ();
my $grace      = 1800;
my $logfile    = 'pb4s.log';
my $pidfile    = 'pb4s.pid';

#   option parsing
GetOptions(
    "daemon!"      => \$daemon,
    "infile=s"     => \$infile,
    "dbfile=s"     => \$dbfile,
    "popserver=s"  => \$popserver,
    "exclude=s@"   => \@exclude,
    "grace=i"      => \$grace,
    "logfile=s"    => \$logfile,
    "pidfile=s"    => \$pidfile,
) or die "Usage: p4bs [--daemon]\n" .
         "            [--infile=filename]\n" .
         "            [--dbfile=filename]\n" .
         "            [--popserver=type]\n" .
         "            [--exclude=a.b.c.d/x]\n" .
         "            [--grace=seconds]\n" .
         "            [--logfile=filename]\n" .
         "            [--pidfile=filename]\n";

#   make sure filenames are specified as absolute paths
die "--infile requires absolute filename" if ($infile !~ m|^/|);

#   make sure it is a known pop server
die "unknown pop server '$popserver'" if (not defined($pattern->{$popserver}));

#   make sure input logfile exists
die "logfile '$infile' not found" if (not -f $infile);

#   create tail object
my $lf = File::Tail->new(
    name        => $infile,
    maxinterval => 2,
    interval    => 1,
    adjustafter => 3,
    resetafter  => 30
) || die "unable to create tail object for '$infile'";

#   create network block
my $nt = {};
foreach my $exclude (@exclude) {
    my $nb = new Net::Netmask ($exclude) || die;
    $nb->storeNetblock($nt);
}

#   create DB hash file
my %db;
my $dbh = tie %db, 'DB_File', $dbfile, O_CREAT|O_RDWR, 0666, $DB_HASH
    || die "cannot open DB file '$dbfile': $!\n";

#   create DB hash file descriptor
my $fd = $dbh->fd;
open(DB_FH, "+<&=$fd") || die "cannot open '$dbfile' filehandle: $!\n";

#   delete database
flock(DB_FH, LOCK_EX) || die "(exclusive) lock failed: $!\n";
foreach $k (keys(%db)) {
    delete $db{$k}; 
}
flock(DB_FH, LOCK_UN) or die "unlock failed: $!\n";

#   open logfile
my $log = new IO::File ">>$logfile" || die;
$log->autoflush(1);

#   establish signal handlers
$SIG{__DIE__} = sub {
    $log->print("[".localtime(time())."] DIE error=".join(" ", @_)."\n");
    die @_;
};

#   start/stop logging
$log->print("[".localtime(time())."] STARTUP\n");
$SIG{'QUIT'} = $SIG{'INT'} = $SIG{'TERM'} = sub {
    $log->print("[".localtime(time())."] SHUTDOWN\n");
    exit(0);
};

#   optionally daemonize
if ($daemon) {
    my ($pid, $sess_id, $i);

    #   fork and exit parent 
    if ($pid = fork()) { 
        exit(0); 
    }

    #   detach from the terminal
    $sess_id = POSIX::setsid();

    #   prevent possibility of acquiring a controling terminal
    $SIG{'HUP'} = 'IGNORE'; 
    if ($pid = fork()) {
        exit(0);
    }

    #   create pidfile
    open(PID, ">$pidfile") || die;
    printf(PID "%d\n", POSIX::getpid());
    close(PID);

    #   change working directory
    chdir("/");

    #   clear file creation mask
    umask(0);

    #   close stdio file descriptors
    close(STDIN);
    close(STDOUT);
    close(STDERR);

    #   re-open stdio file descriptors to /dev/null
    open(STDIN,  "+>/dev/null");
    open(STDOUT, "+>&STDIN");
    open(STDERR, "+>&STDIN");
}

my $t = {}; # ip to expire table
my $q = []; # ip/expire stack
while (1) {
    my $line = $lf->read();
    my $now = time();
    if ($line =~ m/$pattern->{$popserver}/o) {
        my ($timestamp, $ipaddr) = ($1, $2);

        #   log recognition of entry
        $log->print("[".localtime($now)."] SEE client=".$ipaddr.
                    " login=".localtime(str2time($timestamp))."\n");

        #   calculate expire time
        my $expire = str2time($timestamp) || next;
        $expire += $grace;

        #   skip if grace period is already expired or ip is excluded
        next if ($expire < $now);
        next if (findNetblock($ipaddr, $nt));

        #   push ip/expire onto stack
        push @{$q}, [$ipaddr, $expire];

        #   remember ip
        my $already_enabled = exists($t->{$ipaddr});
        $t->{$ipaddr} = $expire;

        #   skip if ip was already enabled
        next if $already_enabled;

        #   lock database
        flock(DB_FH, LOCK_EX);

        #   add entry to database
        $db{$ipaddr} = "OK";
        $log->print("[".localtime($now)."] ADD client=".$ipaddr." logout=".localtime($expire)."\n");

        #   purge expired database entries
        while ($q->[0][1] < $now) {
            if ($q->[0][1] == $t->{$q->[0][0]}) {
                $log->print("[".localtime($now)."] DEL client=".$q->[0][0]." logout=".localtime($q->[0][1])."\n");
                delete $t->{$q->[0][0]};
                delete $db{$q->[0][0]};
            }
            shift @q;
        }

        #   synchronize database
        $dbh->sync();

        #   unlock database
        flock(DB_FH, LOCK_UN);
    }
}

__DATA__

=pod

=head1 NAME

pb4sd -- POP-before-SMTP Daemon

=head1 SYNOPSIS

B<p4bsd>
[--daemon]
[--infile=filename]
[--dbfile=filename]
[--popserver=type]
[--exclude=a.b.c.d/x]
[--grace=seconds]
[--logfile=filename]
[--pidfile=filename]

=head1 DESCRIPTION

B<pb4sd> is a little daemon program which watches a POP/IMAP server's
logfile for successful client authentications and writes the
corresponding IP addresses into a Berkeley-DB hash file. This hash file
then can be used by the MTA to allow relaying access.

=cut