#!/usr/bin/perl

use Shell qw(rm);
use strict;

# *** NOTE: BE SURE TO CHANGE THIS LINE TO REFLECT YOUR CONFIGURATION! ***
my $spamfconf = '/home/user/spamfilter/conf/spamfilter.conf';


# *****************************************************************
# spamfilter.pl

my $appname = 'bHjp spamfilter';
my $version = '0.2.7';
my $verdate = '04.25.2002';

#
# usage:         use as an inline procmail filter. exit(0) if msg
#                should pass on through; exit(1) otherwise
#                .procmailrc eg.:
#
#                :0: spam.lock
#                * ? spamfilter.pl
#                potential-spam
#
#
# Copyright (C) 2001,2002 - Sean Keplinger, bHjp
#
#    (see LICENSE and README distributed with this program)
#
# version:     0.1.2   [sk] - corrected problem with spamcount reversed
#              0.1.3   [sk] - if there are whitespaces in domain/email
#                             lists, then anything will match...built
#                             pattern checking code
#              0.1.4   [sk] - correct problem with domain matching
#              0.2.0   [sk] - totally rewrote the blocking code -- added
#                             more functionality by allowing more fields
#                             to be passed / blocked
#              0.2.1   [sk] - added config file instead of hard-coded
#                             values. makes for easier distribution.
#              0.2.2   [sk] - clear spam.log after send / autoaddblock
#                             configuration
#              0.2.3   [sk] - added procmail log to spam.log send
#              0.2.3.1 [sk] - problem with spam email with <> only email
#                             addresses resolved; path to spamf_conf must
#                             be fully qualified!
#              0.2.3.2 [sk] - added 'select' statement into action
#                             allowing for different processing options
#              0.2.3.3 [sk] - minor mod to logout -- date slimming
#              0.2.4   [sk] - allow comments and blank lines in block.conf
#              0.2.4.1 [sk] - fixed minor problem with month in logout()
#              0.2.6   [sk] - fixed mass to: problem (in patter match)
#              0.2.7   [sk] - Added capability to block by contents of the
#                             message body (not sure why I didn't do this
#                             before.
#
# *****************************************************************

# inits
my ($line,$label,$value,$key,$header,$body,$tfield,$pattern,$action);
my (%conf,%h);
my (@ary_spamfconf,@ary_blockconf,@lines);

# load / parse new spamfilter config file
open(SPAMF_CONF, $spamfconf) || die("$! - could not locate spamfilter.conf at $spamfconf!\n");
  @ary_spamfconf = <SPAMF_CONF>;
close(SPAMF_CONF);

foreach $line (@ary_spamfconf) {
  ($label, $value) = split /:\s/, $line, 2;
  $label = lc($label);
  chomp($label);
  chomp($value);
  $conf{$label} = lc($value);
}

# load / parse block file
open(BLOCK_CONF, $conf{block_conf}) || die("$! - could not locate block.conf at $conf{block_conf}\n");
  @ary_blockconf = <BLOCK_CONF>;
close(BLOCK_CONF);

if ($conf{debug}) {
  print "$appname - v$version ($verdate)\n\n";
  print "***CONFIG\n";
  foreach $key (keys %conf) {
    print "$key: $conf{$key}\n";
  }
  print "***END CONFIG\n\n";
}

# read STDIN from procmail (grabs the actual email message)
{ local $/ = "";   # set paragraph mode
  $header = <STDIN>;
  undef $/;
  $body = <STDIN>;
}  

#DEBUG THE MESSAGE (way overkill, but potentially useful)
#if ($conf{debug}) {
#   open(DEBUGFILE,">>$HOME/bhjp/procmail/debug.log");
#      print DEBUGFILE ("$header");
#   close (DEBUGFILE);
#}

# split the header and create a hash of all xxx: variables
# this makes it a hell of a lot easier to parse!
@lines = split /\n(?!\s)/,$header;

foreach $line (@lines) {
  my($label, $value) = split /:\s/, $line, 2;
  $label = lc($label);
  chomp($label);
  chomp($value);
  $h{$label} = lc($value);
}

# strip to and from domains / grab email address
$h{domain} = getdomain($h{from});
$h{todomain} = getdomain($h{to});
$h{femail} = getemail($h{from});
$h{temail} = getemail($h{to});

# allow for the body of the message to be used in a rule. this might cause
# some problems with filtering if the rule isn't written right, but may prove
# to be useful when blocking html spam or unwanted words.
$h{body} = $body;

# **** RULES CHECKING BEGINS HERE ****
# ** DEBUGGING CRAP */*
if ($conf{debug}) {
  foreach $key (keys %h) {
    unless ($key eq "body") {print "$key: $h{$key}\n"}
  }
  print "*****\n";
}

# from block.conf, check each field against each pattern as specified
foreach (@ary_blockconf) {
  if ($_ !~ /^#/ || $_ !~ /^\n/) {($tfield, $action, $pattern) = split /,/,$_}
  chomp($h{$tfield});
  chomp($pattern);
  if (checkpattern($pattern)) { #check for good pattern (no blankline)
    if ($h{$tfield} =~ /$pattern/ig) {
      if ($conf{debug}) {print qq("$tfield}" matches "$pattern" in block.conf -- $tfield:$action...\n)}
         
      for ($action) {
        /BLOCK/i and do {
          logout(qq("$tfield" matches "$pattern" in block.conf -- $tfield:$action...));
          cleanup(1);
        last};

        /PASS/i and do {
          cleanup(0);
          last};
      } #end action select statement
    }
  }
}

# we've been through all of the exceptions, now automate email blocking...
# if the email isn't sent to me and they've made it this far, then it's
# probably spam. the only exceptions are from lists and mail forwarding
# addresses which should be tagged as domain,pass or email,pass in the
# block.conf. otherwise, this filter will add their email address as a 
# spammer and log it.

# add email to spam block list and log it
if ($conf{autoaddblock}) {
  open(ADDEMBLOCK,">>$conf{block_conf}") || die("$! - could not open $conf{block_conf}!\n");
    print ADDEMBLOCK ("femail,block,$h{femail}\n");
  close (ADDEMBLOCK);
  
  logout("$h{femail} is probably spam...tagged as email,block due to to:$h{to} field!");
  if ($conf{debug}) {print "$h{femail} is probably spam...tagged as email,block due to to:$h{to} field!"}
} else {
  logout("$h{femail} is probably spam...diverting (autoaddblock off)");
  if ($conf{debug}) {print "$h{femail} is probably spam...diverting (autoaddblock off)"}
}

cleanup(1);


# **** SUB DEFINITIONS ****
# cleanup and exit; increment spamcount as necessary; send log 
# (email) once spammax has been reached; rm log file
sub cleanup {
  my ($is_spam) = shift;
  my ($msgtxt,$msg);
  if ($is_spam > 0) {$conf{spamcount}++}

  # if spam counter reaches certain increment, then send log file
  if ($conf{spamcount} > $conf{spammax}) {
    if ($conf{debug}) {print "sending spam autoresponse to $conf{logemail}...\n"}
    my($msgtxt) = "**SPAMFILTER AUTORESPONDER --" . localtime() . " **\n\n\n";
    $msgtxt .= "!Autosend spam.log - spamcount ($conf{spamcount}) max ($conf{spammax}) exceeded\n";

    #get the mailstat stuff
    $msgtxt .= "!mailstat:\n";
    open(MAILSTAT,"mailstat $conf{logdir}/procmail.log|") || die("$! - cannot open mailstat pipe!\n");
      while (<MAILSTAT>) {$msgtxt .= "$_\n"}
    close(MAILSTAT);

    $msgtxt .= "\n!spam.log contents:\n";

    # grab the spam log 
    open(SPAMLOG,"$conf{logdir}/spam.log") || die("$! - could not open $conf{logdir}/spam.log!\n"); 
      while (<SPAMLOG>) {
        $msgtxt .= "$_\n";   
      }
    close(SPAMLOG);

    # construct the msg
    $msg = "From: bhjp.spamfilter.log\@one.net\n";
    $msg .= "To: $conf{logemail}\n";
    $msg .= "Subject: [spamfilter] log autoreponse\n";
    $msg .= "-- bHjp spamfilter autoresponse -- \n\nYou are receiving this message because an automated procedure has your email address listed as the receipient of the spam log.\n\nIf you have received this message by mistake, please send a message to $conf{probemail} to correct it.\n\n"; 
    $msg .= $msgtxt;
      
    # now, send the message
    open(MAIL,"|$conf{sendmailloc} -oi -t") || die("$! - can't open sendmail pipe!\n");
      print MAIL ($msg);
    close(MAIL);

    # delete the old spam.log
    rm("-f","$conf{logdir}/spam.log");

    $conf{spamcount}=0;
  }

  # write out new values to the config
  saveconf();

  # now exit using the spam code
  if ($conf{debug}) {print "exit status=$is_spam\n"}
   
  if ($is_spam >0) {exit(0)}
  if ($is_spam <1) {exit(1)}
}

# save configuration file
sub saveconf {
  if ($conf{debug}) {print "Saving config file to $spamfconf...\n"}
  open(SAVE_CONF,">$spamfconf") || die ("$! - could not open $spamfconf!\n");
    foreach $key (keys %conf) {
      print SAVE_CONF ("$key: $conf{$key}\n");
    }
  close(SAVE_CONF);
}

# output to log file
sub logout {
  my ($msg) = shift @_;
  my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
  $year += 1900;
  $hour *= 100;
  $hour += $min;  
  $mon += 1;
 
  open(LOGFILE,">>$conf{logdir}/spam.log");
    print LOGFILE ("$mon.$mday.$year:$hour ** $msg\n");
  close(LOGFILE);
}

# check pattern to see if it's good...
sub checkpattern {
  my ($inpattern) = shift @_;
  my ($badmatch) = "qjdhqhd1!&@^#^*&!@#";

  if ($badmatch =~ /$pattern/i) {
    logout("Blank line or bad pattern in conf! Check domain/email files!");
    if ($conf{debug}) {print "Blank line or bad pattern in conf! Check domain/email files!\n"}
    return 0;
  } else {
    return 1;
  }
}

# extract domain from email address
sub getdomain {
  my ($email) = shift @_;

  # tear down domain and rebuild to suit overseas addresses 
  my ($user, $site) = $email =~ /(.*)@(.*)/;
  #next unless $site;
  my @comp = split(/\./, $site);
  my ($n_comp) = ($comp[-1] =~ /^edu|com|net|org|gov|mil$/) ? 2: 3;
  my ($domain) = lc(join '.', @comp[-$n_comp .. -1]);
  ($domain = $domain) =~ s/^\.//; # remove leading .
  ($domain = $domain) =~ s/[<>]//g; # fix for other gunk (rig)

  return $domain;
}

# grab the email if it's in brackets (ie: "Sean Keplinger" <skeplin@one.net>)
sub getemail {
  my ($email) = shift @_;
  my ($femail) = "";

  ($femail = $email) =~ s/.+<(.+)>/$1/;
  ($femail = $femail) =~ s/<(.+)>/$1/;
   
  if ($femail eq '') {$femail = $email}

  return $femail;
}

# extract forwarders from received headers
sub forwarders {
  my (@forwarders,%r,$r);
  return @forwarders if @forwarders; # if already run...

  @forwarders = grep {/A-Za-z]/} ($h{received} =~ m/(?:[\w-]+\.)+[\w-]+/g);

  # weed out duplicates using standard hash technique
  foreach (@forwarders) {$r{lc $r} = 1}
  @forwarders = keys %r;

  return @forwarders;
}