#!/usr/bin/perl -Tw
require 5.006_001;
use strict;
use sigtrap;
=head1 NAME
bfproxy - performs bogofilter functions via email
=cut
my $version = "0.3.5";
################################################
############### Copyleft Notice ################
################################################
# Copyright © 2003 Order amid Chaos, Inc.
# Author: Tom Anderson
# neo+bfproxy@orderamidchaos.com
#
# This program is open-source software; you can redistribute it
# and/or modify it under the terms of the GNU General Public
# License, v2, as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public
# License along with this program; if not, write to:
#
# Free Software Foundation
# 59 Temple Place, Suite 330
# Boston, MA 02111-1307 USA
#
# http://www.gnu.org/
#################################################
################# Documentation #################
#################################################
# use "perldoc bfproxy" or "bfproxy -h" to read this
=head1 SYNOPSIS
=head2 Command line usage:
B<bfproxy> [I<options>] < [I<rfc822_email>]
=head2 Procmail usage (recommended):
Add to ~/.procmailrc the following recipe. This recipe needs to
be BEFORE the filtering recipe to prevent reclassifying all of
the forwarded messages again.
:0fw
* ^To: $USER\+bfproxyID
| $HOME/.bogofilter/bfproxy
Where I<$HOME> is your home directory, if not set in the environment,
I<$USER> is your login name, if not set, and "I<bfproxyID>" is any
string by which you choose to identify mail that should be
processed by bfproxy. Essentially, you are matching your regular
email address with "I<+bfproxyID>" after it. Eg:
joe.shmoe+mybfproxystring@somedomain.com
Joe's procmail recipe would then be:
:0fw
* ^To: joe.shmoe\+mybfproxystring
| $HOME/.bogofilter/bfproxy
Don't use the default "I<bfproxyID>" though, and keep yours
confidential so that people can't send bogofilter commands on your
behalf. The from address would have to be spoofed, and you'd get a
report anyway, but why tempt fate? Using your own unique
"I<bfproxyID>" helps prevent automated attacks by spammers on
bogofilter users.
When entering the bogofilter recipe after the bfproxy recipe, you
should add the C<E> flag so that bogofilter does not filter the
results of running bfproxy. Eg:
:0Efw
| bogofilter -uep
It's not necessary, but suggested. If you use the C<-u> option with
bogofilter, these bfproxy-trained emails would be trained again
otherwise, which is generally not what you want. You would also
risk having the results thrown in with your spam, which would also
be undesireable. Therefore, it's best to use the C<E> flag in the
bogofilter recipe.
Just remember to make sure that the bogofilter recipe is AFTER the
bfproxy recipe to prevent screwing up your database by double-
classifying those attached emails.
=head2 Email usage:
When using an MDA such as Procmail to handle running bfproxy, as
intended, you'll need to send yourself emails with the special
"I<bfproxyID>" included, followed by any options. Eg:
[I<USER>]+[I<bfproxyID>]-[I<options>]@[I<DOMAIN>]
The email you send to this address should contain any emails you
want to correct as attachments. Using your email client's forward-
as-attachment functionality should suffice. All such attached
emails will be processed according to address-line options.
=head1 OPTIONS:
=head2 Address-line options:
=over 4
=item B<C>
all emails with an original bogosity of I<spam> or I<ham> will
be unregistered and then re-registered as the opposite bogosity
(C<-Sn>, C<-Ns>). This is useful if the emails were originally
auto registered with the C<-u> flag or if a user error occurred.
=item B<R>
all emails with an original bogosity of I<spam> or I<ham> will
be registered as the opposite bogosity (C<-n>, C<-s>).
=item B<N>
unregister all attached emails from the ham database
=item B<S>
unregister all attached emails from the spam database
=item B<n>
register all attached emails as ham
=item B<s>
register all attached emails as spam
=item B<x>
Repeatedly register emails that are within the "unsure" zone
of spamicity values (between ham_cutoff and spam_cutoff) until
they are correctly classified or until I<rmax> has been reached.
=item B<v>
Verbose output. Show per-email registration information in
addition to the subject lines and summary.
=item B<b>
Show benchmarking information in the output.
=item B<c>
Display bogofilter configuration info in the output.
=back
If no address-line command is provided, it defaults to C<C> for
"correction" mode. If you choose to use C<C> or C<R> and wish to
register unsures at the same time, you can add a secondary command
after the C<C> or C<R> to register unsures as either spam (C<s>)
or ham (C<n>). Eg:
joe.shmoe+mybfproxystring-Rs@somedomain.com
The result of the above command string will be that all emails
previously classified as spams will be registered as hams, all
emails previously classified as hams will be registered as spams,
and all emails previously classified as unsures will be registered
as spams. If a secondary command is not used with C<C> or C<R>,
then unsures are not registered.
=head2 Command-line options:
=over 4
=item B<h>
display this help file
=back
=head1 REQUIRES
=over 4
=item *
Perl 5.6.1
=item *
bogofilter
=back
=head1 DESCRIPTION
Bfproxy accepts an email on stdin (generally from procmail or some
other MDA) containing one or more forwarded-as-attachment emails.
It will extract the attached emails and remove [SPAM] indicators
from the subject line. Then, it'll determine the original
classification of each email from its X-Bogosity field, and pass
the original emails to bogofilter with the appropriate flags as
determined by address-line options.
The attachments containing the emails should be message/rfc822
format, which is how most email clients will do
forwarding-by-attachment by default. If they are not in this
format, then it is quite likely that important header information
is being omitted, and bfproxy will ignore such attachments.
Moreover, bfproxy will only recognize attachments in encapsulating
MIME types multipart/mixed or multipart/digest. Quoted-text
attachments will not work, nor will inline attachments which do not
conform to the previous requirements (rfc822 and mixed or digest).
Just about any MUA should be able to meet these requirements for
forwarding emails. If there is one that uses a slightly different,
but possibly acceptable format, please send a bug report to
neo+bfproxy@orderamidchaos.com.
Also, bfproxy will not parse attached emails multiple MIME levels.
If an attachment has an attachment, then the whole thing will get
parsed as a single email rather than accounting for the headers in
the attached email. Do not nest corrections within each other.
This scheme uses "subaddressing" to direct the MDA to run the
email through bfproxy without requiring a new user or alias on the
system. Moreover, the output of the operation will arrive in the
user's mailbox without having to resend a second email. This also
allows bfproxy to run with the permissions of the user whose
database is to be altered by the command, and access his/her
environment, including the appropriate config files and db files.
See RFC3598 (http://www.ietf.org/) for details on "subaddressing".
It is supported by common MTA's such as Sendmail.
=head1 FAQ
=head2 Why isn't it working?
If you get an error the first time you try it, such as bfproxy
saying it received zero emails for correction, then view the source
of the email you sent and make sure the attachments use
message/rfc822 format, and that the attachments are contained in a
MIME part of multipart/mixed or multipart/digest. If not, check your
email client's options to see if you can get it into that format. If
you get any other errors/problems, please submit a bug report.
=head2 Why call it 'bfproxy' instead of 'bogoproxy', etc.?
Because "bogo" refers to bogons which are the elementary particle
of bogosity which bogofilter filters. We're not proxying bogons
but commands to bogofilter. Therefore, despite the lyrical
synergy that "bogoproxy" would have, it simply wouldn't make any
logical sense, whereas the less elegant bfproxy is more
descriptive of its actual function... proxying "bf" commands.
=head2 What happens to X-headers from my client/proxy/etc?
X-headers are left as-is now, unlike initial bfproxy behavior. The
reason is that bogofilter's Bayesian algorithm will essentially make
those X-headers irrelevant to classifications since an equal number
will come from spams as from hams. Therefore emails will end up
being classified based on other tokens instead. And this way,
X-headers from senders' clients/proxies/servers/etc may be useful in
classifying. Furthermore, this reduces the number of ad hoc rules
that bfproxy applies and would need to be maintained. Bogofilter
already strips the X-Bogosity header, so it is unnecessary to do so
in bfproxy.
=head1 BUGS
=over 4
=item Please report any.
=back
=head1 TODO
=over 4
=item Add more verbosity options
=item Use bogofilter -Q to obtain non-standard tags, formats, etc.
=item Suggestions welcome.
=back
=head1 SEE ALSO
L<bogofilter>
=head1 AUTHOR
Tom Anderson <neo+bfproxy@orderamidchaos.com>
=cut
#################################################
############### User Variables #################
#################################################
# please edit according to your setup
# default path
our $path = "/bin:/usr/bin:/usr/local/bin";
# default shell
our $shell = "/bin/sh";
# address-line command string (after the "+", before the "@")
our $command = "bfproxyID";
# maximum number of recursions for train-to-exhaustion
our $rmax = 10;
# delivery username; leave blank unless your MTA is unable
# to deliver to individual virtual host users but instead
# delivers to a single shared virtual host user
our $mailbox = ""; # most setups will not need this
# of course, modify the first line of this file,
# the shebang, to point to your perl interpreter
# do not edit below this line unless you really
# know what you're doing
#################################################
############## Include Libraries ################
#################################################
use IO::Select;
use IPC::Open2;
use Fcntl qw(:flock);
use Benchmark;
#################################################
############## Default Globals ##################
#################################################
$> = $<; # set effective user ID to real UID
$) = $(; # set effective group ID to real GID
# Make %ENV safer
delete @ENV{qw(IFS CDPATH ENV BASH_ENV PATH SHELL)};
# Set the environment explicitely
$ENV{PATH} = $path;
$ENV{SHELL} = $shell;
################################################
##################### Main #####################
################################################
# print help info
if (defined @ARGV && $ARGV[0] =~ /^-+h.*/)
{
my $bfproxy = $1 if $0 =~ /^([\w\/.\-~]*)$/;
system("perldoc $bfproxy"); exit(0);
}
# determine bogofilter settings
our ($robx, $robs, $min_dev, $ham_cutoff, $spam_cutoff) = get_config();
# extract the header
my ($header, $boundary, $from, $options) = extract_header($command, $version);
# run bogofilter on the extracted emails and gather the results
my $results = process_emails($boundary, $from, $options);
# output the new email containing the results
print "$header\n$results\n";
################################################
############## Get Configuration ##############
################################################
sub get_config
{
my ($robx, $robs, $min_dev, $ham_cutoff, $spam_cutoff) = (0,0,0,0,0);
open (CONF, "bogofilter -Q |") or error("warn", "Could not get bogofilter settings");
while (<CONF>)
{
my $line = $_;
$robx = ($1+0) if $line =~ /robx\s*?=\s*?([0-9\.]+?)\s/i;
$robs = ($1+0) if $line =~ /robs\s*?=\s*?([0-9\.]+?)\s/i;
$min_dev = ($1+0) if $line =~ /min_dev\s*?=\s*?([0-9\.]+?)\s/i;
$ham_cutoff = ($1+0) if $line =~ /ham_cutoff\s*?=\s*?([0-9\.]+?)\s/i;
$spam_cutoff = ($1+0) if $line =~ /spam_cutoff\s*?=\s*?([0-9\.]+?)\s/i;
}
close CONF;
return $robx, $robs, $min_dev, $ham_cutoff, $spam_cutoff;
}
################################################
############### Extract Header ################
################################################
sub extract_header
{
my $command = shift;
my $version = shift;
my $header = "";
my $boundary = "";
my $multipart = 0;
my $from = "";
my $to = "";
while (<STDIN>)
{
my $line = $_;
# record the boundary of the multipart/mixed or digest MIME message
$multipart = 1 if $line =~ /Content-Type: multipart\/(?:mixed|digest);/i;
$boundary = $1 if $multipart && $line =~ /boundary="(.*?)"/i;
# replace the from, subject, and content-type lines in the headers
$from = $1 if $line =~ s/^From:\s(.*)$/From: Bfproxy v$version/i;
$line =~ s/^Subject:\s.*$/Subject: training results/i;
$line =~ s/^Content-type:\s.*$/Content-Type: text\/plain/i;
$to = $1 if $line =~ /^To:\s(.*)$/i;
$header .= $line; # if $line =~ /^\w*?:\s|^From\s/i; # unless $line =~ /^X-[^\s]*?:/i;
# we're done with the header when we've found a blank line
last if $line !~ /[^\s]/i;
}
# extract the "user" portion of the "from" address
my $user = $1 if $from =~ /.*?((?:\w|-|\.)+?)\@.*$/i;
# parse any address-line flags
my $options = ($to =~ /.*?$user\+$command\-(.*?)\@.*$/i)? $1 : "";
return $header, $boundary, $from, $options;
}
################################################
############### Process Emails ################
################################################
sub process_emails
{
# 1) Read the email from STDIN
# 2) Discard the enveloping email and process only the "message/rfc822" MIME parts
# representing the forwarded-as-attachment incorrectly classified emails
# 3) Send emails to bogofilter for registration
# 4) Output the results
my $boundary=shift||""; # multipart boundary
my $from = shift || ""; # address of sender
my $options=shift ||""; # address-line flags
my @count = (0,0,0,0); # count of emails (found, processed, lines, words)
my $locked = 0; # lock the boundary at the shallowest level where rfc822 content found
my %email; # hash to temporarily hold a single email
my $found = 0; # indicator of when to record an email
# 0: no rfc822 messages found yet
# 1: we've got a message/rfc822 header
# 2: we're out of the header part
# start timing the process
my $start_time = new Benchmark if $options =~ /b/;
# begin generating output
my $results .= "Bfproxy has processed the following emails with option $options:\n\n";
while (<STDIN>)
{
my $line = $_;
$count[2]++;
if ($found < 2) # try to find any new attached emails
{
# record the boundary of the multipart/mixed or digest MIME message
unless ($locked) { $boundary = $1 if $line =~ /Content-Type: multipart\/(?:mixed|digest); boundary="(.*?)"/i; }
# we've found a new attached email if the content-type is message/rfc822 and we have a boundary
if ($line =~ /Content-Type: message\/rfc822/i && $boundary)
{
$found++;
$locked = 1; # lock the boundary on first attachment
}
# we're ready to start recording if we're out of the attachment header (found a blank line)
$found++ if ($line !~ /[^\s]/i && $found == 1);
}
else # if we're inside an attached email, record it
{
if ($line !~ /\Q$boundary\E/)
{
# strip [SPAM] token from subject
$line =~ s/^Subject: (.*?)\[(?:SPAM|UNSURE)\]/Subject: $1/i;
# escape From lines in body
$line =~ s/^(From) />$1 /i;
# record properties of this email
$email{'spam'} = 'U' if $line =~ /^X-Bogosity: (?:Unsure)/i;
$email{'spam'} = 'S' if $line =~ /^X-Bogosity: (?:Yes|Spam)/i;
$email{'spam'} = 'H' if $line =~ /^X-Bogosity: (?:No|Ham|Clean)/i;
$email{'spamicity'} = $1 if $line =~ /spamicity=((?:\d|\.)*?), /;
$email{'content'} .= "$line" unless $line =~ /^X-[^\s]*?:/i;
$email{'return-path'} = $1 if $line =~ /^Return-Path: <?(.*?)(?=>|\n)/i;
$email{'from'} = $1 if !defined $email{'from'} && $line =~ /^From: (?:.*?<)?(.*?)(?=>|\n)/i;
$email{'subject'} = $1 if $line =~ /^Subject: (.{0, 40})(.*?)/i;
$email{'subject'} .= "..." if $line =~ /^Subject: .{40}.+?/i;
}
else # the email is finished once we've come to a boundary -- send it to bogofilter
{
$count[0]++;
$email{'subject'} = "No Subject" unless $email{'subject'};
$email{'spam'} = 'U' unless defined $email{'spam'};
$email{'spamicity'} = "None" unless $email{'spamicity'};
my $training = train(\%email, $options, 0, \@count);
# per-email output
$results .= "subject: $email{'subject'}\n";
$results .= "original spamicity: $email{'spamicity'}\n" . $training if $options =~ /v/;
# close this email and advance to the next
undef %email;
$found = 0;
}
}
}
$results .= "\n";
$results .= "$count[0] emails found, containing $count[2] lines total.\n";
$results .= "$count[3] words from $count[1] emails were registered.\n\n";
if ($options =~ /b/)
{
# calculate total running time
my $end_time = new Benchmark;
my $td = timediff($end_time, $start_time);
my $cpu = $td->[1]+$td->[2]+$td->[3]+$td->[4];
my $wall = $td->[0];
my $per_line = $cpu / $count[2]; $per_line = int(($per_line*1000) + .5 * ($per_line <=> 0)) / 1000;
my $per_mail = $cpu / $count[0]; $per_mail = int(($per_mail*1000) + .5 * ($per_mail <=> 0)) / 1000;
$results .= "Total running time was $wall wallclock secs, $cpu CPU secs.\n";
$results .= "$per_line CPU secs/line, $per_mail CPU secs/email.\n";
$results .= "Bfproxy required ".$td->[1]." usr + ".$td->[2]." sys = ".($td->[1]+$td->[2])." CPU secs.\n";
$results .= "Bogofilter required ".$td->[3]." usr + ".$td->[4]." sys = ".($td->[3]+$td->[4])." CPU secs.\n\n";
}
if ($options =~ /c/)
{
$results .= "robx=$robx, robs=$robs, min_dev=$min_dev, spam_cutoff=$spam_cutoff, ham_cutoff=$ham_cutoff, rmax=$rmax\n";
}
return $results;
}
################################################
############### Perform Training ###############
################################################
sub train
{
my $email = shift or error("warn", "No email provided");
my $options = shift || "C";
my $r = shift || 0; # recursion counter for exhaustive training
my $count = shift || (0,0,0,0);
my $results = "";
if ($options =~ /[CR]/) # if action is corrective, check the bogosity to decide what to do
{
if ($email->{'spam'} == 'S') # email was classified as SPAM
{
my $flag = ($options =~ /C/)? "Sn" : "n";
$results .= "user classification: ham\ncommand: bogofilter -${\$flag}\n" unless $r;
my ($status, $words, $output) = bogofilter("-${\$flag}evD 2>&1", $email->{'content'});
unless ($status || $r) { $count->[1]++; $count->[3]+=$words; $results .= "words: $words\n"; }
elsif ($status) {$results .= "could not process this email: $status\n";}
}
elsif ($email->{'spam'} == 'H') # email was classified as HAM
{
my $flag = ($options =~ /C/)? "Ns" : "s";
$results .= "user classification: spam\ncommand: bogofilter -${\$flag}\n" unless $r;
my ($status, $words, $output) = bogofilter("-${\$flag}evD 2>&1", $email->{'content'});
unless ($status || $r) { $count->[1]++; $count->[3]+=$words; $results .= "words: $words\n"; }
elsif ($status) {$results .= "could not process this email: $status\n";}
}
elsif ($email->{'spam'} == 'U') # email was classified as UNSURE
{
my $new_options = $options; $new_options =~ s/[CR]//gs;
$results .= train($email, $new_options, $r, $count);
return $results;
}
}
elsif ($options =~ /[NSns]/) # if action is direct, just do it
{
my $flag = $options; $flag =~ s/[^NSns]//gs;
my $class = ($flag =~ /s/)? "spam" : ($flag =~ /n/)? "ham" : "none";
$results .= "user classification: $class\ncommand: bogofilter -${\$flag}\n" unless $r;
my ($status, $words, $output) = bogofilter("-${\$flag}evD 2>&1", $email->{'content'});
unless ($status || $r) { $count->[1]++; $count->[3]+=$words; $results .= "words: $words\n"; }
elsif ($status) { $results .= "could not process this email: $status\n"; }
}
else { $results .= "could not process this email: no option passed in for this condition\n"; }
# check new spamicity
my ($status, $words, $output) = bogofilter("-te 2>&1", $email->{'content'});
unless ($status) { $output =~ s/^.*?((?:\d|\.)*?)$/$1/; $results .= "new spamicity: $output"; }
else {$results .= "could not classify this email: $status\n";}
# train-to-exhaustion
$options =~ s/[^nsx]//gis; # only do registration on subsequent recursions
$results .= train($email, $options, $r+1, $count) if $options =~ /x/ && $r < $rmax && (($options =~ /s/ && $output < $spam_cutoff) || ($options =~ /n/ && $output > $ham_cutoff));
$results .= "\n" unless $r;
return $results;
}
################################################
################ Run Bogofilter ################
################################################
sub bogofilter
{
my $options = shift || "";
my $email = shift || "";
my $status = 0;
my $output = "";
my $words = "";
# for environments that don't split virtual host users into system users
$options = "-d $ENV{HOME}/.bogofilter/$mailbox " . $options if $mailbox;
# trap broken pipes
$SIG{PIPE} = \&sig_trap;
# fork pipe to bogofilter
my $pid = open2(\*R, \*W, "bogofilter $options") or error("die", "Could not open pipe to bogofilter: $!");
# lock filehandle
assert_dominance (\*W, LOCK_EX);
# create filehandle references
my $R = *R{IO}; my $W = *W{IO};
# create select object and add handles
my $sel = IO::Select->new($R, $W) or error("die", "Cannot create IO::Select object: $!");
# set autoflush
select((select(W), $| = 1)[0]);
# select strings
my $ex = join(', ', $sel->has_exception(0));
my $cw = join(', ', $sel->can_write(0));
my $w = "$W";
# send email to bogofilter
unless ($ex =~ /\Q$w\E/) # unless there was an exception on this filehandle
{
if ($cw =~ /\Q$w\E/) # if this filehandle is writeable
{
syswrite W, $email or error("die", "Cannot write to pipe: bogofilter $options: $email: $!");
}
else {error("warn", "Filehandle $w is not in ready list: $cw: $!");}
}
else {error("warn", "Filehandle $w had an exception: $!");}
# close write filehandle to flush the buffer and read from the process outputs
if (close W)
{
$status = $? >> 8; # exit status
sysread R, $output, 32 or error("warn", "Cannot read from pipe: $!");
$words = $1 if $output =~ /^#\s*?(\d*?) words.*/;
}
else {error("warn", "Could not flush output to bogofilter: $!");}
# close read filehandle
unless (close R) {error("warn", "Could not close input from bogofilter: $!");}
# terminate child processes
waitpid $pid, 0;
return $status, $words, $output;
}
################################################
################ Error Handling ################
################################################
sub error
{
my ($action, $msg) = @_;
die $msg if $action eq "die";
warn $msg unless $action eq "die";
# add other actions if you like
}
sub sig_trap
{
my $sig = shift;
my ($action, $more) = ("warn", "");
sig:
{
$action = "warn", last sig if $sig =~ /ALRM/;
$action = "warn", last sig if $sig =~ /PIPE/;
$action = "warn", last sig if $sig =~ /CHLD/;
$action = "die" , last sig if $sig =~ /INT/;
$action = "die" , last sig if $sig =~ /HUP/;
$action = "warn";
}
my $waitedpid = wait;
$more = "; Reaped pid $waitedpid, exited with status " . ($? >> 8) if $waitedpid;
$SIG{$sig} = \&sig_trap;
error ($action, "Trapped signal SIG$sig$more");
}
################################################
################# File Locking #################
################################################
sub assert_dominance
{
my ($handle, $type) = @_;
# assert yourself
unless (flock ($handle, $type))
{
# get impatient
sleep 3;
# reassert yourself or give up
unless (flock ($handle, $type)) { error ("die", "File lock error: $!"); }
}
seek $handle, 0, 2;
}