# FS::MsgStructure.pm -- era Tue Nov 16 10:47:31 2004
# $Id: MsgStructure.pm 3971 2006-10-17 07:34:01Z eriker $
# Copyright (C) 2004, 2005, 2006 F-Secure Corporation

=head1 NAME

FS::MsgStructure - SpamAssassin message structure template plugin

=head1 SYNOPSIS

The following is merely an illustrative example,
not a properly tested rule.

  loadplugin   FS::MsgStructure

  define_structure MSGSTRUCT_QMAIL_BOUNCE
  structure ^(?:Hi\. )?This is the qmail-send program at [^<>@ \t,;]{4,60}\.\n
  structure I'm afraid I wasn't able to deliver your message to the(?: )
  structure    following addresses.\n
  structure This is a permanent error; I've given up\.(?: )
  structure    Sorry it didn't work out\.\n\n
  structure (?:\S+ )*<[^<>@ \t,;]{2,60}@[^<>@ \t,;]{4,60}>:\n
  structure Sorry, no mailbox here by that name\.(?: )
  structure    \(\#\d{1,3}\.\d{1,3}\.\d{1,3}\)\n
  structure \n--- Below this line is a copy of the message.\n\n

  describe MSGSTRUCT_QMAIL_BOUNCE Message appears to be a Qmail bounce
  score    MSGSTRUCT_QMAIL_BOUNCE -1

=head1 DESCRIPTION

B<FS::MsgStructure> allows you to define
message template rules for SpamAssassin.
These are like big body rules which let you
look for messages with a particular structure.

The benefit is that you can define very
precise rules which are not likely to
produce any false positives.
The cost is that the rules are a bit slow
to process, and somewhat unwieldy to
create and maintain.

=cut

# Cruft cased and pasted from Mail::SpamAssassin::Plugin::Test

package FS::MsgStructure;

use Mail::SpamAssassin::Plugin;
use strict;
use bytes;

our @ISA = qw(Mail::SpamAssassin::Plugin);
our $VERSION = '0.001';			######## TODO: remember to update

# Declaration of new rules is a bit ass-backwards because Plugin doesn't
# currently have proper support for the things we want to do.
#
# The current implementation works like this;
#  define_structure calls MsgStructure::Rule->new
#      which simply declares $conf->{msg_structure_plugin}->{rules}->{$name}
#      and returns a handle to that (called $rule in this expose).
#      It also runs add_test(eval:msg_structure_plugin_rule($name)) to add
#      a call to the corresponding rule to the SpamAssassin rule base.
#  structure calls $rule->add_text (text)
#      which adds to $conf->{msg_structure_plugin}->{rules}->{$name}->{text}
#  Additionally, the first call to define_structure sets up an
#      eval:initialize_msg_structure_plugin() rule (in Rule->new())
#      which will eventually be called to compile the collected rules.
#
# In order for structure to know which rule it's adding text to,
# we set up a semi-global handle $conf->{msg_structure_plugin}->{__parse__}
# which points to the current $rule which we are parsing.
#
# A better implementation would allow us to define a new rule type
# and handle rule collection and compilation through that rule type.

$Mail::SpamAssassin::DEBUG->{msgstruct_plugin} ||= 0;

sub new {
  my $class = shift;
  my $mailsaobject = shift;

  # some boilerplate...
  $class = ref($class) || $class;
  my $self = $class->SUPER::new($mailsaobject);
  bless ($self, $class);
  $self->{conf} = $mailsaobject->{conf};
  
  ######## TODO: maybe one day register completely a new rule type instead
  $self->register_eval_rule ("initialize_msg_structure_plugin");
  $self->register_eval_rule ("msg_structure_plugin_rule");
  
  dbg("plugin: registered FS::MsgStructure plugin", 'msgstruct_plugin', -1);
  return $self;
}

my %parser = ();


sub define_structure
{
    my ($self, $opts) = @_;

    #dbg("msgstruct: define_structure " . $opts->{value} . " with conf " . $opts->{conf});

    my $name = $opts->{value};
    my $conf = $opts->{conf};

    my $rule = FS::MsgStructure::Rule->new($name, $conf);
    $conf->{msg_structure_plugin}->{__parse__} = $rule;

    $conf->{parser}->add_test ($name,
			       qq(msg_structure_plugin_rule("$name")),
			       $Mail::SpamAssassin::Conf::TYPE_FULL_EVALS);
    return $rule;
}

$parser{'define_structure'} = \&define_structure;


sub structure
{
    my ($self, $opts) = @_;

    my $rule = $opts->{conf}->{msg_structure_plugin}->{__parse__};
    ######## FIXME: maybe return Mail::SpamAssassin::Conf::INVALID_VALUE here?
    die ref($self), ": structure directive without define_structure"
	unless (defined $rule);
    #dbg("msgstruct: structure " . $opts->{value});
    return $rule->add_text ($opts->{value});
}

$parser{'structure'} = \&structure;


=back

=cut

sub parse_config
{
    my ($self, $opts) = @_;

    my $parser = $parser{$opts->{key}};
    if (defined $parser)
    {
	$self->$parser($opts) &&
	    return $self->inhibit_further_callbacks();
    }
    # else
    undef $opts->{conf}->{msg_structure_plugin}->{__parse__};
    return 0;
}


sub initialize_msg_structure_plugin
{
    my $self = shift;
    my $permsgstatus = shift;

    my $conf = $self->{conf};

    # If this is set, it's a signal that we are already initialized
    return 0 if (defined $conf->{msg_structure_plugin}->{__init_done__});

    # If this doesn't exist, we don't need to do anything
    if (defined $conf->{msg_structure_plugin}->{__init__})
    {
	dbg("msgstruct: Running initialize_msg_structure_plugin pseudo-rule");
	for my $rule (keys %{$conf->{msg_structure_plugin}->{rules}})
	{
	    $conf->{msg_structure_plugin}->{rules}->{$rule}->init();
	}
    }

    # We're done -- signal to self that we are a no-op now
    $conf->{msg_structure_plugin}->{__init_done__} = 1;

    return 0;
}

sub msg_structure_plugin_rule
{
    my $self = shift;
    my $permsgstatus = shift;
    my $messageref = shift;

    #my $name = $self->{name};
    ######## FIXME: somehow we're not being passed the current rule name :-(
    my $name = $permsgstatus->{current_rule_name};
    my $conf = $self->{conf};

    die "msg_structure_plugin_rule called without having been initialized\n"
	unless (defined $conf->{msg_structure_plugin}->{__init_done__});

    die "Unknown msg_structure_plugin_rule $name"
    	unless (defined $conf->{msg_structure_plugin}->{rules}->{$name});

    return $conf->{msg_structure_plugin}->{rules}->{$name}->
	eval($permsgstatus, $messageref);
}



*dbg = *Mail::SpamAssassin::Plugin::dbg;



package FS::MsgStructure::Rule;

=head1 CONFIGURATION DIRECTIVES

B<FS::MsgStructure> is supported
via the following configuration
directives.

=over 4

=item B<define_structure> I<rule_name>

Start the definition of a new structure rule,
and declare I<rule_name> to be its name.

The content of the rule will be the contents
of the B<structure> directives which follow.
See below.

=cut

my $ignore = <<'=cut';
It is an error to define an empty
structure.

=cut

sub new
{
    my $class = shift;
    my $self = bless { }, $class;

    my $name = shift;
    $self->{name} = $name;

    my $conf = shift;
    $self->{conf} = $conf;

    unless (defined $conf->{msg_structure_plugin}->{__init__})
    {
	$conf->{parser}->add_test ('__MSG_STRUCTURE_INIT__',
				   'initialize_msg_structure_plugin()',
				   $Mail::SpamAssassin::Conf::TYPE_HEAD_EVALS);
	$conf->{msg_structure_plugin}->{__init__} =
	    \$conf->{tests}->{'__MSG_STRUCTURE_INIT__'};
    }
	
    $conf->{msg_structure_plugin}->{rules}->{$name} = $self;

    $self->{text} = '';

    return $self;
}


=item B<structure> I<text>

Add the specified I<text>
to the structure being defined.

It is an error to invoke this directive
before any structure has been declared
with B<define_structure>.

The collected B<structure> directives
are compiled into one long regular expression
by simple concatenation, after
newlines and trailing spaces are trimmed off.

The regular expression is then evaluated
against the message body.
Technically the resulting rule is internally
a B<FULL_EVAL> rule, but it is transformed
so that any B<^> anchor matches on the
beginning of the body instead,
and B<$> matches against the end of the body.
Use B<\n> to match a newline within the body.

=cut


sub add_text
{
    my $self = shift;
    my $text = shift;
    #$text =~ s/%/\\\%/g;
    $self->{text} .= $text;
    #dbg("msgstruct: Adding to $self->{name} text: result is $self->{text}");
}


# This is called for each rule by eval:initialize_msg_structure_plugin()
sub init
{
    my $self = shift;

    my $conf = $self->{conf};
    my $name = $self->{name};
    my $eval;

    # Massage text into something closer to what we actually want
    my $regex = $self->preprocess ($self->{text});

    #dbg("msgstruct: initializing structure rule $name (regex is $regex)");
    if ($conf->{parser}->is_regexp_valid ($name, $regex))
    {
	# Eye candy for making evalstr slightly more human readable
	my $obj = '$obj';
	my $msgref = '$msgref';
	# More eye candy, slighly more tricky (not just identity)
	my $subname = "FS::MsgStructure::Rule::sub::$name";
	my $msg = '$$msgref';
	my $sub = '$eval';

	my $debug_maybe = '';
	$debug_maybe = 'dbg("rules: Match on $name ($regex): $&")'
	    if $::sa->{save_pattern_hits};

	# Gack, paste & rape of what's going on in PerMsgStatus
	my $evalstr = <<"________IOR";
	    sub $subname {
		my $obj = shift;
		my $msgref = shift;
		if ($msg =~ m{$regex}o)
		{
		    $debug_maybe;
		    return 1;
		}
		# else
		return 0;
	    };
	    1;
________IOR

	eval ($evalstr);
	if ($@)
	{
	    warn "Failed to compile msg_struct $name rule, skipping:\n",
		"\t($@)\n";
	}
	else
	{
	    $self->{eval} = \&$subname;
	}
    }
}

# Rewrite parts of a regular expression to better support our mental model
sub preprocess
{
    my $self = shift;
    my $regex = shift;

    # Translate ^ anchor to start of body regex
    $regex =~ s%^\^%^(?:(?:.+?\\n){0,100}\\n)%;

    return $regex;
}

# When the rule is actually evaluated with eval:msg_structure_plugin_rule(this)
sub eval
{
    my $self = shift;
    my $permsgstatus = shift;
    my $msgref = shift;

    #dbg("rules: Running $self->{text} against $$msgref");
    return $self->{eval}->($permsgstatus, $msgref);

    #my $message = $permsgstatus->get_message()->get_pristine();
    #return $message =~ $self->{regex};
}    

*dbg = *Mail::SpamAssassin::Plugin::dbg;

package FS::MsgStructure;

1;

=head1 BUGS

The plugin makes SpamAssassin
slightly slower, but not by much.

It would be nice to have a facility
for declaring regular expression macros.

=head1 COPYRIGHT

Copyright (C) 2004 F-Secure Corporation

=cut
