Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

Clean unknown users/email from pop3 account

by castaway (Parson)
on Sep 20, 2003 at 20:59 UTC ( [id://292909]=sourcecode: print w/replies, xml ) Need Help??
Category: networking code
Author/Contact Info castaway
Description: Someone started using my domain name to send spam mails, and I started to receive bounces to users that don't exist on my machine.. (I have a multi-drop pop3 account) So I decided to write a little something to remove them before they get picked up and delivered to root. This is meant to be added to .fetchmailrc using the 'preconnect' command. It relies on several MailTools modules (included in 5.8.0). The check if a user is valid locally is made using getpwnam() and Mail::Alias which parses sendmails aliases file.

Update: Also now throws away mails from certain countries, using Geo::IP to determine the oroginal source of the mail. Also parses/uses an XML email whitelist, to accept legitimate mails sent to mailing lists that I receive.

#!/usr/bin/perl
# Looks at all the mails waiting in a multi-drop pop3 box, and discard
+s
# 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"]/desc
+endant::email/child::text()');
@listaddresses = map {$_->address() } @listaddresses;

debug(Dumper(\@listaddresses));

# Parse UIDL file: expected, newline separated <user>@<pop3server> UID
+L
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)->address
+es())
        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 } @add
+resses} @fromaddress);
    next if(grep {debug("grep2 $_\n"); $x = $_; grep { $_ eq $x } @lis
+taddresses} @toaddress);
    $delete = 1, $reason = "Unknown To: address" if(!grep {debug("grep
+3 $_\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_ad
+dr($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 @_;
}
Replies are listed 'Best First'.
Re: Clean unknown users/email from pop3 account
by zentara (Archbishop) on Sep 21, 2003 at 17:01 UTC
    This isn't a comment on your code per-say, but it relates. I have a cpanel hosting account, and one of it's mail options is "send all unrouted mail to /dev/null", instead of the default account. They must do it thru procmail.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://292909]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others having a coffee break in the Monastery: (6)
As of 2024-03-29 10:04 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found