RE: SA 3.0 and Greylisting (new version)

package SAExim;
use strict;
use Mail::SpamAssassin;
use Mail::SpamAssassin::Plugin;
our @ISA = qw(Mail::SpamAssassin::Plugin);

sub new {
  my ($class, $mailsa) = @_;
  $class = ref($class) || $class;
  my $self = $class->SUPER::new($mailsa);
  bless ($self, $class);
  $self->register_eval_rule ("greylisting");
  return $self;
}


# This was originally written to implement greylisting in SA-Exim, although
# I have tried to make it more general and allow for reuse in other MTAs
# (although they will need to
# 1) be running SA at SMTP time
# 2) Provide the list of rcpt to and env from in some headers for SA to read
# 3) Provide the IP of the connecting host )
#
# This rule should get a negative score so that if we've already seen the
# greylisting tuplet before, we lower the score, which hopefully brings us from
# a tempreject to an accept (at least that's how sa-exim does it)
# -- Marc <[email protected]> 2004/01/19

sub greylisting {
  my ($self, $permsgstatus, $optionhash) = @_;

  $optionhash  =~ s/;/,/g;
  # This is safe, right? (users shouldn't be able to set it in their config)
  my %option=eval $optionhash;
  my $connectip; 
  my $envfrom;
  my $rcptto;
  my @rcptto;
  my $iswhitelisted=0;
  my $err;
  my $mesgid = $permsgstatus->get ('Message-Id')."\n"; 
  my $mesgidfn;
  my $tuplet;

  foreach my $reqoption (qw ( method greylistsecs dontgreylistthreshold 
	connectiphdr envfromhdr rcpttohdr greylistnullfrom greylistfourthbyte ))
  {
    die "Greylist option $reqoption missing from SA config" unless (defined $option{$reqoption});
    #warn "found $reqoption -> $option{$reqoption}\n";
  }
  # No newlines, thank you (yes, you need this twice apparently)
  chomp ($mesgid);
  chomp ($mesgid);
  # Newline in the middle mesgids, are you serious? Get rid of them here
  $mesgid =~ s/\012/|/g;

  # For stuff that we know is spam, don't greylist the host
  # (that might help later spam with a lower score to come in)
  if ($permsgstatus->get_score() >= $option{'dontgreylistthreshold'})
  {
    #warn "debug: skipping greylisting on $mesgid, since score is already ".$self->{hits}." and you configured greylisting to not bother with anything above $dontcheckscore\n";
    return 0;
  }


  if (not $connectip = $permsgstatus->get($option{'connectiphdr'}))
  {
    warn "Couldn't get Connecting IP header $option{'connectiphdr'} for message $mesgid, skipping greylisting call\n";
    return 0;
  }
  chomp($connectip);
  # Clean up input (for security, if you use files/dirs)
  $connectip =~ s#/#-#g;

  # Account for a null envelope from
  if (not defined ($envfrom = $permsgstatus->get($option{'envfromhdr'})))
  {
    warn "Couldn't get Envelope From header $option{'envfromhdr'} for message $mesgid, skipping greylisting call\n";
    return 0;
  }
  chomp($envfrom);
  # Clean up input (for security, if you use files/dirs)
  $envfrom =~ s#/#-#g;
  if (not $envfrom)
  {
      $envfrom="<>";
      return 0 if (not $option{'greylistnullfrom'});
  }

  if (not $rcptto = $permsgstatus->get($option{'rcpttohdr'}))
  {
    warn "Couldn't get Rcpt To header $option{'rcpttohdr'} for message $mesgid, skipping greylisting call\n";
    return 0;
  }
  chomp($rcptto);
  # Clean up input (for security, if you use files/dirs)
  $rcptto =~ s#/#-#g;
  @rcptto = split(/, /, $rcptto);


  umask 0007;

  foreach $rcptto (@rcptto)
  {
    # The dir method is easy to fiddle with and expire records in (with
    # a find | rm) but it's probably more I/O extensive than a real DB
    # and suffers from directory size problems if a specific IP is sending
    # generating tens of thousands of tuplets. -- Marc
    # That said, I prefer formats I can easily tinker with, and not having to
    # worry about buggy locking and so forth 

    if ($option{'method'} eq "dir")
    {
      # The clean strings are hardcoded because it's hard to do a variable
      # substitution within a tr (and using the eval solution is too resource
      # expensive)
      $envfrom =~ tr/!#%( )*+,-.0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_abcdefghijklmnopqrstuvwxyz{|}~/_/c;
      # clean variables to run properly under -T
      $envfrom =~ /(.+)/;
      $envfrom = $1;
      $rcptto  =~ tr/!#%( )*+,-.0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_abcdefghijklmnopqrstuvwxyz{|}~/_/c;
      $rcptto =~ /(.+)/;
      $rcptto = $1;

      die "greylist option dir not passed, even though method was set to dir" unless ($option{'dir'});

      # Need to untaint $connectip
      unless ($connectip =~ m#^([\w.-]+)$#) {                  # $1 is untainted
          die "connectip '$connectip' has invalid characters.\n";
	  }
      $connectip = $1;                                         # $connectip untainted
      
      my ($ipbyte1, $ipbyte2, $ipbyte3, $ipbyte4) = split(/\./, $connectip); 
      my $ipdir1 = "$option{'dir'}/$ipbyte1";
      my $ipdir2 = "$ipdir1/$ipbyte2";
      my $ipdir3 = "$ipdir2/$ipbyte3";
      my $ipdir4;
      my $tupletdir;

      $ipdir4 = "$ipdir3";
      $ipdir4 .= "/$ipbyte4" if ($option{'greylistfourthbyte'});
      $tupletdir = "$ipdir4/$envfrom";

      $tuplet = "$tupletdir/$rcptto";
  
      # make directory whether it's there or not (faster than test and set)
      mkdir $ipdir1;
      mkdir $ipdir2;
      mkdir $ipdir3;
      mkdir $ipdir4;
      mkdir $tupletdir;

      if (not -e $tuplet) 
      {
        # If the tuplets aren't there, we create them and continue in
        # case there are other ones (one of them might be whitelisted already)
	$err="creating $tuplet";
	open (TUPLET, ">$tuplet") or goto greylisterror;
	print TUPLET time."\n";
	print TUPLET "Status: Greylisted\n";
	print TUPLET "Last Message-Id: $mesgid\n";
	print TUPLET "Whitelisted Count: 0\n";
	print TUPLET "Query Count: 1\n";
	$err="closing first-written $tuplet";
	close TUPLET or goto greylisterror;
      }
      else
      {
	my $time;
	my $status;
	my $whitelistcount;
	my $querycount;

	# Take into account race condition of expiring deletes and us running
	$err="reading $tuplet";
	open (TUPLET, "<$tuplet") or goto greylisterror;
	$err="Couldn't read time";
	defined ($time=<TUPLET>) or goto greylisterror;
	chomp ($time);

	$err="Couldn't read status";
	defined ($status=<TUPLET>) or goto greylisterror;
	chomp ($status);
	$err="Couldn't extract Status from $status";
	$status =~ s/^Status: // or goto greylisterror;

	# Skip Mesg-Id
	$err="Couldn't skip Mesg-Id";
	defined ($_=<TUPLET>) or goto greylisterror;

	$err="Couldn't read whitelistcount";
	defined ($whitelistcount=<TUPLET>) or goto greylisterror;
	chomp ($whitelistcount);
	$err="Couldn't extract Whitelisted Count from $whitelistcount";
	$whitelistcount =~ s/^Whitelisted Count: // or goto greylisterror;

	$err="Couldn't read querycount";
	defined ($querycount=<TUPLET>) or goto greylisterror;
	chomp ($querycount);
	$err="Couldn't extract Query Count from $querycount";
	$querycount =~ s/^Query Count: // or goto greylisterror;
	close (TUPLET);

	$querycount++;
	if ((time - $time) > $option{'greylistsecs'})
	{
	  $status="Whitelisted";
	  $whitelistcount++;
	}

	$err="re-writing $tuplet";
	open (TUPLET, ">$tuplet") or goto greylisterror;
	print TUPLET "$time\n";
	print TUPLET "Status: $status\n";
	print TUPLET "Last Message-Id: $mesgid\n";
	print TUPLET "Whitelisted Count: $whitelistcount\n";
	print TUPLET "Query Count: $querycount\n";
	$err="closing re-written $tuplet";
	close TUPLET or goto greylisterror;

        # We continue processing the other receipients, to setup or
	# update their counters
	if ($status eq "Whitelisted")
	{
	  $iswhitelisted=1;
	}
      }
    }
    elsif ($option{'method'} eq "file")
    {
      warn "codeme\n";
    }
    elsif ($option{'method'} eq "db")
    {
      warn "codeme\n";
    }
  }
  
  return $iswhitelisted;
  
  greylisterror:
  warn "Reached greylisterror: $err / $!";
  # delete tuplet since it apparently had issues but don't check for errors
  # in case it was a permission denied on write
  unlink ($tuplet);
  return $iswhitelisted;
}