#!/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.13 2005/10/24
#
# .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
# .07 Added addition of iptables calls to maintain blocks for people doing harvesting and to kill any 
#     associated sendmail processes -- Requires IPTables::IPv4 and Pkill now.
# .08 Changed the INPUT rule to an INSERT and augmented rule_exists more
# .09 Fixed snafu in reloading iptable on a new startup
# .10 Added -n No Fork option (suggested by Albert Whale)
# .11 Added centralized UDP Reporting for SMTP RCPT Floods 
# .12 Added DoveCot to parsing
# .13 Added Dovecot 1.0 to parsing
#
#  Usage:
#	poprelayd -d [-n]
#	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. Additionally,
#  specifying -n will cause the program not to fork into the background.
#  The daemon will then monitor /var/log/maillog (following rollovers from 
#  the system log being rotated) 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.
#  
#  The -t option will run a timeout on the database for all entries older than
#  the specified number of seconds

#

#
#  Modules
#

use Fcntl;
use DB_File;
use POSIX;
use strict;
use IPTables::IPv4;
use IO::Socket;

#
#  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.
#
# After considering this heavily, we decided to also implement the code to 
# block these people as they are probably harvesting bad addresses from the
# server

$flood_dbfile = "/etc/mail/rcpt_flood.db";  # Map with IPs for RCPT Flooding
$flood_timeout_minutes = "90";		    # 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, %params) = @_;
  my ($output);

  $db{$addr} = time;

  if ($params{'iptables'}) {
    &add_iptable(chain=>"RCPT_flood", source=>$addr, jump=>"RCPT_flood_log", cli=>$params{'cli'});
  }
}

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 {
  my ($timeout_secs, %params) = @_;

  # Convert timeout in secs to a time_t before which we delete.
  my ($to, $key, $output);
  $to = time - $timeout_secs;

  foreach $key (sort(keys(%db))) {
    if ($db{$key} < $to)  {
      delete $db{$key};
      if ($params{'iptables'}) {
        &remove_iptable(chain=>"RCPT_flood", source=>$key, jump=>"RCPT_flood_log");
      }
    }
  }
}

# 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.

  #DOVECOT 1.0 w/SSL
  #Oct 24 03:46:13 intel1 dovecot: imap-login: Login: user=<kam>, method=PLAIN, rip=68.105.183.179, lip=209.225.49.10, TLS
  if ($s =~ /^... .. ..:..:.. .* dovecot: (pop3|imap)-login: Login: .+ rip=(\d+\.\d+\.\d+\.\d+),.*$/i) {
    $s =~ s/^... .. ..:..:.. .* dovecot: (pop3|imap)-login: Login: .+ rip=(\d+\.\d+\.\d+\.\d+),.*$/$2/i;

    push (@addrs, $s);

    #print "DEBUG: $s\n";

    return @addrs;
  }

  #DOVECOT 0.99
  #Apr 27 14:33:26 intel1 imap-login: Login: kmcgrail [69.3.86.30]
  if ($s =~ /^(... .. ..:..:..) \S+ (?:pop3|imap)-login: Login: .+ \[(\d+\.\d+\.\d+\.\d+)\]/) {
    $s =~ s/^(... .. ..:..:..) \S+ (?:pop3|imap)-login: Login: .+ \[//;
    $s =~ s/\]$//;
    push (@addrs, $s); 

    #print "DEBUG: $s\n";

    return @addrs;
  }

  #UW-IMAP & SIMILAR
  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, $output);

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

  $countopts = 0;
  getopts('a:dfpr:t:n') || \
    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);
    if ($opt_f) {
      &adddb($opt_a, iptables=>1, cli=>1);
    } else {
      &adddb($opt_a);
    }
    &closedb;
  }
  
  # Remove an address.
  if ($opt_r)  {
    $countopts++;
    &opendb_write($dbfile);
    &removedb($opt_r);
    if ($opt_f) {
      &timeoutdb(($timeout_minutes*60), iptables=>1);
    } else {
      &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);
    if ($opt_f) {
      &timeoutdb($opt_t, iptables=>1);
    } else {
      &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;

    #SETUP IPTABLE RULES TO BLOCK RCPT_FLOODs
    &setup_iptable;
    #ADD ALL EXISTING ENTRIES FROM FILE TO BLOCK
    &opendb_read($flood_dbfile);
    foreach $key (sort(keys(%db))) {
      &add_iptable(chain=>"RCPT_flood", source=>$key, jump=>"RCPT_flood_log");
    }
    &closedb;

    unless ($opt_n) {
      # 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);

    unless ($opt_n) {
      # 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, iptables=>1);
      }
      # Timeout entries if we just did it for the POP database
      if ($timeout)  {
        $timeout = 0;
        &timeoutdb((60 * $flood_timeout_minutes), iptables=>1);
      }
      &closedb;

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

sub setup_iptable {
  my ($table, $rv, $error, $chain, @chains, $testiter, @rules);

  $error = 0;
  $table = IPTables::IPv4::init('filter');
  if ($table) {
    @chains = ("RCPT_flood","RCPT_flood_log");
    foreach $chain (@chains) {
      unless ($table->is_chain($chain)) {
        $rv = $table->create_chain($chain);
        if ($rv < 1) {
          print "Error Creating $chain - $!\n";
          $error++;
        }
      } else {
        $rv = $table->flush_entries($chain);
        if ($rv < 1) {
          print "Error Flushing $chain - $!\n";
          $error++;
        }
      }
    }
  }

 #Excluding the local network from poprelayd can be done by modifying the setup_iptable routine in setup_iptable.
 #Modify the setup_iptable routine to return from the chain that drops the packets for your local network(s):
 #Untested but should work.  KAM 08-26-04

 #$rv = $table->append_entry("RCPT_flood_log", { jump=>"RETURN", source=>"192.168.1.0/24" });
 #if ($rv < 1) {
 #  print "Error Adding LOG rule - $!\n";
 #  $error++;
 #} 


  $rv = $table->append_entry("RCPT_flood_log", { jump=>"LOG", "log-prefix"=>"FW: RCPT_Flood " });
  if ($rv < 1) {
    print "Error Adding LOG rule - $!\n";
    $error++;
  } 

  $rv = $table->append_entry("RCPT_flood_log", { jump=>"DROP"});
  if ($rv < 1) {
    print "Error Adding DROP rule - $!\n";
    $error++;
  }      

  #SOMETIMES THE INPUT RULE ALREADY EXISTS SO LET'S GET RID OF IT
  while (&rule_exists($table, chain=>"INPUT", protocol=>"tcp", "destination-port"=>"25", jump=>"RCPT_flood")) {
    $table->delete_entry("INPUT", {  protocol=>"tcp", "destination-port"=>"25", jump=>"RCPT_flood" });
  }

  #THIS NEEDS TO BE THE FIRST RULE IN CASE OTHER RULES LIKE DROP ALREADY EXIST 
  $rv = $table->insert_entry("INPUT", { protocol=>"tcp", "destination-port"=>"25", jump=>"RCPT_flood"}, 0);
  if ($rv < 1) {
    print "Error inserting INPUT rule - $!\n";
    $error++;
  }
 
  if ($error == 0) {
    return ($table->commit());
  }
}

sub add_iptable {
  my (%rule) = @_;

  my ($table, $output);

  $table = IPTables::IPv4::init('filter'); 

  unless (&rule_exists($table, chain=>$rule{'chain'}, source=>$rule{'source'}, jump=>$rule{'jump'})) {
    #RULE DOESN'T EXIST, LET'S ADD IT
    $table->append_entry($rule{'chain'}, { source=>$rule{'source'}, jump=>$rule{'jump'} });
    unless ($rule{'cli'}) {
      #NOW LET'S KILL SENDMAIL PROCS WITH THE SAME SOURCE
      $output = `/usr/bin/pkill -f $rule{'source'}`; 
    }
    &rr_log("$rule{'source'}\t\tRCPT_flood");
  } 
  return ($table->commit());
}

sub remove_iptable {
  my (%rule) = @_;

  my ($table);

  $table = IPTables::IPv4::init('filter');
  
  $table->delete_entry($rule{'chain'}, { source=>$rule{'source'}, jump=>$rule{'jump'} });
  return ($table->commit());
} 

sub rule_exists {
  my ($table, %rule) = @_;

  my (@rules, $i);

  @rules = $table->list_rules($rule{'chain'});

  for ($i = 0; $i <= $#rules; $i++) {
    if ($rules[$i]->{'source'} eq $rule{'source'} && $rules[$i]->{'jump'} eq $rule{'jump'}) {
      if ($rule{'destination_port'} ne "" && $rule{'protocol'} ne "") {
        if ($rules[$i]->{'destination_port'} eq $rule{'destination_port'} && $rules[$i]->{'protocol'} eq $rule{'protocol'}) {
          return 1;
        }
      } else {
       return 1;
      }
    }
  }
  return 0;
}

sub rr_log {
  my ($log) = @_;

  my($sock, $server_host, $PORTNO);

  $PORTNO = 5155;

  $server_host = '209.225.49.90';

  $sock = IO::Socket::INET->new(Proto     => 'udp',
                                PeerPort  => $PORTNO,
                                PeerAddr  => $server_host);

  $sock->send($log);
}