#!/usr/bin/perl -w

# POP3 account settings. Please, put suitable values here.
my $server   = 'server';
my $login    = 'user';
my $password = 'password';
my $filterdir = ".";

#
# Local domains.
# 
# These should be target of email, but not the source (via pop3)
#
my %local_domains = (
    'localhost' => 1,
);

# ----------------------------------------------------------------------
#
# Modified from pop3filter by Xavier Noria..
#
# Author: Xavier Noria <`echo -n ska@unfuers.pbz | tr a-z n-za-m`>
# Time-stamp: <2003-09-21 18:12:25 fxn>
#
# ..by Peter Fox.
#
# Usage:
#
#   pop3filter.pl
#
# Requires Graham Barr's Net::POP3 Perl module, which can be installed
# in a Unix box as root this way:
#
#   # perl -MCPAN -e 'install Net::POP3'
#
# This POP3 filter examines the email envelope addresses using demon's
# SDPS extension to POP3, and deletes emails we don't want to download.
#
# The objective is to _avoid their download_, which is desirable in slow
# connections where a few MBs of mail can take a few minutes to get.
#
# In any case _no mails are actually downloaded_, so after the filtering
# normal email can be retrieved from the everyday mail client as usual.
#
# Exit status is true if there are mails left after the filtering
# process, false if there are none left.
#
# Firstly the emails are examined for the sending and receiving domains,
# (don't expect to receive emails from our domain via pop3). Then they're
# compared against various lists: a couple of do not bounce list, then
# a bounce domains list. If they are in the do not bounce list, or NOT in the
# bounce list, they're left on the server, otherwise they're deleted.
#
# ----------------------------------------------------------------------

use strict;
use warnings;

use Net::Cmd;
use Net::POP3;
use FileHandle;

sub say { print @_, "\n" }

# ----------------------------------------------------------------------

my $date = `date '+%Y-%m-%d %H:%M:%S'`;
chomp($date);

# Connect to the server.
my $pop;
eval { $pop = Net::POP3->new($server) };
defined $pop or print <<MSG and exit;
Couldn't connect to the server.
MSG

# Log in.
my $nmails;
eval { $nmails = $pop->login($login, $password) };
defined $nmails or print <<MSG and exit;
I could connect to the server but couldn't log in.
MSG

sub getfromto
{
    my $cmd = shift;
    my $msgnum = shift;
    my @lines;
#    $cmd->debug(7);
    if($cmd->command("*ENV $msgnum")->response() == CMD_OK)
    {
	@lines = @{$cmd->read_until_dot()};
	warn "No response" unless @lines;
#	print "$lines[0]";
#	print "$lines[1]";
#	print "$lines[2]";
#	print "$lines[3]";
    }
    chomp $lines[2];
    chomp $lines[3];
    ($lines[2], $lines[3]);
}

#foreach my $key (keys %local_domains)
#{
#    print "$key -> $local_domains{$key}\n";
#}

#
# Local users that mustn't bounce on server
#
my %took;

my $ifh = new FileHandle  "<$filterdir/took";
while(<$ifh>)
{
    chomp;
    $took{$_} = 1;
}
undef $ifh;

#foreach my $key (keys %took)
#{
#    print "$key -> $took{$key}\n";
#}

#
# Senders that are always ok
#
my %fromok;

$ifh = new FileHandle  "<$filterdir/fromok";
while(<$ifh>)
{
    chomp;
    next if m/^#/;
    $_ =~ s/\*(\**)/*/g;
    $_ =~ s/\./\\./g;
    $_ =~ s/\*/\.\*/g;
    $fromok{"^$_\$"} = 1;
}
undef $ifh;

#foreach my $key (keys %fromok)
#{
#    print "$key -> $fromok{$key}\n";
#}

#
# Domains that we get spam from
#
my %baddomains;

$ifh = new FileHandle  "<$filterdir/baddomains";
while(<$ifh>)
{
    chomp;
    next if m/^#/;
    if($_ =~ m/\\N(.*)\\N/)
    {
	$baddomains{$1} = 1;
	next;
    }
    $_ =~ s/\*(\**)/*/g;
    $_ =~ s/\./\\./g;
    $_ =~ s/\*/\.\*/g;
    $baddomains{"^$_\$"} = 1;
}
undef $ifh;

#foreach my $key (keys %baddomains)
#{
#    print "$key -> $baddomains{$key}\n";
#}

my $from;
my $to;
my $msgnum;
my $size;
my $deleted = 0;
my $total_size_of_deleted = 0;
my $total_size_of_good = 0;

sub reject($)
{
    my $message = shift;
#    print "$date $msgnum: ***** <$from> for <$to> $message\n";
    print "$date ** <$from> for <$to> $message\n";
    $pop->delete($msgnum);
    $nmails--;
    $deleted++;
    $total_size_of_deleted += $size;
}

sub accept($)
{
    my $message = shift;
#    print "$date $msgnum: ##### <$from> for <$to> $message\n";
#    print "$date ## <$from> for <$to> $message\n";
    $total_size_of_good += $size;
}

# $nmails is "0E0" if there are no new mails, or a number otherwise
if ($nmails > 0) {
    my %messages = %{$pop->list};
#    print getfromto($pop, 1);
    foreach my $key (sort {$a <=> $b} keys %messages)
    {
	$msgnum = $key;
	$size = $messages{$msgnum};
	($from, $to) = getfromto($pop, $msgnum);
	my ($tolocal, $todomain) = split /@/, $to;
	my ($fromlocal, $fromdomain) = split /@/, $from;
	$todomain = lc($todomain);
	$fromdomain = lc($fromdomain);
#	print "$from $to\n";
	# First check local domains are to, and not from
	my $goodtodomain = $local_domains{$todomain} || 0;
	my $badfromdomain = $local_domains{$fromdomain} || 0;
	&reject("Not one of our domains"), next unless $goodtodomain;
	&reject("Sender domain purports to be ours"), next if $badfromdomain;
	my $goodtolocal = $took{$tolocal} || 0;
	&accept("recipient whitelisted"), next if $goodtolocal;
	my $goodsender = 0;
	foreach my $key (keys %fromok)
	{
	    $goodsender = 1, last if $from =~ m/$key/i;
	}
	&accept("sender whitelisted"), next if $goodsender;
	my $rejectfromdomain = 0;
	foreach my $key (keys %baddomains)
	{
	    $rejectfromdomain = 1, last if $fromdomain =~ m/$key/i;
	}
	&reject("Sender's domain unacceptable"), next if $rejectfromdomain;
	&accept("No rule activated");
    }
    say sprintf "$date $deleted deleted, total size was: %dK",
      int($total_size_of_deleted/1024) if $deleted;
    say sprintf "$date $nmails left, total size %dK remain in the mailbox", int($total_size_of_good/1024);
}
$pop->quit;

exit(0) if $nmails;
exit(1);