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 / lib / FS / MsgStructure.pm < prev    next >
Text File  |  2006-11-29  |  10KB  |  403 lines
  1. # FS::MsgStructure.pm -- era Tue Nov 16 10:47:31 2004
  2. # $Id: MsgStructure.pm 3971 2006-10-17 07:34:01Z eriker $
  3. # Copyright (C) 2004, 2005, 2006 F-Secure Corporation
  4.  
  5. =head1 NAME
  6.  
  7. FS::MsgStructure - SpamAssassin message structure template plugin
  8.  
  9. =head1 SYNOPSIS
  10.  
  11. The following is merely an illustrative example,
  12. not a properly tested rule.
  13.  
  14.   loadplugin   FS::MsgStructure
  15.  
  16.   define_structure MSGSTRUCT_QMAIL_BOUNCE
  17.   structure ^(?:Hi\. )?This is the qmail-send program at [^<>@ \t,;]{4,60}\.\n
  18.   structure I'm afraid I wasn't able to deliver your message to the(?: )
  19.   structure    following addresses.\n
  20.   structure This is a permanent error; I've given up\.(?: )
  21.   structure    Sorry it didn't work out\.\n\n
  22.   structure (?:\S+ )*<[^<>@ \t,;]{2,60}@[^<>@ \t,;]{4,60}>:\n
  23.   structure Sorry, no mailbox here by that name\.(?: )
  24.   structure    \(\#\d{1,3}\.\d{1,3}\.\d{1,3}\)\n
  25.   structure \n--- Below this line is a copy of the message.\n\n
  26.  
  27.   describe MSGSTRUCT_QMAIL_BOUNCE Message appears to be a Qmail bounce
  28.   score    MSGSTRUCT_QMAIL_BOUNCE -1
  29.  
  30. =head1 DESCRIPTION
  31.  
  32. B<FS::MsgStructure> allows you to define
  33. message template rules for SpamAssassin.
  34. These are like big body rules which let you
  35. look for messages with a particular structure.
  36.  
  37. The benefit is that you can define very
  38. precise rules which are not likely to
  39. produce any false positives.
  40. The cost is that the rules are a bit slow
  41. to process, and somewhat unwieldy to
  42. create and maintain.
  43.  
  44. =cut
  45.  
  46. # Cruft cased and pasted from Mail::SpamAssassin::Plugin::Test
  47.  
  48. package FS::MsgStructure;
  49.  
  50. use Mail::SpamAssassin::Plugin;
  51. use strict;
  52. use bytes;
  53.  
  54. our @ISA = qw(Mail::SpamAssassin::Plugin);
  55. our $VERSION = '0.001';            ######## TODO: remember to update
  56.  
  57. # Declaration of new rules is a bit ass-backwards because Plugin doesn't
  58. # currently have proper support for the things we want to do.
  59. #
  60. # The current implementation works like this;
  61. #  define_structure calls MsgStructure::Rule->new
  62. #      which simply declares $conf->{msg_structure_plugin}->{rules}->{$name}
  63. #      and returns a handle to that (called $rule in this expose).
  64. #      It also runs add_test(eval:msg_structure_plugin_rule($name)) to add
  65. #      a call to the corresponding rule to the SpamAssassin rule base.
  66. #  structure calls $rule->add_text (text)
  67. #      which adds to $conf->{msg_structure_plugin}->{rules}->{$name}->{text}
  68. #  Additionally, the first call to define_structure sets up an
  69. #      eval:initialize_msg_structure_plugin() rule (in Rule->new())
  70. #      which will eventually be called to compile the collected rules.
  71. #
  72. # In order for structure to know which rule it's adding text to,
  73. # we set up a semi-global handle $conf->{msg_structure_plugin}->{__parse__}
  74. # which points to the current $rule which we are parsing.
  75. #
  76. # A better implementation would allow us to define a new rule type
  77. # and handle rule collection and compilation through that rule type.
  78.  
  79. $Mail::SpamAssassin::DEBUG->{msgstruct_plugin} ||= 0;
  80.  
  81. sub new {
  82.   my $class = shift;
  83.   my $mailsaobject = shift;
  84.  
  85.   # some boilerplate...
  86.   $class = ref($class) || $class;
  87.   my $self = $class->SUPER::new($mailsaobject);
  88.   bless ($self, $class);
  89.   $self->{conf} = $mailsaobject->{conf};
  90.   
  91.   ######## TODO: maybe one day register completely a new rule type instead
  92.   $self->register_eval_rule ("initialize_msg_structure_plugin");
  93.   $self->register_eval_rule ("msg_structure_plugin_rule");
  94.   
  95.   dbg("plugin: registered FS::MsgStructure plugin", 'msgstruct_plugin', -1);
  96.   return $self;
  97. }
  98.  
  99. my %parser = ();
  100.  
  101.  
  102. sub define_structure
  103. {
  104.     my ($self, $opts) = @_;
  105.  
  106.     #dbg("msgstruct: define_structure " . $opts->{value} . " with conf " . $opts->{conf});
  107.  
  108.     my $name = $opts->{value};
  109.     my $conf = $opts->{conf};
  110.  
  111.     my $rule = FS::MsgStructure::Rule->new($name, $conf);
  112.     $conf->{msg_structure_plugin}->{__parse__} = $rule;
  113.  
  114.     $conf->{parser}->add_test ($name,
  115.                    qq(msg_structure_plugin_rule("$name")),
  116.                    $Mail::SpamAssassin::Conf::TYPE_FULL_EVALS);
  117.     return $rule;
  118. }
  119.  
  120. $parser{'define_structure'} = \&define_structure;
  121.  
  122.  
  123. sub structure
  124. {
  125.     my ($self, $opts) = @_;
  126.  
  127.     my $rule = $opts->{conf}->{msg_structure_plugin}->{__parse__};
  128.     ######## FIXME: maybe return Mail::SpamAssassin::Conf::INVALID_VALUE here?
  129.     die ref($self), ": structure directive without define_structure"
  130.     unless (defined $rule);
  131.     #dbg("msgstruct: structure " . $opts->{value});
  132.     return $rule->add_text ($opts->{value});
  133. }
  134.  
  135. $parser{'structure'} = \&structure;
  136.  
  137.  
  138. =back
  139.  
  140. =cut
  141.  
  142. sub parse_config
  143. {
  144.     my ($self, $opts) = @_;
  145.  
  146.     my $parser = $parser{$opts->{key}};
  147.     if (defined $parser)
  148.     {
  149.     $self->$parser($opts) &&
  150.         return $self->inhibit_further_callbacks();
  151.     }
  152.     # else
  153.     undef $opts->{conf}->{msg_structure_plugin}->{__parse__};
  154.     return 0;
  155. }
  156.  
  157.  
  158. sub initialize_msg_structure_plugin
  159. {
  160.     my $self = shift;
  161.     my $permsgstatus = shift;
  162.  
  163.     my $conf = $self->{conf};
  164.  
  165.     # If this is set, it's a signal that we are already initialized
  166.     return 0 if (defined $conf->{msg_structure_plugin}->{__init_done__});
  167.  
  168.     # If this doesn't exist, we don't need to do anything
  169.     if (defined $conf->{msg_structure_plugin}->{__init__})
  170.     {
  171.     dbg("msgstruct: Running initialize_msg_structure_plugin pseudo-rule");
  172.     for my $rule (keys %{$conf->{msg_structure_plugin}->{rules}})
  173.     {
  174.         $conf->{msg_structure_plugin}->{rules}->{$rule}->init();
  175.     }
  176.     }
  177.  
  178.     # We're done -- signal to self that we are a no-op now
  179.     $conf->{msg_structure_plugin}->{__init_done__} = 1;
  180.  
  181.     return 0;
  182. }
  183.  
  184. sub msg_structure_plugin_rule
  185. {
  186.     my $self = shift;
  187.     my $permsgstatus = shift;
  188.     my $messageref = shift;
  189.  
  190.     #my $name = $self->{name};
  191.     ######## FIXME: somehow we're not being passed the current rule name :-(
  192.     my $name = $permsgstatus->{current_rule_name};
  193.     my $conf = $self->{conf};
  194.  
  195.     die "msg_structure_plugin_rule called without having been initialized\n"
  196.     unless (defined $conf->{msg_structure_plugin}->{__init_done__});
  197.  
  198.     die "Unknown msg_structure_plugin_rule $name"
  199.         unless (defined $conf->{msg_structure_plugin}->{rules}->{$name});
  200.  
  201.     return $conf->{msg_structure_plugin}->{rules}->{$name}->
  202.     eval($permsgstatus, $messageref);
  203. }
  204.  
  205.  
  206.  
  207. *dbg = *Mail::SpamAssassin::Plugin::dbg;
  208.  
  209.  
  210.  
  211. package FS::MsgStructure::Rule;
  212.  
  213. =head1 CONFIGURATION DIRECTIVES
  214.  
  215. B<FS::MsgStructure> is supported
  216. via the following configuration
  217. directives.
  218.  
  219. =over 4
  220.  
  221. =item B<define_structure> I<rule_name>
  222.  
  223. Start the definition of a new structure rule,
  224. and declare I<rule_name> to be its name.
  225.  
  226. The content of the rule will be the contents
  227. of the B<structure> directives which follow.
  228. See below.
  229.  
  230. =cut
  231.  
  232. my $ignore = <<'=cut';
  233. It is an error to define an empty
  234. structure.
  235.  
  236. =cut
  237.  
  238. sub new
  239. {
  240.     my $class = shift;
  241.     my $self = bless { }, $class;
  242.  
  243.     my $name = shift;
  244.     $self->{name} = $name;
  245.  
  246.     my $conf = shift;
  247.     $self->{conf} = $conf;
  248.  
  249.     unless (defined $conf->{msg_structure_plugin}->{__init__})
  250.     {
  251.     $conf->{parser}->add_test ('__MSG_STRUCTURE_INIT__',
  252.                    'initialize_msg_structure_plugin()',
  253.                    $Mail::SpamAssassin::Conf::TYPE_HEAD_EVALS);
  254.     $conf->{msg_structure_plugin}->{__init__} =
  255.         \$conf->{tests}->{'__MSG_STRUCTURE_INIT__'};
  256.     }
  257.     
  258.     $conf->{msg_structure_plugin}->{rules}->{$name} = $self;
  259.  
  260.     $self->{text} = '';
  261.  
  262.     return $self;
  263. }
  264.  
  265.  
  266. =item B<structure> I<text>
  267.  
  268. Add the specified I<text>
  269. to the structure being defined.
  270.  
  271. It is an error to invoke this directive
  272. before any structure has been declared
  273. with B<define_structure>.
  274.  
  275. The collected B<structure> directives
  276. are compiled into one long regular expression
  277. by simple concatenation, after
  278. newlines and trailing spaces are trimmed off.
  279.  
  280. The regular expression is then evaluated
  281. against the message body.
  282. Technically the resulting rule is internally
  283. a B<FULL_EVAL> rule, but it is transformed
  284. so that any B<^> anchor matches on the
  285. beginning of the body instead,
  286. and B<$> matches against the end of the body.
  287. Use B<\n> to match a newline within the body.
  288.  
  289. =cut
  290.  
  291.  
  292. sub add_text
  293. {
  294.     my $self = shift;
  295.     my $text = shift;
  296.     #$text =~ s/%/\\\%/g;
  297.     $self->{text} .= $text;
  298.     #dbg("msgstruct: Adding to $self->{name} text: result is $self->{text}");
  299. }
  300.  
  301.  
  302. # This is called for each rule by eval:initialize_msg_structure_plugin()
  303. sub init
  304. {
  305.     my $self = shift;
  306.  
  307.     my $conf = $self->{conf};
  308.     my $name = $self->{name};
  309.     my $eval;
  310.  
  311.     # Massage text into something closer to what we actually want
  312.     my $regex = $self->preprocess ($self->{text});
  313.  
  314.     #dbg("msgstruct: initializing structure rule $name (regex is $regex)");
  315.     if ($conf->{parser}->is_regexp_valid ($name, $regex))
  316.     {
  317.     # Eye candy for making evalstr slightly more human readable
  318.     my $obj = '$obj';
  319.     my $msgref = '$msgref';
  320.     # More eye candy, slighly more tricky (not just identity)
  321.     my $subname = "FS::MsgStructure::Rule::sub::$name";
  322.     my $msg = '$$msgref';
  323.     my $sub = '$eval';
  324.  
  325.     my $debug_maybe = '';
  326.     $debug_maybe = 'dbg("rules: Match on $name ($regex): $&")'
  327.         if $::sa->{save_pattern_hits};
  328.  
  329.     # Gack, paste & rape of what's going on in PerMsgStatus
  330.     my $evalstr = <<"________IOR";
  331.         sub $subname {
  332.         my $obj = shift;
  333.         my $msgref = shift;
  334.         if ($msg =~ m{$regex}o)
  335.         {
  336.             $debug_maybe;
  337.             return 1;
  338.         }
  339.         # else
  340.         return 0;
  341.         };
  342.         1;
  343. ________IOR
  344.  
  345.     eval ($evalstr);
  346.     if ($@)
  347.     {
  348.         warn "Failed to compile msg_struct $name rule, skipping:\n",
  349.         "\t($@)\n";
  350.     }
  351.     else
  352.     {
  353.         $self->{eval} = \&$subname;
  354.     }
  355.     }
  356. }
  357.  
  358. # Rewrite parts of a regular expression to better support our mental model
  359. sub preprocess
  360. {
  361.     my $self = shift;
  362.     my $regex = shift;
  363.  
  364.     # Translate ^ anchor to start of body regex
  365.     $regex =~ s%^\^%^(?:(?:.+?\\n){0,100}\\n)%;
  366.  
  367.     return $regex;
  368. }
  369.  
  370. # When the rule is actually evaluated with eval:msg_structure_plugin_rule(this)
  371. sub eval
  372. {
  373.     my $self = shift;
  374.     my $permsgstatus = shift;
  375.     my $msgref = shift;
  376.  
  377.     #dbg("rules: Running $self->{text} against $$msgref");
  378.     return $self->{eval}->($permsgstatus, $msgref);
  379.  
  380.     #my $message = $permsgstatus->get_message()->get_pristine();
  381.     #return $message =~ $self->{regex};
  382. }    
  383.  
  384. *dbg = *Mail::SpamAssassin::Plugin::dbg;
  385.  
  386. package FS::MsgStructure;
  387.  
  388. 1;
  389.  
  390. =head1 BUGS
  391.  
  392. The plugin makes SpamAssassin
  393. slightly slower, but not by much.
  394.  
  395. It would be nice to have a facility
  396. for declaring regular expression macros.
  397.  
  398. =head1 COPYRIGHT
  399.  
  400. Copyright (C) 2004 F-Secure Corporation
  401.  
  402. =cut
  403.