home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.f-secure.com
/
2014.06.ftp.f-secure.com.tar
/
ftp.f-secure.com
/
support
/
hotfix
/
fsis
/
IS-SpamControl.fsfix
/
iufssc
/
spamscanner.pl
< prev
Wrap
Perl Script
|
2006-11-29
|
27KB
|
1,037 lines
#!/usr/bin/perl
#
# Copyright (C) 2002, 2003, 2004, 2005, 2006 F-Secure Corporation
#
# svn ID below (look for $SVNid)
use strict;
use warnings;
use vars qw($VERSION $Id $spam_scanner_id $fsas_version);
### Files to be shot on sight :-)
# removed on startup end shutdown
my @temporary_files = qw(
rules/bayes_journal
rules/auto-whitelist
);
# removed on startup
my @obsolete_files = qw(
lib/Storable.pm
);
# removed on startup, if empty
my @obsolete_directories = qw(
lib/auto/Storable
);
# created on startup
my @needed_directories = qw(
log
var
);
my $spam_scanner_debug;
# dir name relative to the scanner top directory
my $spam_scanner_msglog_base_dir = "msglog";
my $spam_scanner_msglog_dir;
my $spam_scanner_msglog_limit;
my $spam_scanner_msglog_count = 0;
# stream to use to output SA score report for each message,
# or undef for no report
my $SPAM_SCANNER_REPORT;
sub ignore
{
return;
}
sub gripe
{
my ($level, $msg) = @_;
my $id = '.';
return if ($level == 2); ######## comment out to get level 2
$id = '-' if ($level == 1);
$id = '=' if ($level == 0);
warn "debug: ", scalar (localtime ()), " ", $id x 8,
" [$spam_scanner_id] $msg\n";
}
sub groan {
my ($level, $msg) = @_;
my $id = '.';
#return if ($level == 2); ######## comment out to get level 2
$id = '-' if ($level == 1);
$id = '=' if ($level == 0);
dbg("spamscanner: " . $id x 8 . " $msg");
}
sub reset_automatic_settings {
my ($value) = @_;
debug (1, ">>reset_automatic_settings($value)");
# do any necessary cleanup in the /var directory here
debug (1, "<<reset_automatic_settings()");
}
my @engine_settings = qw(
userid maxsize instances checkifmail reports conflevel bwfile
sender recipients
);
my %trigger = (
reset => \&reset_automatic_settings
);
my %custom_settings = ();
my $custom_settings = "";
sub spam_submit_custom_settings {
my ($settings) = @_;
# TODO: add functionality here
debug (1, "spam_submit_custom_settings($settings)");
# Parse key=value pairs delimited with spaces, tabs, slashes (/) or
# semicolons (;)
# (the string is usually formatted "/key1=value1 /key2=value2")
# Value should be surrounded with double quotes ("), if it contains
# one of the delimiters.
my $delim = '\s\t/;';
# Bletch, workaround to make Emacs colorization happy
while ($settings =~ /\G[$delim]*([^=]+)=(?:"([^"]*)"|([^$delim]*))(?:$|[$delim])/gc) {
my ($key, $value) = ($1, $2);
$value = $3 unless defined $value;
$value = "" unless defined $value;
debug(1, "spam_submit_custom_settings: [$key]=[$value]");
if (my $func = $trigger{$key}) {
debug(1, "calling trigger $func($value) for $key");
next;
}
$custom_settings{$key} = $value;
}
if ($settings =~ m,\G(.+)$,g) {
debug(1, "spam_submit_custom_settings: unmatched stuff='$1'");
}
$custom_settings = "";
while (my ($key, $value) = each %custom_settings) {
# skip settings intended for FSAS.DLL
next if grep {$_ eq $key} @engine_settings;
$custom_settings .= "$key $value\n"
}
debug(1, "spam_submit_custom_settings: \$custom_settings = '$custom_settings'");
return 1;
}
sub spam_scanner_id_gen
{
my $id = rand();
$id =~ s/^0\.//;
return $id;
}
sub module_logger {
my ($self, $module) = @_;
debug(1, "trying to load module '$module'");
return undef;
}
sub failure_logger {
my ($self, $module) = @_;
my @callers = ();
my $depth = 1;
while (1) {
my ($package, $filename, $line, $subroutine) = caller($depth++);
last unless defined $subroutine;
push @callers, $subroutine;
}
#my $callers = join("/", @callers);
my $callers = join("\n| ", @callers);
#
# TODO: filter out known offenders based on $callers stack
#
my @ignore = qw(
Storable.pm
Mail/SpamAssassin/NoMailAudit.pm
Mail/SpamAssassin/TextCat.pm
Net/DNS/RR/SIG.pm
Net/DNS/SEC.pm
Socket6.pm
IO/Socket/INET6.pm
Sys/Hostname/Long.pm
auto/Mail/SpamAssassin/HTML/DESTROY.al
);
if (grep { $module eq $_ } @ignore) {
debug(1, "IGNORING LOAD FAILURE OF '$module'");
return;
}
if ($module =~ /autosplit\.ix$/) {
debug(1, "IGNORING autosplit.ix probe: '$module'");
return;
}
debug(1, "FAILED TO LOAD MODULE '$module' in\n| $callers");
return undef;
}
sub dirsep
{
return '\\' if ($^O =~ /win32/i);
return '/';
}
# get diagnostic setting from an environment variable or a file
sub get_diag_setting {
my ($setting) = @_;
return $ENV{$setting} if defined $ENV{$setting};
# TODO: using slash (/), not dirsep
my $cfg_dir = $ENV{FS_SA_CFG_DIR} || "c:/";
my $filename = sprintf "%s.cfg", join(dirsep(), $cfg_dir, lc($setting));
open(my $fh, '<', $filename) or return undef;
return scalar(<$fh>);
}
BEGIN
{
######## TODO: upgrade when we release a new version
$VERSION = '3.131';
my $SVNid = qw($Id: spamscanner.pl 4149 2006-11-15 10:24:56Z eriker $)[2];
$Id = "svn$SVNid";
$spam_scanner_debug = "";
$spam_scanner_id = spam_scanner_id_gen();
# fix around wrong DLL call convention
@INC = map { split (";", $_) } @INC;
# add path/to/db to parallel any path/to/lib, all in front of old @INC
# (so, uh, if map returns nothing, discard that, with grep)
unshift @INC, grep { $_ } map { m%(^|.*[/\\])lib% and "${1}dlib" } @INC;
if (my $log = get_diag_setting("FS_SA_DEBUG")) {
$spam_scanner_debug = "all";
$spam_scanner_debug = $1 if $log =~ s/^(-?\w+(?:,-?\w+)*);//;
# Heuristic for what "looks like" an IP:port designator
if ($log =~ m/^(\d+\.\d+\.\d+\.\d+):(\d+)$/)
{
use Socket;
my ($ip, $port) = ($1, $2);
my ($iaddr, $paddr, $proto);
open (my $err, ">&STDERR");
unless ($iaddr = inet_aton ($ip) and
$paddr = sockaddr_in ($port, $iaddr) and
$proto = getprotobyname('tcp') and
socket (STDERR, PF_INET, SOCK_STREAM, $proto) and
connect (STDERR, $paddr))
{
close (STDERR);
open (STDERR, ">&$err");
warn "$0: You probably won't see this, but $!";
}
close ($err);
}
######## FIXME: vague heuristic for what "looks like" a file name
# If the value contains any of `/', `\', or `.', try it as a file
elsif ($log =~ qr'[\\/.]')
{
open (STDERR, '>>', $log);
}
# Make STDERR and STDOUT unbuffered (the latter probably unnecessary)
select (STDERR); $| = 1;
select (STDOUT); $| = 1;
eval {
require Mail::SpamAssassin::Logger;
import Mail::SpamAssassin::Logger;
Mail::SpamAssassin::Logger::add_facilities($spam_scanner_debug);
};
*debug = $@ ? *gripe : *groan;
debug (0, "F-Secure SpamAssassin v$::VERSION/$Id starting up");
#unshift @INC, \&module_logger;
push @INC, \&failure_logger;
}
else
{
*debug = *ignore;
}
debug (2, ">> BEGIN (actually since some time already)");
if (my $log = get_diag_setting("FS_SA_REPORT")) {
######## FIXME: vague heuristic for what "looks like" a file name
# If the value contains any of `/', `\', or `.', try it as a file
unless ($log =~ qr'[\\/.]' && open ($SPAM_SCANNER_REPORT, '>>', $log))
{
if (open ($SPAM_SCANNER_REPORT, ">&STDOUT")) {
# make the stream unbuffered so that it interleaves better with
# other STDOUT output.
# It would be cleaner to say
# use IO::Handle;$SPAM_SCANNER_REPORT->autoflush(1);
# but IO::Handle might bring some bloat...
my $oldfh = select ($SPAM_SCANNER_REPORT);
$| = 1;
select($oldfh);
} else {
undef $SPAM_SCANNER_REPORT;
}
}
}
# Print a stack trace when we get an error
$SIG{__DIE__} = sub {
# react only to runtime errors
return unless defined $^S && !$^S;
warn "\nError:\n\t" . $_[0];
require Carp if defined $^S;
# skip our main::__ANON__ routine from the trace
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
Carp::confess("Stack trace:\n") if defined &Carp::confess;
die "Something wrong, but could not load Carp to give backtrace...\n" .
"To see backtrace try starting Perl with -MCarp switch";
};
# Bogus declarations of legacy packages to make downgrade work (#35947)
package bogus;
use strict;
use warnings;
for my $lib (qw(Storable
Mail::SpamAssassin::NoMailAudit
Mail::SpamAssassin::Logger
Mail::SpamAssassin::TextCat))
{
eval "require $lib;";
if ($@)
{
my $path = $lib;
$path =~ s%::%/%g;
if ($@ !~ m%^Can't locate $path.pm in \@INC %)
{
main::debug (1, "unexpected exception: $@");
}
main::debug (1, "declaring bogus $lib");
$::INC{"$path.pm"} = "bogus, my friend";
}
}
package main;
debug (2, "<< BEGIN");
}
sub spam_scanner_remove_hook
{
my ($dir, $files, $directories) = @_;
debug (2, ">>spam_scanner_remove_hook($dir)");
# Hook to remove obsolete files
for my $file (@$files) {
my $path = join(dirsep(), $dir, $file);
debug (2, "spam_scanner_remove_hook: considering '$path'");
next unless -w $path;
debug (1, "spam_scanner_remove_hook: unlinking $path");
unlink $path or debug (1, "Could not unlink $path: $!");
}
# Hook to remove obsolete directories
for my $file (@$directories) {
my $path = join(dirsep(), $dir, $file);
debug (2, "spam_scanner_remove_hook: considering directory '$path'");
next unless -d $path;
debug (1, "spam_scanner_remove_hook: removing directory '$path'");
rmdir $path or debug (1, "Could not remove directory '$path': $!");
}
debug (2, "<<spam_scanner_remove_hook()");
}
my $spam_scanner_directory = undef;
END
{
spam_scanner_remove_hook($spam_scanner_directory, \@temporary_files, [])
if defined $spam_scanner_directory;
}
use Mail::SpamAssassin 2.6301; # really 2.64 (and now 3.1.3) -- see bug 34781
my @mapping = ();
my %cached = (); # Cache per-user configurations
my $cached;
# Return this api version
sub spam_scan_api_version { return 100; }
sub mkdir_path {
my ($base, $path) = @_;
my @parts = split(/\//, $path);
$path = $base;
for my $part (@parts) {
$path = join(dirsep(), $path, $part);
unless (mkdir $path) {
debug (1, "Could not create directory '$path': $!");
return 0;
}
}
return 1;
}
sub create_directories {
my ($base, @dirs) = @_;
for my $file (@dirs) {
my $path = join(dirsep(), $base, $file);
debug (2, "considering creating directory '$path'");
next if -d $path;
debug (1, "creating directory '$path'");
mkdir_path($base, $file) or
debug (1, "Could not create directory '$path': $!");
}
}
sub init_logging {
my ($dir) = @_;
my $dirsep = dirsep();
my $log_path = join($dirsep, $dir, "log/fs_sa_log.txt");
my $log_path2 = join($dirsep, $dir, "log/fs_sa_log-old.txt");
my $max_log_file_size = 10000;
if ((-s $log_path || 0 ) > $max_log_file_size) {
close(STDERR);
rename $log_path, $log_path2 or print "rename failed: $!\n";
}
open(STDERR, '>>', $log_path);
select (STDERR); $| = 1;
select (STDOUT); $| = 1;
}
sub get_mapping {
my ($mappings) = @_;
die "Could not open $mappings: $!\n"
unless open (my $MAPPINGS, '<', $mappings);
my @mapping = ();
while (<$MAPPINGS>)
{
# Skip comments && empty lines
next if m/^\s*(\#.*)?\r?$/;
if (m/^\s*(\d+)\s+(-?((\.\d+)|\d+(\.\d+)?))\s*\r?$/)
{
my ($from, $to) = ($1, $2);
die "$mappings:$.:Target rating $from not between 1 and 9: $_"
unless ($from >= 1 && $from <= 9);
$mapping[$from] = $to;
}
else
{
die "$mappings:$.:Invalid input $_";
}
}
close $MAPPINGS;
# Some final sanity checking of mappings
######## TODO: interpolate missing limits geometrically instead of gripe?
for (my $i = 1; $i <= 9; ++$i)
{
die "$mappings: Confidence level rating $_ remains undefined"
unless (defined $mapping[$i]);
}
return @mapping;
}
sub init_msglog {
my ($dir) = @_;
my $dirsep = dirsep();
return unless my $msglog_setting = get_diag_setting("FS_SA_MSGLOG");
# expand the relative directory name
$spam_scanner_msglog_dir =
join($dirsep, $dir, $spam_scanner_msglog_base_dir);
unless (-d $spam_scanner_msglog_dir) {
mkdir($spam_scanner_msglog_dir) or
debug(1, "msglog: failed to create directory '$spam_scanner_msglog_dir': $!");
}
return unless -d $spam_scanner_msglog_dir;
$spam_scanner_msglog_limit = $msglog_setting + 0;
debug(1, "msglog: requested to log $spam_scanner_msglog_limit messages");
# the files are logged with names of the form "CLR%d-msg%04d.txt"
# count, if there are any matching ones already from a
# previous invocation and continue from there
my @msg_names = ();
if (opendir(my $dir, $spam_scanner_msglog_dir)) {
@msg_names = map {
/^CLR\d+-msg(\d{4})\.txt$/i ? $1 : ()
} readdir($dir);
closedir($dir);
}
my $count = @msg_names;
my $last = $count ? (sort(@msg_names))[-1] + 0 : 0;
debug(1, "msglog: found $count messages, highest numbered '$last'");
$spam_scanner_msglog_count = $count + $last;
$spam_scanner_msglog_limit += $last;
debug(1, "msglog: logging messages from $spam_scanner_msglog_count to $spam_scanner_msglog_limit");
# copy the configuration file to the logging directory first
my $cfg = join($dirsep, $dir, "fssc.cfg");
require File::Copy;
File::Copy::copy($cfg, $spam_scanner_msglog_dir) or
debug(1, "msglog: failed to copy '$cfg'");
}
sub is_validating {
my ($top_dir) = @_;
# normally the Spam Control directory contains this, but the
# database update directory not
return ! -e join(dirsep(), $top_dir, "fsas.dll");
}
sub spam_scan_init {
my ($rules, $fsas_version) = @_;
# store globally as an integer "vector"
$::fsas_version = defined $fsas_version ?
pack("U*", grep { s/^(\d+).*$/$1/ } split /\./, $fsas_version) : 0.0.0;
debug (2, ">> spam_scan_init(" . join(", ", grep defined, @_) . ")");
my $dirsep = dirsep();
debug (1, sprintf "spam_scan_init (%s/%s [%s], engine %s)",
$Mail::SpamAssassin::VERSION,
$VERSION,
$Id,
$fsas_version || "unknown"
);
$spam_scanner_directory = join($dirsep, $rules, "..");
spam_scanner_remove_hook($spam_scanner_directory, [@temporary_files, @obsolete_files], \@obsolete_directories);
my $is_validating = is_validating($spam_scanner_directory);
debug(1, "preparing for " .
($is_validating ? "database validation" : "spam scanning")
);
unless ($is_validating) {
create_directories($spam_scanner_directory, @needed_directories);
init_logging($spam_scanner_directory) unless $spam_scanner_debug;
}
my ($mappings) = join ($dirsep, $rules, "mappings.txt");
@mapping = get_mapping($mappings);
my $cfg = join ($dirsep, $rules, "..", "site");
$::sa = new Mail::SpamAssassin({
rules_filename => $rules,
site_rules_filename => $cfg,
userstate_dir => $rules,
local_tests_only => 0, # 1,
dont_copy_prefs => 1,
debug => $spam_scanner_debug,
});
# FIXME: Not valid anymore?
if ($spam_scanner_debug)
{
$Mail::SpamAssassin::DEBUG->{rulesrun} = 127;
$Mail::SpamAssassin::DEBUG->{rbl} = -1;
$::sa->{save_pattern_hits} = 1;
}
$::sa->compile_now(0);
# Cache global settings
eval {
$::sa->copy_config(undef, \%{$cached{''}}) or
debug (1, "failed to copy_config");
};
debug (1, "could not find copy_config: $@") if ($@);
$cached = '';
init_msglog($spam_scanner_directory) unless $is_validating;
debug (2, "<<spam_scan_init()");
}
sub spam_scan_version {
return ($::sa->Version . "+fs$VERSION");
}
sub spam_scan_lint_rules {
######## TODO: maybe remove this braindeath altogether one day
debug (1, "spam_scan_lint_rules bypassed (bug #34781)");
return 0;
#return &spam_scan_lint_really();
}
sub open_or_debug {
my $ok = open($_[0], $_[1], $_[2]);
debug(1, "could not open file '$_[2]': $!")
unless $ok;
return $ok;
}
sub set_sa_config {
my ($config) = @_;
if ($config eq $cached)
{
# no action
}
elsif ($cached{$config})
{
debug (1, "set_sa_config: retreiving cached config");
$::sa->copy_config($cached{$config}, undef) or
die "copy_config failed";
$cached = $config;
}
else
{
debug (1, "set_sa_config: no cached config");
# Massage $config into the format it really needs to be in.
# That is, any F-specific directives are either handled and removed,
# or transformed into the corresponding generic SA directives.
my $rawconfig = $config;
my $username;
my %directives = (
username => sub { $username = shift; },
);
my $directives = join ('|', keys %directives);
######## FIXME: ugly spaces required in most values in %subst
my %subst = (
blacklist => 'blacklist_from ',
whitelist => 'whitelist_from ',
mydomain => 'whitelist_from *@',
# blacklist_to => (identity),
# whitelist_to => (identity),
);
my $subst = join ('|', keys %subst);
my @addr_options = qw(
whitelist_from unwhitelist_from whitelist_from_rcvd
def_whitelist_from_rcvd whitelist_allows_relays
unwhitelist_from_rcvd blacklist_from unblacklist_from
whitelist_to more_spam_to all_spam_to blacklist_to
);
my $addr_options = join('|', @addr_options);
$config =~ s/^\s*($directives)\s(.*)\r?/&{$directives{$1}}($2)/mge;
$config =~ s/^\s*($subst)\s+(.*)\r?$/$subst{$1}$2/mg;
$config =~ s/^\s*($addr_options)\s+<(\S+)>(\s|$)/$1 $2$3/mg;
# Augment $::sa->{conf} with additional configuration data in $config
# restore the common configuration
$::sa->copy_config($cached{''}, undef) or
die "copy_config failed";
$cached = '';
# Go and parse the config!
$::sa->{conf}->{main} = $::sa;
$::sa->{conf}->parse_scores_only ($config);
$::sa->{conf}->finish_parsing ();
delete $::sa->{conf}->{main}; # to allow future GC'ing
$::sa->signal_user_changed ({ username => $username });
# and cache the newly parsed
$::sa->copy_config(undef, \%{$cached{$rawconfig}}) or
die "copy_config failed";
$cached = $rawconfig;
}
}
sub spam_scan_message {
debug (2, ">>spam_scan_message");
my ($c, @data) = @_;
my ($config, $conf);
if (ref $c eq "HASH")
{
$config = $c->{bwlist} || '';
$conf = $c->{settings} || { };
}
else
{
$conf = { };
$config = $c;
}
$config = $custom_settings . $config if $custom_settings;
# Default is to use envelope sender and recipient, if available.
my $use_envelope = 0;
if (defined $conf->{sender} ||
defined $conf->{recipients})
{
if (defined $conf->{sender} &&
defined $conf->{recipients})
{
$use_envelope = 1;
debug (2, "Envelope sender and recipients supplied: " .
"/sender:" . $conf->{sender} .
"; /recipients:" . $conf->{recipients});
}
else
{
my ($supplied, $missing) =
(defined $conf->{sender}
? ("/sender:" . $conf->{sender}, "/recipients")
: ("/recipients:" . $conf->{recipients}, "/sender") );
warn "$supplied supplied but $missing missing\n";
debug (2, "$supplied supplied but $missing missing");
}
}
else
{
debug (1, "No envelope information supplied; using headers");
}
if ($use_envelope)
{
# Zapping the scores for these rules mean they will not show in hits,
# but we are still able to check if an address is black/whitelisted
$config .= "
score USER_IN_DEF_WHITELIST 0
score USER_IN_DEF_BLACKLIST 0
score USER_IN_WHITELIST_TO 0
score USER_IN_BLACKLIST_TO 0
score USER_IN_WHITELIST 0
score USER_IN_BLACKLIST 0
";
}
my $spam_scanner_msglog_on = 0;
if (
defined $spam_scanner_msglog_limit &&
$spam_scanner_msglog_count < $spam_scanner_msglog_limit
) {
$spam_scanner_msglog_on = 1;
$spam_scanner_msglog_count++;
}
if (defined $SPAM_SCANNER_REPORT || $spam_scanner_msglog_on) {
print $SPAM_SCANNER_REPORT "file: '$c->{filename}'\n"
if defined $SPAM_SCANNER_REPORT && ref $c && defined $c->{filename};
$config .= "
clear_report_template
report
report report _REPORT_
report total _SCORE_/_REQD_
";
}
### TODO: _REQD_ doesn't seem to match what fsas.dll has as a limit
### (at least when fpirun calls it), take it out? Or set it somehow?
my $hits = "N/A";
set_sa_config($config);
my $confidence_level_rating;
my $report;
# Default is to do full test, but bypass if we get black/white envelope
my $full_test = 1;
my $full_report;
if ($use_envelope)
{
my $dummy = Mail::SpamAssassin::PerMsgStatus->new($::sa, undef);
@{$dummy->{all_from_addrs}} = map { s/^<(.*)>$/$1/;$_ } split(
";", $conf->{sender});
@{$dummy->{all_to_addrs}} = map { s/^<(.*)>$/$1/;$_ } split(
";", $conf->{recipients});
######## FIXME: rules/97_fs-whitelist-from.cf should work with envelopes too
######## TODO: should we copy over def_whitelist_from etc?
# for my $key (qw( whitelist_from whitelist_to
# whitelist_from_rcvd
# def_whitelist_from
# def_whitelist_from_rcvd
# blacklist_from blacklist_to
# more_spam_to all_spam_to))
# {
# $dummy->{conf}->{$key} = $::sa->{conf}->{$key};
#warn "\$dummy->{conf}->{$key} =\n"; map { warn " '$_' => '", $dummy->{conf}->{$_} || "", "'\n" } keys %{$dummy->{conf}->{$key}};
# }
if ($dummy->check_from_in_whitelist
|| $dummy->check_to_in_whitelist)
{
$confidence_level_rating = 0;
$report = "WHITELISTED";
$full_test = 0;
}
elsif ($dummy->check_from_in_blacklist
|| $dummy->check_to_in_blacklist)
{
$confidence_level_rating = 10;
$report = "BLACKLISTED";
$full_test = 0;
}
}
my %classifications = ( );
if ($full_test)
{
# IGK/FSAV4IMTTLATIMLA >= 6.40 adds spurious Received: header and
# final trailing CRLF -- trim them if present (CTS #49919)
######## TODO: make conditional on engine.cf too?
my $i = 0;
if ($data[$i++] =~ m/\AReceived: from .*\(.* \[[.0-9]+\]\)\r\n\Z/
&& ($data[$i] =~ m/\A by .* \(\[[.0-9]+\]:\d+\) \(.*\)\r\n\Z/
&& ++$i || '# this will be missing in "anonymous mode"')
&& $data[$i++] =~ m/\A[ ]with[ ].*;[ ] # SMTP or ESMTP
([A-Z][a-z]{2},[ ] # weekday,
[ 0-3][0-9][ ][A-Z][a-z]{2}[ ][12]\d{3}[ ] # nn Mon yyyy
[012]\d:\d{2}:\d{2}[ ] # hh:mm:ss
[-+ ]?\d{4}) # -TZ00
\r\n\Z/x
&& (my $datestamp = $1)
&& $data[$i] =~ m/\A \(envelope-from .*\)\r\n\Z/
&& $data[-1] eq "\r\n")
{
my $age = Mail::SpamAssassin::Util::parse_rfc822_date ($datestamp);
my $t;
if (! defined $age)
{
debug (1, "Invalid date in IGK/FSAV4IM Received: header");
}
elsif ($age > ($t = time))
{
debug (1, "IGK/FSAV4IM Received: header dated in the future");
}
elsif ($age < $t-300) ######## FIXME: higher age limit?
{
debug (1, "IGK/FSAV4IM Received: header older than 5 minutes");
}
else
{
debug (1,
"Trimming IGK/FSAV4IM >= 6.40 Received: and final CRLF");
splice @data, 0, $i;
splice @data, -1, 1;
}
}
# If mail seems to contain \r?\r\n's throughout, attempt to fix
for my $regex (qr(\r\r\n\Z), qr(\r\n\Z))
{
my @dataclone;
foreach (@data)
{
my $datum = $_;
unless ($datum =~ s/$regex/\n/)
{
@dataclone = ();
last;
}
push @dataclone, $datum;
}
if (@dataclone)
{
debug (1, "spam_scan_message: $regex line endings normalized");
@data = @dataclone;
last;
}
}
# Check mail with current settings
my $mail = $::sa->parse(\@data);
my $status = $::sa->check ($mail); # The check is in the mail
# If white/blacklisted, just return ({WHITE,BLACK}LISTED, {0,10})
######## TODO: is there a less resource-intensive way to do this?
# One gets the feeling that the check($mail) above does lots of work
# Plan: factor out and use only pertinent parts of SpamAssassin->check
######## FIXME: perhaps also check other PerMsgStatus->..._whitelist
if (! $use_envelope &&
($status->check_from_in_whitelist
|| $status->check_to_in_whitelist))
{
$confidence_level_rating = 0;
$report = "WHITELISTED";
}
elsif (! $use_envelope &&
($status->check_from_in_blacklist
|| $status->check_to_in_blacklist))
{
$confidence_level_rating = 10;
$report = "BLACKLISTED";
}
else
{
$hits = $status->get_hits();
$confidence_level_rating = get_clr($hits);
$report = $status->get_names_of_tests_hit();
}
if (defined $SPAM_SCANNER_REPORT || $spam_scanner_msglog_on)
{
$full_report = $status->get_report();
}
%classifications = %{$status->{fs_phishblplugin} || {}};
$status->finish();
$mail->finish();
}
printf $SPAM_SCANNER_REPORT "%sCLR %s\n",
$full_report, $confidence_level_rating
if (defined $SPAM_SCANNER_REPORT);
if ($spam_scanner_msglog_on) {
if (open_or_debug(my $fh, '>', sprintf(
"$spam_scanner_msglog_dir/CLR%d-msg%04d.txt",
$confidence_level_rating,
$spam_scanner_msglog_count
))) {
print $fh $config;
print $fh "-" x 80, "\n";
printf $fh "%sCLR %s\nreport %s\nhits %s\n",
$full_report,
$confidence_level_rating,
$report, $hits;
print $fh "=" x 80,"\n";
print $fh @data;
close($fh);
}
}
# report the traditional spam score also as a "spam class" score
$classifications{spam} = $confidence_level_rating;
# convert any heuristic phishing rule matches to "phishing class"
# score of 9, unless specific phishing score is already higher,
# or explicitly whitelisted (phishing score zero).
$classifications{phishing} = 9 if
$report =~ /PHISH/ && (
!exists $classifications{phishing} || (
$classifications{phishing} < 9 &&
$classifications{phishing} != 0
)
);
# add any specific classifications as pseudo rules of the form
# FS_CLASS_<class>_<value> into the matched rule names list
$report .= ($report ? "," : "") . join(",",
map { "FS_CLASS_\U$_\E_$classifications{$_}" }
keys %classifications
);
debug (0, sprintf "spam_scan_message result: CLR = %s (%s; %s; %s)",
$confidence_level_rating,
$hits,
$report ? "$report" : '',
join(", ", map { "$_ = $classifications{$_}" } keys %classifications)
);
if ($::fsas_version lt 1.22.0) {
# for old clients that only know about spam scores,
# convert any phishing score into a spam score, unless
# the score is already higher, or the message whitelisted.
# this way any phishing messages get moved at least to
# the junk mail folder.
if (
$confidence_level_rating > 0 &&
exists $classifications{phishing} &&
$confidence_level_rating < $classifications{phishing})
{
$confidence_level_rating = $classifications{phishing};
}
debug (2, "<<spam_scan_message (old engine, CLR = $confidence_level_rating)");
return ($report, $confidence_level_rating);
}
debug (2, "<<spam_scan_message");
return ($report, $confidence_level_rating, \%classifications);
}
sub get_clr
{
######## FIXME: do a binary search here instead
my ($score) = @_;
my $i;
for ($i = 9; $i >= 1; --$i)
{
last if ($mapping[$i] <= $score);
}
return $i;
}
sub spam_scan_lint_really
{
debug (1, "lint");
#$::sa->{conf} = $cached{''}->copy() if (defined $cached{''});
return ($::sa->lint_rules_really);
}
1;