#!/usr/bin/perl
# Looks at all the mails waiting in a multi-drop pop3 box, and discards
# any that would not be delivered to local users anyway.
# (Using getpwname and Mail::Alias to recognise local users)
# $Revision: 1.2 $ $Date: 2003/12/03 00:39:41 $

use warnings;
use Net::POP3;
use Mail::Header;
use Mail::Field;
use Mail::Field::Received; # complain if not installed!
use Mail::Address;
use Mail::Alias;
use Regexp::Common 'net';
use Geo::IP::PurePerl;
use XML::LibXML;

# use Data::Dumper;
use Data::Dump::Streamer 'Dumper';
$| = 1;
$DEBUG = 0;

# Log headers of mail that gets deleted here:
# (my fetchmail runs as root, YMMV)
# my $LOGFILE = $ENV{HOME} . "/pop3clean.log";
my $LOGFILE = "/root/pop3clean.log";
# print $LOGFILE;

# Sendmails aliases file lives here:
my $mailaliases = "/etc/aliases";

# Fetchmails UIDL store, if using (else will get all mails!)
my $uidlsfile = '/root/.fetchids';

# Edit to fit your POP3 account:
my ($user, $passwd, $host) = ('desert-i', 'XXX', 'mail.m.isar.de');

# XML Email addressbook
my $XMLBook = '/home/castaway/perl/data/emaillist.xml';

# Countries we dont want mail from:
my @countries = ('KR', 'CN', 'CL', 'AR', 'MX');

# My addresses:
my @me = ('castaway@desert-island.m.isar.de',
          'me@localhost'
          );

##############################################################################

# GeoIP Object
my $gip = Geo::IP::PurePerl->new();

# Addressbook parser:
my $parser = XML::LibXML->new();
my $addrbook = $parser->parse_file($XMLBook) ;
my @addresses = map { my $e =$_->textContent(); 
                      $e =~ s/\n//g; 
                      $e =~ s/\s+$//g; 
#                      $e }
                      Mail::Address->parse($e)} 
 $addrbook->findnodes('descendant::email/child::text()');
@addresses = map {$_->address() } @addresses;

my @listaddresses =  map { my $e =$_->textContent();
                           $e =~ s/\n//g;
                           $e =~ s/\s+$//g;
#                      $e }
                           Mail::Address->parse($e)}
$addrbook->findnodes('descendant::address[attribute::type="list"]/descendant::email/child::text()');
@listaddresses = map {$_->address() } @listaddresses;

debug(Dumper(\@listaddresses));

# Parse UIDL file: expected, newline separated <user>@<pop3server> UIDL
my @uidls = do { local(@ARGV) = $uidlsfile; <> };
debug("Found:" . Dumper(\@uidls). "\n");
@uidls = map { chomp; (split(/\s+/, $_))[1] } @uidls;
debug("Found:" . Dumper(\@uidls). "\n");

open(LOGFILE, ">>$LOGFILE") or
    die "Can't open $LOGFILE for append, ($!)\n";
my $aliases = Mail::Alias->new($mailaliases);
debug("Aliases: " . Dumper($aliases) . "\n");
my $pop = Net::POP3->new($host,Timeout=>30) or 
    die "Can't connect to $host: ($!)\n";
my $messages = $pop->login($user=>$passwd) or 
    die "Can't log in:",$pop->message,"\n";

my $last = $pop->last(); # BROKEN!

debug("You have $messages - $last messages\n");

my $msguidl = $pop->uidl();
debug("Found:" . Dumper($msguidl). "\n");

my @msgs = sort {$a<=>$b} 
            grep { my $uidl = $msguidl->{$_}; 
                   !grep { $uidl eq $_ } @uidls } 
             keys %$msguidl;

debug("Found:" . Dumper(\@msgs). "\n");


foreach my $msgnum (@msgs)
# foreach my $msgnum ($last+1 .. $messages)
# foreach my $msgnum (keys %$msgs) # Test! (all mesgs)
{
    my $delete = 0;
    my $reason = 1;

    debug($msgnum, "\n");
    my $header = $pop->top($msgnum);
    debug(Dumper($header));
    my $mh = Mail::Header->new($header);
    debug("Headers: " , Dumper($mh), "\n");
    
    my @mfs = Mail::Field->extract('Received', $mh);

    my @fromaddress = Mail::Field->extract('From', $mh)->addresses();
    my $to = Mail::Field->extract('To', $mh);
    my @toaddress = $to->addresses() if($to);
    @toaddress = (@toaddress, Mail::Field->extract('CC', $mh)->addresses())
        if(Mail::Field->extract('CC', $mh));
     debug("To: ", Dumper(\@toaddress));
     debug("From: ", Dumper(\@fromaddress));

    # check against the list we're accepting from:
    my $x;
    next if(grep {debug("grep1 $_\n"); $x = $_; grep { $_ eq $x } @addresses} @fromaddress);
    next if(grep {debug("grep2 $_\n"); $x = $_; grep { $_ eq $x } @listaddresses} @toaddress);
    $delete = 1, $reason = "Unknown To: address" if(!grep {debug("grep3 $_\n"); $x = lc($_); grep { $_ eq $x } @me} @toaddress);
    # Check hostname/alias/localuser ?

    # Dont accept mails that arent a local user/alias
    my $mf = Mail::Field->extract('Received', $mh, 1);
    debug("MF" . Dumper($mf) . "\n");
    my $res = $mf->parse_tree();
    debug("Res:" . Dumper($res). "\n");
    my ($addr) = Mail::Address->parse($res->{'for'}->{'for'});
    debug(Dumper($addr). "\n") if($addr);
    debug("No for address in Mail::Address object?\n") if(!$addr);

    if($addr)
    {
        debug("Alias: ", $aliases->exists($addr->user()), "\n");
        debug("Local: ", $addr->user(), "\n");
        debug("Local: ", getpwnam($addr->user()), "\n");

        $delete = 1 if(!defined(getpwnam($addr->user())) && 
                       ($aliases && !$aliases->exists($addr->user())));

        # reverse decision of checking @toaddress, above
        # And aliases: local users arent aliased
        $delete = 0, $reason = "" if(defined(getpwnam($addr->user())));

        if($delete && !$reason)
        {
            $reason = "Unknown local user/alias: " . $addr->user();
            print "Reason (Aliases): $reason\n";
        }
    }

    # Look for the originating address of the mail
    # (Starting at the last (original), Received header)
    my $ip;
    foreach my $field (reverse @mfs)
    {
        debug("Received headers :" , Dumper($field), "\n");
        my $f = $field->parse_tree();
        debug("Received headers-parsed :" , Dumper($f), "\n");
        debug(Dumper($f), "\n");
        $f = $f->{'from'};
        debug(Dumper($f), "\n");
        $ip=$1 if($f->{'address'} && 
                  $f->{'address'} =~ /$RE{net}{IPv4}{-keep}/);
        $ip = $1 if(!$ip && $f->{'from'} && 
                    $f->{'from'} =~ /$RE{net}{IPv4}{-keep}/);
        if($ip)
        {
            last;
        }
    }
    debug("IP: $ip\n");
    debug("From: ", $gip->country_name_by_addr($ip) ||'', "\n");
    debug("From: ", $gip->country_code_by_addr($ip) ||'', "\n");

    my $co =  $gip->country_code_by_addr($ip) || '';
    print "Found Mail from: [$ip] ", ($gip->country_name_by_addr($ip) || ''),"\n";
    print LOGFILE "Found Mail from: [$ip] ", ($gip->country_name_by_addr($ip) || ''),"\n";

    # Go to next email, if this is a country we are accepting from
    next if((!$co || !grep(/\Q$co\E/, @countries)) && !$delete);

    if(!$delete)
    {
        $reason = "Country: " . $gip->country_name_by_addr($ip);
        debug("No reason yet - $reason\n");
    }
    debug("Oops, thats not a mail for us!\n");

    # Default Action, log header, delete file:
    print LOGFILE "\n".localtime(), "\n", "Reason: $reason\n", 
                  $mh->as_string(), "\n";
    $pop->delete($msgnum);
}
close(LOGFILE);
$pop->quit();


sub debug
{
    return if(!$DEBUG);

    print @_;
}