#!/usr/bin/perl
#
#  poprelayd - update /etc/mail/popauth.db based on POP2/POP3/IMAP logins
#
#  POPRelayD is a program that monitors the maillog and updates a database 
#  for valid logins via POP and IMAP.  It is an excellent, time tested 
#  method for performing POP before SMTP Authentication.
#
#  This code was written by Curt Sampson <cjs@cynic.net> and placed into
#  the public domain in 1998 by Western Internet Portal Services, Inc.
#
#  Modified by Kevin A. McGrail <kmcgrail@peregrinehw.com> and kept in
#  the public domain.
#  
#  This modification removes the need for a reverse lookup if the IP
#  address of the client is already logged.  Additionally, 127.0.0.1
#  is skipped for entry in the popauth database.
#
#  poprelayd-KAM v1.1.1.1.06 2004/08/09
#
# .01 Initial Re-release
# .02 Added another case for machines with no hostname
# .03 Added Auth to Login for IP Stripping Lines
# .04 Work on EXLOCK problem with Linux 2.0.X and older glibc
# .05 Added more exceptions to the scanaddr function
# .06 Added logging of BAD RCPT Throttle IPs & Strict Mode / Fixed a bug in lffd / Documented -t switch / 
#     Changed -r option to update hash and perform a timeout as deleting the hash entry was unpredictable. / 
#     Very large re-write/re-visit to all of the code / Added -f switch
#
#  Usage:
#	poprelayd -d
#	poprelayd -p [-f]
#	poprelayd -a <ip> [-f]
#	poprelayd -r <ip> [-f]
#       poprelayd -t <num_of_seconds> [-f]
#
#  With the -d option this program goes into daemon mode. It will
#  monitor /var/log/maillog (following rollovers by newsyslog)
#  for successful POP3 logins. When it sees one, it will
#  look up the IP address the login came from and add this to the
#  popip sendmail map (the address as the key, the current time in
#  seconds since the epoch as the datum). Every minute, it 
#  will also remove any addresses older than a certain time from that
#  file.
#
#  If given the -p option, the program will not go into daemon mode,
#  but will instead dump the current database, printing each IP address
#  and its age.
#
#  The -a option will add the IP address given. The -r option will delete
#  the IP address given.
# 
#  The -f option will cause the program to use the RCPT Flood database 
#  instead of the POP3 database.

#

#
#  Modules
#

use Fcntl;
use DB_File;
use POSIX;
use strict;

#
#  Configuration settings.
#

our ($logfile, $pidfile, $pop_dbfile, $dbtype, $timeout_minutes, $log_wait_interval, $flood_dbfile, $flood_timeout_minutes, $help);

$logfile = "/var/log/maillog";		# POP3 daemon log.
$pidfile = "/var/run/poprelayd.pid";	# Where we put our PID.
$pop_dbfile = "/etc/mail/popauth.db";	# Sendmail map to update.
$dbtype = "DB_HASH";
$timeout_minutes = 240;			# Minutes an entry lasts.
$log_wait_interval = 5;			# Number of seconds between checks
					# of the log file.

$help = "Usage: poprelayd [-p] [-a <ip>] [-r <ip>] [-d]\n
\t-p\tPrint POP Auth DB and exit.\n
\t-a <ip>\tAdd an IP Address to the POP Auth DB and exit.\n
\t-r <ip>\tRemove an IP Address from the POP Auth DB and exit.\n
\t-t <seconds>\tRemove IP Addresses from the POP Auth DB older than specified seconds.\n
\t-f\tUsing -f in conjuction with the above commands will utilize the RCPT Flood Database instead.\n
\t\t-or-\n
\t-d\tEnter Daemon Mode, watch $logfile every $log_wait_interval second(s), 
\t\tupdate $pop_dbfile and remove stale entries after $timeout_minutes minute(s)\n\n";

# Sendmail has a feature called BAD RCPT Throttling which delays connections
# where people are repeatedly sending to BAD email addresses.  Because this
# is often used for SPAM, we are going to populate a database with the 
# information.  
#
# This program does NOTHING with the information but it might be used in 
# MIMEDefang for example to delay the connection

$flood_dbfile = "/etc/mail/rcpt_flood.db";  # Map with IPs for RCPT Flooding
$flood_timeout_minutes = "10";		    # Minutes an entry in the RCPT Flooding database

# You may need to uncomment this if your fcntl.ph doesn't export it.
# This seems to be ignored on Redhat Systems and does not seem to do anything different
# On Redhat 5.2 Systems, this line should be commented and the opendb_write procedure changed
# to remove the |O_EXLOCK.  
sub O_EXLOCK { 0x20 };

#
#  Variables
#
our ($pid, %db, $lffd, $lfino, $lfbuf, $lasttimeout);

undef $pid;				# Process ID.
undef %db;				# Hash into database file.
undef $lffd;				# $logfile file descriptor.
undef $lfino;				# Inode of $logfile when we opened it.
undef $lfbuf;				# Buffer for data from $lffd.
undef $lasttimeout;			# Last time we did a timeout.

#
#  Subroutines
#

sub opendb_read {
  my ($dbfile) = @_;
  my ($dbtype_pointer);

  unless ($dbfile) {
    $dbfile = $pop_dbfile;
  } 

  if (uc($dbtype) eq "DB_HASH") {
    $dbtype_pointer = $DB_HASH;
  } elsif (uc($dbtype) eq "DB_BTREE") {
    $dbtype_pointer = $DB_BTREE;
  } elsif (uc($dbtype) eq "DB_RECNO") {
    $dbtype_pointer = $DB_RECNO
  } else {
    die "Invalid DB Type $dbtype";
  }
  
  tie(%db, "DB_File", $dbfile, O_RDONLY, 0, $dbtype_pointer) || die "Can't open $dbfile";
}

sub opendb_write {
  my ($dbfile) = @_;
  my ($dbtype_pointer);

  unless ($dbfile) {
    $dbfile = $pop_dbfile;
  }  
  
  if (uc($dbtype) eq "DB_HASH") {
    $dbtype_pointer = $DB_HASH;
  } elsif (uc($dbtype) eq "DB_BTREE") {
    $dbtype_pointer = $DB_BTREE;
  } elsif (uc($dbtype) eq "DB_RECNO") {
    $dbtype_pointer = $DB_RECNO
  } else {
    die "Invalid DB Type $dbtype";
  }

  tie(%db, "DB_File", $dbfile, O_RDWR|&O_EXLOCK, 0, $dbtype_pointer) || die "Can't open $dbfile";
}

sub closedb {
  untie %db;
}

sub adddb {
  my $addr = $_[0];
  $db{$addr} = time;
}

sub removedb {
  my $addr = $_[0];
  $db{$addr} = ($timeout_minutes*60)+1;
}

# timeoutdb(secs)
#
# Remove all entries from %db more than secs seconds old.
#
sub timeoutdb {
  # Convert timeout in secs to a time_t before which we delete.
  my ($to, $key);
  $to = time - $_[0];

  foreach $key (sort(keys(%db))) {
    if ($db{$key} < $to)  {
      delete $db{$key};
    }
  }
}

# getlogline()
#
# Return the next line from $logfile, or undef if one isn't currently ready.
#
# XXX Note that there's a bug in this routine that causes it to ignore
# blank lines. I kinda like this behaviour, so I've not fixed it.
#
sub getlogline {
  my $junk;
  my $ino;
  my $foundeof = 0;
  my $buf;
  my $count;

  # The first time we're called; open the logfile, skip to the end,
  # and remember the inode we opened.
  if (!defined($lffd))  {
    $lffd = POSIX::open($logfile, O_RDONLY|O_NONBLOCK, 0);
    if (!defined($lffd))  {
      die "Can't open $logfile\n";
    }
    if (POSIX::lseek($lffd, 0, &POSIX::SEEK_END) == -1)  {
      die "Can't seek to end of $logfile\n";
    }
    ($junk, $lfino, $junk) = POSIX::fstat($lffd);
  }

  # Append new data, if available, to our buffer.
  $count = POSIX::read($lffd, $buf, 1024);
  if ($count)  {
    $lfbuf = $lfbuf . $buf;
  }

  # Return a line, if we have one.
  if ($lfbuf =~ m/\n/m)  {
    ($buf, $lfbuf) = split(/\n/m, $lfbuf, 2);
    return $buf;
  }

  # Check the inode number of $logfile; if it's not the saved one,
  # the logfile has been rotated and we need to reopen.
  ($junk, $ino, $junk) = POSIX::stat($logfile);
  if ($ino != $lfino)  {
    POSIX::close($lffd);
    undef($lffd);
    $lffd = POSIX::open($logfile, O_RDONLY|O_NONBLOCK, 0);
    if (!defined($lffd))  {
      die "Can't open $logfile\n";
    }
    ($junk, $lfino, $junk) = POSIX::fstat($lffd);
  }

  return undef;
}

# scanaddr($line)
#
# Scan $line to see if it's a log of a successful POP2/3/IMAP authentication.
# Return an array of the addresses that authenticated.
#
sub scanaddr ($) {
  my $s = $_[0];
  my @paddrs;		# Packed IP addresses.
  my @addrs;		# ASCII addresses.

  if ($s =~ m/i(pop2|pop3|map)d\[[0-9]+\]: (Login|Auth|Authenticated) user=/)  {
    # DEBUG ENTRY -- HOST NAME NO IP 
    #$s = "Mar  7 01:48:42 intel1 imapd[1653]: Login user=kam host=intel2.peregrinehw.com";
    # DEBUG ENTRY -- NO HOST NAME 
    #$s = "Mar  7 08:18:01 intel1 ipop3d[6265]: Login user=nscainc host=[64.67.148.177] nmsgs=1/1";
    # DEBUG ENTRY -- HOST NAME & IP
    #$s = "Mar  7 10:59:12 intel1 ipop3d[7851]: Login user=slothy host=1Cust199.tnt10.tco2.da.uu.net [63.39.89.199] nmsgs=1/1"; 

    #print "Line to clean -- $s\n";

    if ($s =~ /\[\d+\.\d+\.\d+\.\d+\]/) {
      # IP Address with NO Host Name
      if ($s =~ /host=\[\d+\.\d+\.\d+\.\d+\]/) {
        $s =~ s/.*host=\[(.*)\].*/$1/;
        if ($s ne "127.0.0.1") {
          push (@addrs,$s);
          #print "IP Added to Return Stack\n";
        }

      # Host Name with IP Address
      } else {
        $s =~ s/.*host=\S+ \[(.*)\].*/$1/;
        if ($s ne "127.0.0.1") {
          push (@addrs,$s);
          #print "IP Added to Return Stack\n";
        }
      }
      #print "IP Cleaned -- $s\n";

    # Host Name with No IP Address
    } else {
      $s =~ s/.*host=(\S+).*/$1/;
      #print "Address Found -- $s\n";
      (undef, undef, undef, undef, @paddrs) = gethostbyname($s);
      while (@paddrs)  {
        $s = join('.', unpack('C4', shift(@paddrs)));

        if ($s ne "127.0.0.1") {
          push(@addrs, $s);
          #print "IP Added to Return Stack\n";
        }
      }
      #print "Address Resolved -- $addrs[0]\n";
    }
    return @addrs;
  }
  return ();
}


# scanaddr_RCPT_flood($line)
#
# Scan $line to see if it's a log of a RCPT Flood
# Return an array of the addresses that match.
#
sub scanaddr_RCPT_flood($) {
  my $s = $_[0];
  my @paddrs;		# Packed IP addresses.
  my @addrs;		# ASCII addresses.

  if ($s =~ m/: Possible SMTP RCPT flood, throttling\.$/i)  {
    #DEBUG ENTRY -- HOST NAME & IP
    #$s = "Aug  8 15:54:38 intel1 sendmail[4841]: i78Jsb9R004841: rdc.irahhayes.org [12.28.145.116]: Possible SMTP RCPT flood, throttling.";
    #DEBUG ENTRY -- IP & NO HOST NAME
    #$s = "Aug  8 15:55:06 intel1 sendmail[4921]: i78Jt1Za004921: [220.175.197.200]: Possible SMTP RCPT flood, throttling.";

    #print "Line to clean -- $s\n";

    if ($s =~ /\[\d+\.\d+\.\d+\.\d+\]/) {
      # IP Address with NO Host Name
      if ($s =~ /: \[\d+\.\d+\.\d+\.\d+\]( \(may be forged\))?: Possible/) {
        $s =~ s/.*: \[(.*)\]:.*/$1/;
        if ($s ne "127.0.0.1") {
          push (@addrs,$s);
          #print "IP: $s Added to Return Stack\n";
        }

      # IP Address with HOST NAME
      } else {
        $s =~ s/.*: \S+ \[(.*)\]( \(may be forged\))?: Possible.*/$1/;
        if ($s ne "127.0.0.1") {
          push (@addrs,$s);
          #print "IP: $s Added to Return Stack\n";
        }
      }
    } 
    return @addrs;
  }
  return ();
}


#  cleanup
#
#  Clean up and exit; executed on receipt of a sighup.
#
sub cleanup {
  unlink $pidfile;
  exit 0;
}

&main();
exit;

sub main {
  #
  #  Main Program
  #
  
  my ($countopts, $key, $line, $addr, @ret, @addrs, @flood_addrs, $dbfile, $timeout);

  use vars qw($opt_f $opt_a $opt_d $opt_p $opt_r $opt_t);
  use Getopt::Std; 

  $countopts = 0;
  getopts('a:dfpr:t:') || \
    die "$help";

  #Switch to Flood Database 
  if ($opt_f) {
    $dbfile = $flood_dbfile;
    $timeout_minutes = $flood_timeout_minutes
  } else {
    $dbfile = $pop_dbfile;
  } 

  # Add an address.
  if ($opt_a)  {
    $countopts++;
    &opendb_write($dbfile);
    &adddb($opt_a);
    &closedb;
  }
  
  # Remove an address.
  if ($opt_r)  {
    $countopts++;
    &opendb_write($dbfile);
    &removedb($opt_r);
    &timeoutdb($timeout_minutes*60);
    &closedb;
  }
  
  # Timeout entries.
  if ($opt_t)  {
    $countopts++;
    die "Invalid timeout value: $opt_t.\n\n$help" unless $opt_t > 0;
    &opendb_write($dbfile);
    &timeoutdb($opt_t);
    &closedb;
  }
  
  # Print address list.
  if ($opt_p)  {
    $countopts++;
    &opendb_read($dbfile);
    foreach $key (sort(keys(%db))) {
      print "$key\t", time - $db{$key}, "\n";
    }
    &closedb;
  }
  
  # Daemon mode.
  if ($opt_d)  {
    # Check to see we can read/write the files we need.
    die "Can't read $logfile: $!\n\n$help" if ! -r $logfile;
    die "Can't write $pop_dbfile: $!\n\n$help" if ! -w $pop_dbfile;

    # Become a daemon: fork, detach, cd /, set creation mode to 0.
    if ($pid = fork)  {
      exit 0;				# Parent.
    } elsif (defined($pid)) {
      $pid = getpid;			# Child.
    } else {
      die "Can't fork: $!\n\n$help";
    }
    # Catch signals.
    $SIG{INT} = \&cleanup;
    $SIG{TERM} = \&cleanup;
    $SIG{HUP} = \&cleanup;
    # Write PID file.
    open(PIDFILE, ">$pidfile") || die "Can't open PID file: $!\n\n$help";
    print PIDFILE "$pid\n";
    close(PIDFILE);
    chmod(0644, $pidfile);
    # Detach from terminal, etc.
    setpgrp(0, 0);
    close(STDIN); close(STDOUT); close(STDERR);
    chdir("/");

    # Main loop.
    $lasttimeout = 0;
    $timeout = 0;
    while (1)  {
      # Build list of addresses of recent authentications.
      while ($line = &getlogline)  {
        undef @ret;
        if (@ret = &scanaddr($line))  {
          push(@addrs, @ret);
        }
        if (@ret = &scanaddr_RCPT_flood($line)) {
          push(@flood_addrs, @ret);
        }
        
      }

      # Add this list to current set for POP Database -- Functionalize this Routine?
      &opendb_write($pop_dbfile);
      while ($addr = pop(@addrs))  {
        &adddb($addr);
      }
      # Timeout entries if we haven't for a minute.
      if ((time - $lasttimeout) > 60)  {
        $lasttimeout = time;
        $timeout++;
        &timeoutdb(60 * $timeout_minutes);
      }
      &closedb;


      # Add this list to current set for Flood Database -- Functionalize/Reuse above Routine?
      &opendb_write($flood_dbfile);
      while ($addr = pop(@flood_addrs))  {
        &adddb($addr);
      }
      # Timeout entries if we just did it for the POP database
      if ($timeout)  {
        $timeout = 0;
        &timeoutdb(60 * $flood_timeout_minutes);
      }
      &closedb;

      sleep $log_wait_interval;
    }
  }
  
  if (! $countopts)  {
    die "$help";
  }
}