#!/usr/bin/perl

# POP3 account settings. Please, put suitable values here.
my $server   = 'pop.example.com';
my $login    = 'login';
my $password = 'password';

# ----------------------------------------------------------------------
#
# Author: Xavier Noria <`echo -n ska@unfuers.pbz | tr a-z n-za-m`>
# Time-stamp: <2003-09-21 18:12:25 fxn>
#
# Usage:
#
#   Interactive mode:    perl pop3filter.pl
#   Nonstop mode:        perl pop3filter.pl -n
#
# 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 tries to identify mails containing the Swen worm
# (also known as Gibe) taking into account the message size and some
# patterns in the headers. Only messages whose size is greater than
# Swen's are inspected. That's close to 105K.
#
# 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.
#
# The filter can run in interactive mode, showing the patterns found and
# asking the user for deletion on the server, or in nonstop mode, which
# deletes any suspicious mails automatically, being suitable for nightly
# removals scheduled with cron(8). See usage above.
#
# Please, bear in mind that, albeit no false positive has been found as
# of this writing, we don't use an infallible test, so run the filter in
# nonstop mode at your own risk.
#
# In any case _no mails are actually downloaded_, so after the filtering
# normal email can be retrieved from the everyday mail client as usual.
#
# The heuristics we use are based on the worm exam published in
#
#    http://www.f-secure.com/v-descs/swen.shtml
#
# In particular, some ~14K messages I have received that look similar
# are NOT being filtered with the default settings. The worm's size is
# 105K, so I am not even sure those small mails have anything to do with
# Swen at all.
#
# Full scanners as those configurations for SpamAssassin and friends
# that are being published in some forums inspect the full email, which
# implies its download. They can fight the worm with more information
# and thus more effectively, so use them if you can and don't care about
# the download.
#
# Otherwise, this script has proven to be a superb help to me.
#
# ----------------------------------------------------------------------

use strict;
use warnings;

use Net::POP3;
use Term::ANSIColor qw(:constants);

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

# ----------------------------------------------------------------------
#
# This data is based on the worm exam published in
#
#      http://www.f-secure.com/v-descs/swen.shtml
#

# Size threshold in bytes.
my $size_threshold = 106496; # Swen's size

my $from_markers = join "|", qw(
MS
Microsoft
Corporation
Program
Internet
Network
Security
Division
Section
Department
Center
Technical
Public
Customer
Bulletin
Services
Assistance
Support
@\S*(?:microsoft|msd?n?)\.(?:net|com)
);

my $to_markers = join "|", qw(
Commercial
MS
Microsoft
Corporation
Customer
User
Partner
Consumer
Client
);

my $subject_markers = join "|", qw(
Current
Newest
Last
New
Latest
Net
Network
Microsoft
Internet
Critical
Security
Patch
Update
Pack
Upgrade
);
#
# ----------------------------------------------------------------------

# Process command line options.
my $opt = shift;
my $nonstop = defined $opt && $opt eq '-n' ? 1 : 0;

# 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

# $nmails is "0E0" if there are no new mails, or a number otherwise
if ($nmails > 0) {
    my $deleted = 0;
    my $total_size_of_deleted = 0;
    my %messages = %{$pop->list};
    while (my ($msgnum, $size) = each %messages) {
        my @lines = @{$pop->top($msgnum)};
        # extract From and Subject headers
        my ($from)    = grep /^From:/i, @lines;
        my ($to)      = grep /^To:/i, @lines;
        my ($subject) = grep /^Subject:/i, @lines;
        # is this message suspicious?
        if ($size > $size_threshold) {
            my $matches = 0;
            ++$matches if $from    =~ /\b(?:$from_markers)\b/o;
            ++$matches if $to      =~ /\b(?:$to_markers)\b/o;
            ++$matches if $subject =~ /\b(?:$subject_markers)\b/o;
            if ($matches > 1) { # sometimes "To:" comes empty
                if ($nonstop) {
                    # delete the message from the server and update counters
                    $pop->delete($msgnum);
                    $total_size_of_deleted += $size;
                    ++$deleted;
                    --$nmails;
                } else {
                    # highlight match if any
                    $from    =~ s/\b(?:$from_markers)\b/BOLD . RED . $& . RESET/geo;
                    $to      =~ s/\b(?:$to_markers)\b/BOLD . RED . $& . RESET/geo;
                    $subject =~ s/\b(?:$subject_markers)\b/BOLD . RED . $& . RESET/geo;
                    print "\nSize: @{[int($size/1024)]}K\n";
                    print $from, $to, $subject;
                    my $a = 'n';
                    do { print "delete [qnY]? "; $a = <STDIN> } until $a =~ /^[ynq]?$/i;
                    if ($a =~ /^y?$/i) {
                        # delete the message from the server and update counters
                        $pop->delete($msgnum);
                        $total_size_of_deleted += $size;
                        ++$deleted;
                        --$nmails;
                    } elsif ($a =~ /^q$/i) {
                        last;
                    }
                }
            }
        }
    }
    say sprintf "$deleted deleted, total size was: %dK",
      int($total_size_of_deleted/1024) if $deleted;
    say "$nmails left in the mailbox";
}
$pop->quit;