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   
Perl Script  |  2006-11-29  |  27KB  |  1,037 lines
  1. #!/usr/bin/perl
  2. #
  3. # Copyright (C) 2002, 2003, 2004, 2005, 2006 F-Secure Corporation
  4. #
  5. # svn ID below (look for $SVNid)
  6.  
  7. use strict;
  8. use warnings;
  9.  
  10. use vars qw($VERSION $Id $spam_scanner_id $fsas_version);
  11.  
  12. ### Files to be shot on sight :-)
  13.  
  14. # removed on startup end shutdown
  15. my @temporary_files = qw(
  16.     rules/bayes_journal
  17.     rules/auto-whitelist
  18. );
  19.  
  20. # removed on startup
  21. my @obsolete_files = qw(
  22.     lib/Storable.pm
  23. );
  24.  
  25. # removed on startup, if empty
  26. my @obsolete_directories = qw(
  27.     lib/auto/Storable
  28. );
  29.  
  30. # created on startup
  31. my @needed_directories = qw(
  32.     log
  33.     var
  34. );
  35.  
  36. my $spam_scanner_debug;
  37.  
  38. # dir name relative to the scanner top directory
  39. my $spam_scanner_msglog_base_dir = "msglog";
  40. my $spam_scanner_msglog_dir;
  41. my $spam_scanner_msglog_limit;
  42. my $spam_scanner_msglog_count = 0;
  43.  
  44. # stream to use to output SA score report for each message,
  45. # or undef for no report
  46. my $SPAM_SCANNER_REPORT;
  47.  
  48. sub ignore
  49. {
  50.     return;
  51. }
  52.  
  53. sub gripe
  54. {
  55.     my ($level, $msg) = @_;
  56.     my $id = '.';
  57.     return if ($level == 2);        ######## comment out to get level 2
  58.     $id = '-' if ($level == 1);
  59.     $id = '=' if ($level == 0);
  60.     warn "debug: ", scalar (localtime ()), " ", $id x 8,
  61.     " [$spam_scanner_id] $msg\n";
  62. }
  63.  
  64. sub groan {
  65.     my ($level, $msg) = @_;
  66.     my $id = '.';
  67.     #return if ($level == 2);        ######## comment out to get level 2
  68.     $id = '-' if ($level == 1);
  69.     $id = '=' if ($level == 0);
  70.     dbg("spamscanner: " . $id x 8 . " $msg");
  71. }
  72.  
  73. sub reset_automatic_settings {
  74.     my ($value) = @_;
  75.     debug (1, ">>reset_automatic_settings($value)");
  76.     # do any necessary cleanup in the /var directory here
  77.     debug (1, "<<reset_automatic_settings()");
  78. }
  79.  
  80. my @engine_settings = qw(
  81.     userid maxsize instances checkifmail reports conflevel bwfile
  82.     sender recipients
  83. );
  84.  
  85. my %trigger = (
  86.     reset => \&reset_automatic_settings
  87. );
  88.  
  89. my %custom_settings = ();
  90. my $custom_settings = "";
  91. sub spam_submit_custom_settings {
  92.     my ($settings) = @_;
  93.  
  94.     # TODO: add functionality here
  95.     debug (1, "spam_submit_custom_settings($settings)");
  96.  
  97.     # Parse key=value pairs delimited with spaces, tabs, slashes (/) or
  98.     # semicolons (;)
  99.     # (the string is usually formatted "/key1=value1 /key2=value2")
  100.     # Value should be surrounded with double quotes ("), if it contains
  101.     # one of the delimiters.
  102.     my $delim = '\s\t/;';
  103.     # Bletch, workaround to make Emacs colorization happy
  104.     while ($settings =~ /\G[$delim]*([^=]+)=(?:"([^"]*)"|([^$delim]*))(?:$|[$delim])/gc) {
  105.     my ($key, $value) = ($1, $2);
  106.     $value = $3 unless defined $value;
  107.     $value = "" unless defined $value;
  108.  
  109.     debug(1, "spam_submit_custom_settings: [$key]=[$value]");
  110.     if (my $func = $trigger{$key}) {
  111.         debug(1, "calling trigger $func($value) for $key");
  112.         next;    
  113.     }
  114.  
  115.     $custom_settings{$key} = $value;
  116.     }
  117.  
  118.     if ($settings =~ m,\G(.+)$,g) {
  119.     debug(1, "spam_submit_custom_settings: unmatched stuff='$1'");
  120.     }
  121.  
  122.     $custom_settings = "";
  123.     while (my ($key, $value) = each %custom_settings) {
  124.     # skip settings intended for FSAS.DLL
  125.     next if grep {$_ eq $key} @engine_settings;
  126.  
  127.     $custom_settings .= "$key $value\n"
  128.     }
  129.  
  130.     debug(1, "spam_submit_custom_settings: \$custom_settings = '$custom_settings'");
  131.  
  132.     return 1;
  133. }
  134.  
  135. sub spam_scanner_id_gen
  136. {
  137.     my $id = rand();
  138.     $id =~ s/^0\.//;
  139.     return $id;
  140. }
  141.  
  142. sub module_logger {
  143.     my ($self, $module) = @_;
  144.     debug(1, "trying to load module '$module'");
  145.     return undef;
  146. }
  147.  
  148. sub failure_logger {
  149.     my ($self, $module) = @_;
  150.  
  151.     my @callers = ();
  152.     my $depth = 1;
  153.     while (1) {
  154.     my ($package, $filename, $line, $subroutine) = caller($depth++);
  155.     last unless defined $subroutine;
  156.     push @callers, $subroutine;
  157.     }
  158.  
  159.     #my $callers = join("/", @callers);
  160.     my $callers = join("\n|   ", @callers);
  161.  
  162.     #
  163.     # TODO: filter out known offenders based on $callers stack
  164.     #
  165.     my @ignore = qw(
  166.     Storable.pm
  167.     Mail/SpamAssassin/NoMailAudit.pm
  168.     Mail/SpamAssassin/TextCat.pm
  169.  
  170.     Net/DNS/RR/SIG.pm
  171.     Net/DNS/SEC.pm
  172.     Socket6.pm
  173.     IO/Socket/INET6.pm
  174.     Sys/Hostname/Long.pm
  175.  
  176.     auto/Mail/SpamAssassin/HTML/DESTROY.al
  177.     );
  178.  
  179.     if (grep { $module eq $_ } @ignore) {
  180.     debug(1, "IGNORING LOAD FAILURE OF '$module'");
  181.     return;
  182.     }
  183.  
  184.     if ($module =~ /autosplit\.ix$/) {
  185.     debug(1, "IGNORING autosplit.ix probe: '$module'");
  186.     return;
  187.     }
  188.  
  189.     debug(1, "FAILED TO LOAD MODULE '$module' in\n|   $callers");
  190.     return undef;
  191. }
  192.  
  193. sub dirsep
  194. {
  195.     return '\\' if ($^O =~ /win32/i);
  196.     return '/';
  197. }
  198.  
  199. # get diagnostic setting from an environment variable or a file
  200. sub get_diag_setting {
  201.     my ($setting) = @_;
  202.  
  203.     return $ENV{$setting} if defined $ENV{$setting};
  204.  
  205.     # TODO: using slash (/), not dirsep
  206.     my $cfg_dir = $ENV{FS_SA_CFG_DIR} || "c:/";
  207.  
  208.     my $filename = sprintf "%s.cfg", join(dirsep(), $cfg_dir, lc($setting));
  209.  
  210.     open(my $fh, '<', $filename) or return undef;
  211.  
  212.     return scalar(<$fh>);
  213. }
  214.  
  215. BEGIN
  216. {
  217.     ######## TODO: upgrade when we release a new version
  218.     $VERSION = '3.131';
  219.     my $SVNid = qw($Id: spamscanner.pl 4149 2006-11-15 10:24:56Z eriker $)[2];
  220.     $Id = "svn$SVNid";
  221.  
  222.     $spam_scanner_debug = "";
  223.     $spam_scanner_id = spam_scanner_id_gen();
  224.  
  225.     # fix around wrong DLL call convention
  226.     @INC = map { split (";", $_) } @INC;
  227.  
  228.     # add path/to/db to parallel any path/to/lib, all in front of old @INC
  229.     # (so, uh, if map returns nothing, discard that, with grep)
  230.     unshift @INC, grep { $_ } map { m%(^|.*[/\\])lib% and "${1}dlib" } @INC;
  231.  
  232.     if (my $log = get_diag_setting("FS_SA_DEBUG")) {
  233.     $spam_scanner_debug = "all";
  234.     $spam_scanner_debug = $1 if $log =~ s/^(-?\w+(?:,-?\w+)*);//;
  235.  
  236.     # Heuristic for what "looks like" an IP:port designator
  237.     if ($log =~ m/^(\d+\.\d+\.\d+\.\d+):(\d+)$/)
  238.     {
  239.         use Socket;
  240.  
  241.         my ($ip, $port) = ($1, $2);
  242.         my ($iaddr, $paddr, $proto);
  243.         open (my $err, ">&STDERR");
  244.         unless ($iaddr = inet_aton ($ip) and
  245.         $paddr = sockaddr_in ($port, $iaddr) and
  246.         $proto = getprotobyname('tcp') and
  247.         socket (STDERR, PF_INET, SOCK_STREAM, $proto) and
  248.         connect (STDERR, $paddr))
  249.         {        
  250.         close (STDERR);
  251.         open (STDERR, ">&$err");
  252.         warn "$0: You probably won't see this, but $!";
  253.         }
  254.         close ($err);
  255.     }
  256.     ######## FIXME: vague heuristic for what "looks like" a file name
  257.     # If the value contains any of `/', `\', or `.', try it as a file
  258.     elsif ($log =~ qr'[\\/.]')
  259.     {
  260.         open (STDERR, '>>', $log);
  261.     }
  262.  
  263.     # Make STDERR and STDOUT unbuffered (the latter probably unnecessary)
  264.     select (STDERR); $| = 1;
  265.     select (STDOUT); $| = 1;
  266.  
  267.     eval {
  268.         require Mail::SpamAssassin::Logger;
  269.         import Mail::SpamAssassin::Logger;
  270.         Mail::SpamAssassin::Logger::add_facilities($spam_scanner_debug);
  271.     };
  272.     *debug = $@ ? *gripe : *groan;
  273.  
  274.     debug (0, "F-Secure SpamAssassin v$::VERSION/$Id starting up");
  275.  
  276.     #unshift @INC, \&module_logger;
  277.     push @INC, \&failure_logger;
  278.     }
  279.     else
  280.     {
  281.     *debug = *ignore;
  282.     }
  283.  
  284.     debug (2, ">> BEGIN (actually since some time already)");
  285.  
  286.     if (my $log = get_diag_setting("FS_SA_REPORT")) {
  287.     ######## FIXME: vague heuristic for what "looks like" a file name
  288.     # If the value contains any of `/', `\', or `.', try it as a file
  289.     unless ($log =~ qr'[\\/.]' && open ($SPAM_SCANNER_REPORT, '>>', $log))
  290.     {
  291.         if (open ($SPAM_SCANNER_REPORT, ">&STDOUT")) {
  292.         # make the stream unbuffered so that it interleaves better with
  293.         # other STDOUT output.
  294.         # It would be cleaner to say
  295.         #    use IO::Handle;$SPAM_SCANNER_REPORT->autoflush(1);
  296.         # but IO::Handle might bring some bloat...
  297.         my $oldfh = select ($SPAM_SCANNER_REPORT);
  298.         $| = 1;
  299.         select($oldfh);
  300.         } else {
  301.         undef $SPAM_SCANNER_REPORT;
  302.         }
  303.     }
  304.     }
  305.  
  306.     # Print a stack trace when we get an error
  307.     $SIG{__DIE__} = sub {
  308.     # react only to runtime errors
  309.     return unless defined $^S && !$^S;
  310.  
  311.     warn "\nError:\n\t" . $_[0];
  312.     require Carp if defined $^S;
  313.  
  314.     # skip our main::__ANON__ routine from the trace
  315.     local $Carp::CarpLevel = $Carp::CarpLevel + 1;
  316.  
  317.     Carp::confess("Stack trace:\n") if defined &Carp::confess;
  318.     die "Something wrong, but could not load Carp to give backtrace...\n" .
  319.         "To see backtrace try starting Perl with -MCarp switch";
  320.     };
  321.  
  322.     # Bogus declarations of legacy packages to make downgrade work (#35947)
  323.     package bogus;
  324.     use strict;
  325.     use warnings;
  326.     for my $lib (qw(Storable
  327.             Mail::SpamAssassin::NoMailAudit
  328.             Mail::SpamAssassin::Logger
  329.             Mail::SpamAssassin::TextCat))
  330.     {
  331.     eval "require $lib;";
  332.     if ($@)
  333.     {
  334.         my $path = $lib;
  335.         $path =~ s%::%/%g;
  336.         if ($@ !~ m%^Can't locate $path.pm in \@INC %)
  337.         {
  338.         main::debug (1, "unexpected exception: $@");
  339.         }
  340.         main::debug (1, "declaring bogus $lib");
  341.         $::INC{"$path.pm"} = "bogus, my friend";
  342.     }
  343.     }
  344.  
  345.     package main;
  346.     debug (2, "<< BEGIN");
  347. }
  348.  
  349. sub spam_scanner_remove_hook
  350. {
  351.     my ($dir, $files, $directories) = @_;
  352.     debug (2, ">>spam_scanner_remove_hook($dir)");
  353.  
  354.     # Hook to remove obsolete files
  355.     for my $file (@$files) {
  356.     my $path = join(dirsep(), $dir, $file);
  357.  
  358.     debug (2, "spam_scanner_remove_hook: considering '$path'");
  359.  
  360.     next unless -w $path;
  361.  
  362.     debug (1, "spam_scanner_remove_hook: unlinking $path");
  363.     unlink $path or debug (1, "Could not unlink $path: $!");
  364.     }
  365.  
  366.     # Hook to remove obsolete directories
  367.     for my $file (@$directories) {
  368.     my $path = join(dirsep(), $dir, $file);
  369.  
  370.     debug (2, "spam_scanner_remove_hook: considering directory '$path'");
  371.  
  372.     next unless -d $path;
  373.  
  374.     debug (1, "spam_scanner_remove_hook: removing directory '$path'");
  375.     rmdir $path or debug (1, "Could not remove directory '$path': $!");
  376.     }
  377.  
  378.     debug (2, "<<spam_scanner_remove_hook()");
  379. }
  380.  
  381. my $spam_scanner_directory = undef;
  382. END
  383. {
  384.     spam_scanner_remove_hook($spam_scanner_directory, \@temporary_files, [])
  385.     if defined $spam_scanner_directory;
  386. }
  387.  
  388.  
  389. use Mail::SpamAssassin 2.6301; # really 2.64 (and now 3.1.3) -- see bug 34781
  390.  
  391. my @mapping = ();
  392. my %cached = ();            # Cache per-user configurations
  393. my $cached;
  394.  
  395. # Return this api version
  396. sub spam_scan_api_version { return 100; }
  397.  
  398. sub mkdir_path {
  399.     my ($base, $path) = @_;
  400.     my @parts = split(/\//, $path);
  401.  
  402.     $path = $base;
  403.     for my $part (@parts) {
  404.         $path = join(dirsep(), $path, $part);
  405.     unless (mkdir $path) {
  406.         debug (1, "Could not create directory '$path': $!");
  407.         return 0;
  408.     }
  409.     }
  410.     return 1;
  411. }
  412.  
  413. sub create_directories {
  414.     my ($base, @dirs) = @_;
  415.  
  416.     for my $file (@dirs) {
  417.     my $path = join(dirsep(), $base, $file);
  418.     debug (2, "considering creating directory '$path'");
  419.  
  420.     next if -d $path;
  421.  
  422.     debug (1, "creating directory '$path'");
  423.     mkdir_path($base, $file) or
  424.         debug (1, "Could not create directory '$path': $!");
  425.     }
  426. }
  427.  
  428. sub init_logging {
  429.     my ($dir) = @_;
  430.  
  431.     my $dirsep = dirsep();
  432.     my $log_path = join($dirsep, $dir, "log/fs_sa_log.txt");
  433.     my $log_path2 = join($dirsep, $dir, "log/fs_sa_log-old.txt");
  434.     my $max_log_file_size = 10000;
  435.  
  436.     if ((-s $log_path || 0 ) > $max_log_file_size) {
  437.     close(STDERR);
  438.     rename $log_path, $log_path2 or print "rename failed: $!\n";
  439.     }
  440.  
  441.     open(STDERR, '>>', $log_path);
  442.     select (STDERR); $| = 1;
  443.     select (STDOUT); $| = 1;
  444. }
  445.  
  446. sub get_mapping {
  447.     my ($mappings) = @_;
  448.  
  449.     die "Could not open $mappings: $!\n"
  450.     unless open (my $MAPPINGS, '<', $mappings);
  451.  
  452.     my @mapping = ();
  453.     while (<$MAPPINGS>)
  454.     {
  455.     # Skip comments && empty lines
  456.     next if m/^\s*(\#.*)?\r?$/;
  457.  
  458.     if (m/^\s*(\d+)\s+(-?((\.\d+)|\d+(\.\d+)?))\s*\r?$/)
  459.     {
  460.         my ($from, $to) = ($1, $2);
  461.         die "$mappings:$.:Target rating $from not between 1 and 9: $_"
  462.         unless ($from >= 1 && $from <= 9);
  463.         $mapping[$from] = $to;
  464.     }
  465.     else
  466.     {
  467.         die "$mappings:$.:Invalid input $_";
  468.     }
  469.     }
  470.     close $MAPPINGS;
  471.  
  472.     # Some final sanity checking of mappings
  473.     ######## TODO: interpolate missing limits geometrically instead of gripe?
  474.     for (my $i = 1; $i <= 9; ++$i)
  475.     {
  476.     die "$mappings: Confidence level rating $_ remains undefined"
  477.         unless (defined $mapping[$i]);
  478.     }
  479.  
  480.     return @mapping;
  481. }
  482.  
  483. sub init_msglog {
  484.     my ($dir) = @_;
  485.     my $dirsep = dirsep();
  486.  
  487.     return unless my $msglog_setting = get_diag_setting("FS_SA_MSGLOG");
  488.  
  489.     # expand the relative directory name
  490.     $spam_scanner_msglog_dir =
  491.     join($dirsep, $dir, $spam_scanner_msglog_base_dir);
  492.  
  493.     unless (-d $spam_scanner_msglog_dir) {
  494.     mkdir($spam_scanner_msglog_dir) or
  495.         debug(1, "msglog: failed to create directory '$spam_scanner_msglog_dir': $!");
  496.     }
  497.  
  498.     return unless -d $spam_scanner_msglog_dir;
  499.  
  500.     $spam_scanner_msglog_limit = $msglog_setting + 0;
  501.     debug(1, "msglog: requested to log $spam_scanner_msglog_limit messages");
  502.  
  503.     # the files are logged with names of the form "CLR%d-msg%04d.txt"
  504.     # count, if there are any matching ones already from a
  505.     # previous invocation and continue from there
  506.  
  507.     my @msg_names = ();
  508.     if (opendir(my $dir, $spam_scanner_msglog_dir)) {
  509.  
  510.     @msg_names = map {
  511.         /^CLR\d+-msg(\d{4})\.txt$/i ? $1 : ()
  512.     } readdir($dir);
  513.  
  514.     closedir($dir);
  515.     }
  516.  
  517.  
  518.     my $count = @msg_names;
  519.     my $last = $count ? (sort(@msg_names))[-1] + 0 : 0;
  520.  
  521.     debug(1, "msglog: found $count messages, highest numbered '$last'");
  522.  
  523.     $spam_scanner_msglog_count = $count + $last;
  524.     $spam_scanner_msglog_limit += $last;
  525.     debug(1, "msglog: logging messages from $spam_scanner_msglog_count to $spam_scanner_msglog_limit");
  526.  
  527.     # copy the configuration file to the logging directory first
  528.     my $cfg = join($dirsep, $dir, "fssc.cfg");
  529.     require File::Copy;
  530.     File::Copy::copy($cfg, $spam_scanner_msglog_dir) or
  531.     debug(1, "msglog: failed to copy '$cfg'");
  532. }
  533.  
  534. sub is_validating {
  535.     my ($top_dir) = @_;
  536.  
  537.     # normally the Spam Control directory contains this, but the
  538.     # database update directory not
  539.     return ! -e join(dirsep(), $top_dir, "fsas.dll");
  540. }
  541.  
  542. sub spam_scan_init {
  543.     my ($rules, $fsas_version) = @_;
  544.  
  545.     # store globally as an integer "vector"
  546.     $::fsas_version = defined $fsas_version ?
  547.     pack("U*", grep { s/^(\d+).*$/$1/ } split /\./, $fsas_version) : 0.0.0;
  548.  
  549.     debug (2, ">> spam_scan_init(" . join(", ", grep defined, @_) . ")");
  550.     my $dirsep = dirsep();
  551.  
  552.     debug (1, sprintf "spam_scan_init (%s/%s [%s], engine %s)",
  553.     $Mail::SpamAssassin::VERSION,
  554.     $VERSION,
  555.     $Id,
  556.     $fsas_version || "unknown"
  557.     );
  558.     
  559.     $spam_scanner_directory = join($dirsep, $rules, "..");
  560.     spam_scanner_remove_hook($spam_scanner_directory, [@temporary_files, @obsolete_files], \@obsolete_directories);
  561.  
  562.     my $is_validating = is_validating($spam_scanner_directory);
  563.     debug(1, "preparing for " .
  564.     ($is_validating ? "database validation" : "spam scanning")
  565.     );
  566.  
  567.     unless ($is_validating) {
  568.     create_directories($spam_scanner_directory, @needed_directories);
  569.     init_logging($spam_scanner_directory) unless $spam_scanner_debug;
  570.     }
  571.  
  572.     my ($mappings) = join ($dirsep, $rules, "mappings.txt");
  573.  
  574.     @mapping = get_mapping($mappings);
  575.  
  576.     my $cfg = join ($dirsep, $rules, "..", "site");
  577.  
  578.     $::sa = new Mail::SpamAssassin({
  579.         rules_filename      => $rules,
  580.         site_rules_filename => $cfg,
  581.         userstate_dir       => $rules,
  582.         local_tests_only    => 0,    # 1,
  583.         dont_copy_prefs     => 1,
  584.         debug               => $spam_scanner_debug,
  585.     });
  586.  
  587.     # FIXME: Not valid anymore?
  588.     if ($spam_scanner_debug)
  589.     {
  590.     $Mail::SpamAssassin::DEBUG->{rulesrun} = 127;
  591.     $Mail::SpamAssassin::DEBUG->{rbl} = -1;
  592.     $::sa->{save_pattern_hits} = 1;
  593.     }
  594.  
  595.     $::sa->compile_now(0);
  596.  
  597.     # Cache global settings
  598.     eval {
  599.     $::sa->copy_config(undef, \%{$cached{''}}) or
  600.         debug (1, "failed to copy_config");
  601.     };
  602.     debug (1, "could not find copy_config: $@") if ($@);
  603.     $cached = '';
  604.  
  605.     init_msglog($spam_scanner_directory) unless $is_validating;
  606.  
  607.     debug (2, "<<spam_scan_init()");
  608. }
  609.  
  610. sub spam_scan_version {
  611.     return ($::sa->Version . "+fs$VERSION");
  612. }
  613.  
  614. sub spam_scan_lint_rules {
  615.     ######## TODO: maybe remove this braindeath altogether one day
  616.     debug (1, "spam_scan_lint_rules bypassed (bug #34781)");
  617.     return 0;
  618.     #return &spam_scan_lint_really();
  619. }
  620.  
  621. sub open_or_debug {
  622.     my $ok = open($_[0], $_[1], $_[2]);
  623.     debug(1, "could not open file '$_[2]': $!")
  624.     unless $ok;
  625.  
  626.     return $ok;
  627. }
  628.  
  629. sub set_sa_config {
  630.     my ($config) = @_;
  631.  
  632.     if ($config eq $cached)
  633.     {
  634.     # no action
  635.     }
  636.     elsif ($cached{$config})
  637.     {
  638.     debug (1, "set_sa_config: retreiving cached config");
  639.     $::sa->copy_config($cached{$config}, undef) or
  640.         die "copy_config failed";
  641.     $cached = $config;
  642.     }
  643.     else
  644.     {
  645.     debug (1, "set_sa_config: no cached config");
  646.  
  647.     # Massage $config into the format it really needs to be in.
  648.     # That is, any F-specific directives are either handled and removed,
  649.     # or transformed into the corresponding generic SA directives.
  650.  
  651.     my $rawconfig = $config;
  652.     my $username;
  653.  
  654.     my %directives = (
  655.         username => sub { $username = shift; },
  656.     );
  657.     my $directives = join ('|', keys %directives);
  658.  
  659.     ######## FIXME: ugly spaces required in most values in %subst
  660.     my %subst = (
  661.         blacklist => 'blacklist_from ',
  662.         whitelist => 'whitelist_from ',
  663.         mydomain  => 'whitelist_from *@',
  664.         # blacklist_to => (identity),
  665.         # whitelist_to => (identity),
  666.     );
  667.     my $subst = join ('|', keys %subst);
  668.  
  669.     my @addr_options = qw(
  670.         whitelist_from unwhitelist_from whitelist_from_rcvd
  671.         def_whitelist_from_rcvd whitelist_allows_relays
  672.         unwhitelist_from_rcvd blacklist_from unblacklist_from
  673.         whitelist_to more_spam_to all_spam_to blacklist_to
  674.     );
  675.     my $addr_options = join('|', @addr_options);
  676.  
  677.     $config =~ s/^\s*($directives)\s(.*)\r?/&{$directives{$1}}($2)/mge;
  678.     $config =~ s/^\s*($subst)\s+(.*)\r?$/$subst{$1}$2/mg;
  679.     $config =~ s/^\s*($addr_options)\s+<(\S+)>(\s|$)/$1 $2$3/mg;
  680.  
  681.     # Augment $::sa->{conf} with additional configuration data in $config
  682.  
  683.     # restore the common configuration
  684.     $::sa->copy_config($cached{''}, undef) or
  685.         die "copy_config failed";
  686.     $cached = '';
  687.  
  688.     # Go and parse the config!
  689.     $::sa->{conf}->{main} = $::sa;
  690.  
  691.     $::sa->{conf}->parse_scores_only ($config);
  692.     $::sa->{conf}->finish_parsing ();
  693.     delete $::sa->{conf}->{main}; # to allow future GC'ing
  694.  
  695.     $::sa->signal_user_changed ({ username => $username });
  696.  
  697.     # and cache the newly parsed
  698.     $::sa->copy_config(undef, \%{$cached{$rawconfig}}) or
  699.         die "copy_config failed";
  700.     $cached = $rawconfig;
  701.     }
  702.  
  703. }
  704.  
  705. sub spam_scan_message {
  706.     debug (2, ">>spam_scan_message");
  707.  
  708.     my ($c, @data) = @_;
  709.     my ($config, $conf);
  710.     if (ref $c eq "HASH")
  711.     {
  712.     $config = $c->{bwlist} || '';
  713.     $conf = $c->{settings} || { };
  714.     }
  715.     else
  716.     {
  717.     $conf = { };
  718.     $config = $c;
  719.     }
  720.     $config = $custom_settings . $config if $custom_settings;
  721.  
  722.     # Default is to use envelope sender and recipient, if available.
  723.     my $use_envelope = 0;
  724.     if (defined $conf->{sender} ||
  725.     defined $conf->{recipients})
  726.     {
  727.     if (defined $conf->{sender} &&
  728.         defined $conf->{recipients})
  729.     {
  730.         $use_envelope = 1;
  731.         debug (2, "Envelope sender and recipients supplied: " .
  732.            "/sender:" . $conf->{sender} .
  733.            "; /recipients:" . $conf->{recipients});
  734.     }
  735.     else
  736.     {
  737.         my ($supplied, $missing) =
  738.         (defined $conf->{sender}
  739.          ? ("/sender:" . $conf->{sender}, "/recipients")
  740.          : ("/recipients:" . $conf->{recipients}, "/sender") );
  741.         warn "$supplied supplied but $missing missing\n";
  742.         debug (2, "$supplied supplied but $missing missing");
  743.     }
  744.     }
  745.     else
  746.     {
  747.     debug (1, "No envelope information supplied; using headers");
  748.     }
  749.  
  750.     if ($use_envelope)
  751.     {
  752.     # Zapping the scores for these rules mean they will not show in hits,
  753.     # but we are still able to check if an address is black/whitelisted
  754.  
  755.     $config .= "
  756. score USER_IN_DEF_WHITELIST 0
  757. score USER_IN_DEF_BLACKLIST 0
  758. score USER_IN_WHITELIST_TO  0
  759. score USER_IN_BLACKLIST_TO  0
  760. score USER_IN_WHITELIST     0
  761. score USER_IN_BLACKLIST     0
  762. ";
  763.     }
  764.  
  765.     my $spam_scanner_msglog_on = 0;
  766.     if (
  767.     defined $spam_scanner_msglog_limit &&
  768.     $spam_scanner_msglog_count < $spam_scanner_msglog_limit
  769.     ) {
  770.     $spam_scanner_msglog_on = 1;
  771.     $spam_scanner_msglog_count++;
  772.     }
  773.  
  774.     if (defined $SPAM_SCANNER_REPORT || $spam_scanner_msglog_on) {
  775.     print $SPAM_SCANNER_REPORT "file: '$c->{filename}'\n"
  776.         if defined $SPAM_SCANNER_REPORT && ref $c && defined $c->{filename};
  777.  
  778.     $config .= "
  779. clear_report_template
  780. report
  781. report report _REPORT_
  782. report total _SCORE_/_REQD_
  783. ";
  784.     }
  785. ### TODO: _REQD_ doesn't seem to match what fsas.dll has as a limit
  786. ### (at least when fpirun calls it), take it out? Or set it somehow?
  787.  
  788.     my $hits = "N/A";
  789.  
  790.     set_sa_config($config);
  791.  
  792.     my $confidence_level_rating;
  793.     my $report;
  794.  
  795.     # Default is to do full test, but bypass if we get black/white envelope
  796.     my $full_test = 1;
  797.     my $full_report;
  798.  
  799.     if ($use_envelope)
  800.     {
  801.     my $dummy = Mail::SpamAssassin::PerMsgStatus->new($::sa, undef);
  802.     @{$dummy->{all_from_addrs}} = map { s/^<(.*)>$/$1/;$_ } split(
  803.         ";", $conf->{sender});
  804.     @{$dummy->{all_to_addrs}} = map { s/^<(.*)>$/$1/;$_ } split(
  805.         ";", $conf->{recipients});
  806. ######## FIXME: rules/97_fs-whitelist-from.cf should work with envelopes too
  807. ######## TODO: should we copy over def_whitelist_from etc?
  808. #    for my $key (qw(    whitelist_from      whitelist_to
  809. #                whitelist_from_rcvd
  810. #            def_whitelist_from
  811. #            def_whitelist_from_rcvd
  812. #                blacklist_from      blacklist_to
  813. #                more_spam_to all_spam_to))
  814. #    {
  815. #        $dummy->{conf}->{$key} = $::sa->{conf}->{$key};
  816. #warn "\$dummy->{conf}->{$key} =\n"; map { warn "   '$_' => '", $dummy->{conf}->{$_} || "", "'\n" } keys %{$dummy->{conf}->{$key}};
  817. #    }
  818.  
  819.     if ($dummy->check_from_in_whitelist
  820.      || $dummy->check_to_in_whitelist)
  821.     {
  822.         $confidence_level_rating = 0;
  823.         $report = "WHITELISTED";
  824.         $full_test = 0;
  825.     }
  826.     elsif ($dummy->check_from_in_blacklist
  827.         || $dummy->check_to_in_blacklist)
  828.     {
  829.         $confidence_level_rating = 10;
  830.         $report = "BLACKLISTED";
  831.         $full_test = 0;
  832.     }
  833.     }
  834.  
  835.     my %classifications = ( );
  836.     if ($full_test)
  837.     {
  838.     # IGK/FSAV4IMTTLATIMLA >= 6.40 adds spurious Received: header and
  839.     # final trailing CRLF -- trim them if present (CTS #49919)
  840.     ######## TODO: make conditional on engine.cf too?
  841.     my $i = 0;
  842.     if ($data[$i++] =~ m/\AReceived: from .*\(.* \[[.0-9]+\]\)\r\n\Z/
  843.         && ($data[$i] =~ m/\A by .* \(\[[.0-9]+\]:\d+\) \(.*\)\r\n\Z/
  844.         && ++$i || '# this will be missing in "anonymous mode"')
  845.         && $data[$i++] =~ m/\A[ ]with[ ].*;[ ]        # SMTP or ESMTP
  846.         ([A-Z][a-z]{2},[ ]                # weekday,
  847.         [ 0-3][0-9][ ][A-Z][a-z]{2}[ ][12]\d{3}[ ]    # nn Mon yyyy
  848.         [012]\d:\d{2}:\d{2}[ ]                # hh:mm:ss
  849.         [-+ ]?\d{4})                    # -TZ00
  850.         \r\n\Z/x
  851.         && (my $datestamp = $1)
  852.         && $data[$i] =~ m/\A \(envelope-from .*\)\r\n\Z/
  853.         && $data[-1] eq "\r\n")
  854.     {
  855.         my $age = Mail::SpamAssassin::Util::parse_rfc822_date ($datestamp);
  856.         my $t;
  857.         if (! defined $age)
  858.         {
  859.         debug (1, "Invalid date in IGK/FSAV4IM Received: header");
  860.         }
  861.         elsif ($age > ($t = time))
  862.         {
  863.         debug (1, "IGK/FSAV4IM Received: header dated in the future");
  864.         }
  865.         elsif ($age < $t-300)    ######## FIXME: higher age limit?
  866.         {
  867.         debug (1, "IGK/FSAV4IM Received: header older than 5 minutes");
  868.         }
  869.         else
  870.         {
  871.         debug (1,
  872.             "Trimming IGK/FSAV4IM >= 6.40 Received: and final CRLF");
  873.         splice @data, 0, $i;
  874.         splice @data, -1, 1;
  875.         }
  876.     }
  877.  
  878.     # If mail seems to contain \r?\r\n's throughout, attempt to fix
  879.     for my $regex (qr(\r\r\n\Z), qr(\r\n\Z))
  880.     {
  881.         my @dataclone;
  882.         foreach (@data)
  883.         {
  884.         my $datum = $_;
  885.         unless ($datum =~ s/$regex/\n/)
  886.         {
  887.             @dataclone = ();
  888.             last;
  889.         }
  890.         push @dataclone, $datum;
  891.         }
  892.  
  893.         if (@dataclone)
  894.         {
  895.         debug (1, "spam_scan_message: $regex line endings normalized");
  896.         @data = @dataclone;
  897.         last;
  898.         }
  899.     }
  900.  
  901.     # Check mail with current settings
  902.     my $mail = $::sa->parse(\@data);
  903.     my $status = $::sa->check ($mail); # The check is in the mail
  904.  
  905.     # If white/blacklisted, just return ({WHITE,BLACK}LISTED, {0,10})
  906.     ######## TODO: is there a less resource-intensive way to do this?
  907.     # One gets the feeling that the check($mail) above does lots of work
  908.     # Plan: factor out and use only pertinent parts of SpamAssassin->check
  909.     ######## FIXME: perhaps also check other PerMsgStatus->..._whitelist
  910.  
  911.     if (! $use_envelope &&
  912.         ($status->check_from_in_whitelist
  913.        || $status->check_to_in_whitelist))
  914.     {
  915.         $confidence_level_rating = 0;
  916.         $report = "WHITELISTED";
  917.     }
  918.     elsif (! $use_envelope &&
  919.         ($status->check_from_in_blacklist
  920.         || $status->check_to_in_blacklist))
  921.     {
  922.         $confidence_level_rating = 10;
  923.         $report = "BLACKLISTED";
  924.     }
  925.     else
  926.     {
  927.         $hits = $status->get_hits();
  928.         $confidence_level_rating = get_clr($hits);
  929.         $report = $status->get_names_of_tests_hit();
  930.     }
  931.  
  932.     if (defined $SPAM_SCANNER_REPORT || $spam_scanner_msglog_on)
  933.     {
  934.         $full_report = $status->get_report();
  935.     }
  936.  
  937.     %classifications = %{$status->{fs_phishblplugin} || {}};
  938.     $status->finish();
  939.     $mail->finish();
  940.     }
  941.  
  942.     printf $SPAM_SCANNER_REPORT "%sCLR %s\n",
  943.     $full_report, $confidence_level_rating
  944.         if (defined $SPAM_SCANNER_REPORT);
  945.  
  946.     if ($spam_scanner_msglog_on) {
  947.     if (open_or_debug(my $fh, '>', sprintf(
  948.         "$spam_scanner_msglog_dir/CLR%d-msg%04d.txt",
  949.         $confidence_level_rating,
  950.         $spam_scanner_msglog_count
  951.     ))) {
  952.         print $fh $config;
  953.         print $fh "-" x 80, "\n";
  954.         printf $fh "%sCLR %s\nreport %s\nhits %s\n",
  955.         $full_report,
  956.         $confidence_level_rating,
  957.         $report, $hits;
  958.         print $fh "=" x 80,"\n";
  959.         print $fh @data;
  960.         close($fh);
  961.     }
  962.  
  963.     }
  964.  
  965.     # report the traditional spam score also as a "spam class" score
  966.     $classifications{spam} = $confidence_level_rating;
  967.  
  968.     # convert any heuristic phishing rule matches to "phishing class"
  969.     # score of 9, unless specific phishing score is already higher,
  970.     # or explicitly whitelisted (phishing score zero).
  971.     $classifications{phishing} = 9 if
  972.     $report =~ /PHISH/ && (
  973.         !exists $classifications{phishing} || (
  974.         $classifications{phishing} < 9 &&
  975.         $classifications{phishing} != 0
  976.         )
  977.     );
  978.  
  979.     # add any specific classifications as pseudo rules of the form
  980.     # FS_CLASS_<class>_<value> into the matched rule names list
  981.     $report .= ($report ? "," : "")  . join(",",
  982.     map { "FS_CLASS_\U$_\E_$classifications{$_}" }
  983.     keys %classifications
  984.     );
  985.  
  986.     debug (0, sprintf "spam_scan_message result: CLR = %s (%s; %s; %s)",
  987.     $confidence_level_rating,
  988.     $hits,
  989.     $report ? "$report" : '',
  990.     join(", ", map { "$_ = $classifications{$_}" } keys %classifications)
  991.     );
  992.  
  993.     if ($::fsas_version lt 1.22.0) {
  994.     # for old clients that only know about spam scores,
  995.     # convert any phishing score into a spam score, unless
  996.     # the score is already higher, or the message whitelisted.
  997.     # this way any phishing messages get moved at least to
  998.     # the junk mail folder.
  999.     if (
  1000.         $confidence_level_rating > 0 &&
  1001.         exists $classifications{phishing} &&
  1002.         $confidence_level_rating < $classifications{phishing})
  1003.     {
  1004.         $confidence_level_rating = $classifications{phishing};
  1005.     }
  1006.  
  1007.     debug (2, "<<spam_scan_message (old engine, CLR = $confidence_level_rating)");
  1008.     return ($report, $confidence_level_rating);
  1009.     }
  1010.   
  1011.     debug (2, "<<spam_scan_message");
  1012.     return ($report, $confidence_level_rating, \%classifications);
  1013. }
  1014.  
  1015. sub get_clr
  1016. {
  1017.     ######## FIXME: do a binary search here instead
  1018.     my ($score) = @_;
  1019.     my $i;
  1020.     for ($i = 9; $i >= 1; --$i)
  1021.     {
  1022.     last if ($mapping[$i] <= $score);
  1023.     }
  1024.     return $i;
  1025. }
  1026.  
  1027. sub spam_scan_lint_really
  1028. {
  1029.     debug (1, "lint");
  1030.     #$::sa->{conf} = $cached{''}->copy() if (defined $cached{''});
  1031.     return ($::sa->lint_rules_really);
  1032. }
  1033.  
  1034.  
  1035.  
  1036. 1;
  1037.