=head1 NAME

SentOutDB - provides eval test using info about sent mails.

=head1 SYNOPSIS

	loadplugin Mail::SpamAssassin::Plugin::SentOutDB /usr/local/etc/mail/spamassassin/plugins/SentOutDB.pm
  
	sentoutdb_sql_dsn       DBI:mysql:dbname:localhost
	sentoutdb_sql_username  user
	sentoutdb_sql_password  pass

	describe  SODB_REPLY           Reply to outgoing message
	header    SODB_REPLY           eval:sentoutdb_reply()
	score     SODB_REPLY           -2.0

	describe  SODB_PROBABLE_REPLY  Probably a reply to outgoing message
	header    SODB_PROBABLE_REPLY  eval:sentoutdb_probable_reply('exclusive')
	score     SODB_PROBABLE_REPLY  -1.0

	describe  SODB_POSSIBLE_REPLY  Might be a reply or DSN to outgoing message
	header    SODB_POSSIBLE_REPLY  eval:sentoutdb_possible_reply('exclusive')
	score     SODB_POSSIBLE_REPLY  -0.5

=head1 DESCRIPTION

This module provides eval tests that uses check a database to see if an
incoming mail seems to be a reply to an outgloing one.

=head1 REQUIREMENT

This plugin uses the database used by the MIMEDefang filter at

	http://whatever.frukt.org.

=head1 CONFIGURATION

=head2 Eval tests

=over

=item sentoutdb_reply

True if it is fairly certain that a message is a reply.

=item sentoutdb_probable_reply

True if a mail probably is a reply.

If a string with an X is sent as the first parameter, this will only be true if 
eval:sentoutdb_reply() isn't.

=item sentoutdb_possible_reply

True if a mail might be a reply.

If a string with an X is sent as the first parameter, this will only be true if 
eval:sentoutdb_reply() and eval:sentoutdb_probable_reply() isn't.

=back

=head2 Options

=over

=item sentoutdb_sql_dsn

Wich database driver and database to use.

=item sentoutdb_sql_username

User name for the database connection.

=item sentoutdb_sql_password

Password for the database connection.

=back

=cut

package Mail::SpamAssassin::Plugin::SentOutDB;

# $Id: SentOutDB.pm,v 1.7 2009/06/26 11:52:16 jonas Exp $

use strict;
use base 'Mail::SpamAssassin::Plugin';
use DBI;

sub dbg { 
	my $msg = shift;
	Mail::SpamAssassin::Plugin::dbg(sprintf("sentoutdb: $msg",@_));
}

sub new {
	my ($class,$mailsa) = @_;
	$class = ref($class) || $class;
	my $self = $class->SUPER::new($mailsa);
	bless($self,$class);
	$self->{sqldb} = undef;
	$self->register_eval_rule('sentoutdb_reply');
	$self->register_eval_rule('sentoutdb_probable_reply');
	$self->register_eval_rule('sentoutdb_possible_reply');
	$self->{main}->{conf}->{sentoutdb_sql_dsn} = 'DBI:mysql:mdf:localhost';
	$self->{main}->{conf}->{sentoutdb_sql_username} = 'sa';
	$self->{main}->{conf}->{sentoutdb_sql_password} = 'pwd';
	#dbg('registered');
	return $self;
}

sub parse_config {
	my ($self,$pars) = @_;
	return 0 if ($pars->{user_config});
	return 0 unless ($pars->{key} =~ /^sentoutdb_(sql_dsn|sql_username|sql_password)$/);
	my $key = $1;
	my $val = $pars->{value};
	$val = '' if ($key =~ /(username|password)/);
	$val = " = $val" if ($val);
	dbg('config %s%s',$key,$val);
	$self->{main}->{conf}->{$pars->{key}} = $pars->{value};
	$self->inhibit_further_callbacks();
	return 1;
}

sub _sql_connect {
	my ($self) = @_;
	return 1 if ($self->{sqldb});
	#dbg('sql connect');
	$self->{sqldb} = DBI->connect_cached(
				$self->{main}->{conf}->{sentoutdb_sql_dsn},
				$self->{main}->{conf}->{sentoutdb_sql_username},
				$self->{main}->{conf}->{sentoutdb_sql_password},
				{RaiseError=>0}
	);
	return 1 if ($self->{sqldb});
	dbg('sql connect failed');
	return 0;
}

sub _sql_disconnect {
	my ($self) = @_;
	if ($self->{sqldb}) {
		#dbg('sql disconnect');
		$self->{sqldb}->disconnect();
	}
	$self->{sqldb} = undef;
}

sub _sql_quote {
	my ($self,$s) = @_;
	#return $s unless ($self->_sql_connect());
	return $self->{sqldb}->quote($s);
}

sub _sql_select_one {
	my $self = shift;
	my $stamp = shift;
	return undef unless (@_);
	#return undef unless ($self->_sql_connect());
	my $where = '';
	while (@_) {
		$where .= ' AND ' if ($where);
		$where .= sprintf('(%s)',shift @_);
	}
	$stamp = 0 unless ($stamp);
	if ($self->{main}->{conf}->{sentoutdb_expire}) {
		my $ts = time-($self->{main}->{conf}->{sentoutdb_expire}*24*60*60);
		$stamp = $ts if ($ts > $stamp);
	}
	my $cmd = "SELECT out_stamp FROM sentout WHERE $where AND (out_stamp>$stamp) LIMIT 1";
	#dbg('sql %s',$cmd);
	my $st = $self->{sqldb}->prepare($cmd);
	unless ($st) {
		dbg('sql prepare failed');
		return undef;
	}
	$st->execute;
	my @res = $st->fetchrow_array;
	$st->finish;
	return undef unless (@res);
	#dbg('sql result %u',$res[0]);
	return $res[0];
}

sub _subject {
	my ($self,$pms) = @_;
	unless ($pms->{sentoutdb_got_subject}) {
		#dbg('get subject');
		$pms->{sentoutdb_got_subject} = 1;
		my $subj = $pms->get('Subject');
		$subj =~ s/[\r\n]+$//s;
		$subj =~ s/[\r\n]+/ /gs;
		#dbg('got subject "%s"',$subj);
		$subj =~ s/\s+/ /g;
		$subj =~ s/^\s+//;
		$subj =~ s/\s+$//;
		$subj =~ s/[^\x20-\x7E]/?/g;
		$subj =~ s/^(?:\[\S+\]\s*)?(?:\S{1,5}:\s*)?(?:\[\S+\]\s*)?(\S)/$1/;
		$subj = $self->_sql_quote($subj);
		dbg('got subject %s',$subj);
		$pms->{sentoutdb_subject} = "out_subject=$subj";
	}
	return $pms->{sentoutdb_subject};
}

sub _init_senders {
	my ($self,$pms) = @_;
	unless ($pms->{sentoutdb_got_senders}) {
		#dbg('get senders');
		$pms->{sentoutdb_got_senders} = 0;
		$pms->{sentoutdb_senders_dom} = '';
		$pms->{sentoutdb_senders_adr} = '';
		my %ga = ();
		my %gd = ();
		foreach my $hn (('EnvelopeFrom','From','Sender','Reply-To')) {
			my $aa = lc($pms->get("$hn:addr"));
			next unless ($aa);
			next if ($ga{$aa});
			$ga{$aa} = 1;
			if ($aa =~ /^(.+)\@(.+?)$/) {
				my $usr = $self->_sql_quote($1);
				my $dom = $self->_sql_quote($2);
				#dbg('got sender %s adress %s %s',$hn,$usr,$dom);
				$pms->{sentoutdb_senders_adr} .= ' OR ' if ($pms->{sentoutdb_senders_adr});
				$pms->{sentoutdb_senders_adr} .= "(out_rcpt_dom=$dom AND out_rcpt_usr=$usr)";
				$pms->{sentoutdb_got_senders} ++;
				next if ($gd{$dom});
				$gd{$dom} = 1;
				#dbg('got sender %s domain %s',$hn,$dom);
				$pms->{sentoutdb_senders_dom} .= ' OR ' if ($pms->{sentoutdb_senders_dom});
				$pms->{sentoutdb_senders_dom} .= "out_rcpt_dom=$dom";
			}
		}
		dbg('got senders %u',$pms->{sentoutdb_got_senders});
		$pms->{sentoutdb_got_senders} = -1 unless ($pms->{sentoutdb_got_senders});
	}
	return $pms->{sentoutdb_got_senders} if ($pms->{sentoutdb_got_senders} > 0);
	return 0;
}

sub _init_recipients {
	my ($self,$pms) = @_;
	unless ($pms->{sentoutdb_got_recipients}) {
		#dbg('get recipients');
		$pms->{sentoutdb_got_recipients} = 0;
		$pms->{sentoutdb_recipients_adr} = '';
		my %ga = ();
		my @al = $pms->get_message->header('Received');
		foreach my $rl (@al) {
			$rl =~ s/[\r\n]+$//s;
			$rl =~ s/[\r\n]+/ /gs;
			$rl =~ s/\s+/ /g;
			$rl =~ s/;.*?$//;
			if ($rl =~ /for <?(\S+?)>?\s*$/) {
				my $aa = lc($1);
				next unless ($aa);
				next if ($ga{$aa});
				$ga{$aa} = 1;
				$aa = $self->_sql_quote($aa);
				#dbg('got recipient %s %s','received',$aa);
				$pms->{sentoutdb_recipients_adr} .= ' OR ' if ($pms->{sentoutdb_recipients_adr});
				$pms->{sentoutdb_recipients_adr} .= "out_sender=$aa";
				$pms->{sentoutdb_got_recipients} ++;
			}
		}
		@al = ();
		foreach my $hn (('Envelope-To','Delivered-To','Apparently-To','To','Cc')) {
			my $ax = $pms->get($hn);
			next unless ($ax);
			$ax =~ s/[\r\n]+$//s;
			$ax =~ s/[\r\n]+/ /gs;
			$ax =~ s/^[^:]+:(.*);\s*$/$1/g;
			$ax =~ s/\s+/ /g;
			$ax =~ s/^\s+//;
			$ax =~ s/\s+$//;
			$ax =~ s/\s*\(.*?\)//g;
			$ax =~ s/(?<!<)"[^"]*"(?!@)//g;
			next unless ($ax);
			foreach my $aa (split(/\s*,\s*/,lc($ax))) {
				$aa =~ s/^[^<]*?<(.*?)>.*$/$1/;
				next unless ($aa);
				next if ($ga{$aa});
				$ga{$aa} = 1;
				$aa = $self->_sql_quote($aa);
				#dbg('got recipient %s %s',$hn,$aa);
				$pms->{sentoutdb_recipients_adr} .= ' OR ' if ($pms->{sentoutdb_recipients_adr});
				$pms->{sentoutdb_recipients_adr} .= "out_sender=$aa";
				$pms->{sentoutdb_got_recipients} ++;
			}
		}
		dbg('got recipients %u',$pms->{sentoutdb_got_recipients});
		$pms->{sentoutdb_got_recipients} = -1 unless ($pms->{sentoutdb_got_recipients});
	}
	return $pms->{sentoutdb_got_recipients} if ($pms->{sentoutdb_got_recipients} > 0);
	return 0;
}

sub _init_references {
	my ($self,$pms) = @_;
	unless ($pms->{sentoutdb_got_references}) {
		#dbg('get references');
		$pms->{sentoutdb_got_references} = 0;
		$pms->{sentoutdb_references_mid} = '';
		my %gi = ();
		foreach my $hn(('References','In-Reply-To')) {
			my $ix = $pms->get($hn);
			next unless ($ix);
			foreach my $hid (split(/\s+/,$ix)) {
				if ($hid =~ /^\s*<(.+)>\s*$/) {
					$hid = $self->_sql_quote($1);
					next if ($gi{$hid});
					$gi{$hid} = 1;
					#dbg('got reference %s %s',$hn,$hid);
					$pms->{sentoutdb_references_mid} .= ' OR ' if ($pms->{sentoutdb_references_mid});
					$pms->{sentoutdb_references_mid} .= "out_id=$hid";
					$pms->{sentoutdb_got_references} ++;
				}
			}
		}
		dbg('got references %u',$pms->{sentoutdb_got_references});
		$pms->{sentoutdb_got_references} = -1 unless ($pms->{sentoutdb_got_references});
	}
	return $pms->{sentoutdb_got_references} if ($pms->{sentoutdb_got_references} > 0);
	return 0;
}

sub _sentoutdb_reply {
	my ($self,$pms) = @_;
	return 0 unless ($self->_init_senders($pms));
	return 0 unless ($self->_init_recipients($pms));
	return 0 unless ($self->_init_references($pms));
	dbg('try reply');
	return 1 if ($self->_sql_select_one(0,$pms->{sentoutdb_references_mid},$pms->{sentoutdb_senders_dom},$pms->{sentoutdb_recipients_adr}));
	dbg('not reply');
	return 0;
}

sub _sentoutdb_probable_reply_cnv {
	my ($self,$pms) = @_;
	return 0 unless ($self->_init_senders($pms));
	return 0 unless ($self->_init_recipients($pms));
	#dbg('try probable reply cnv');
	return 1 if ($self->_sql_select_one(0,$pms->{sentoutdb_recipients_adr},$pms->{sentoutdb_senders_adr},$self->_subject($pms)));
	#dbg('not probable reply cnv');
	return 0;
}
sub _sentoutdb_probable_reply_mid {
	my ($self,$pms) = @_;
	return 0 unless ($self->_init_senders($pms));
	return 0 unless ($self->_init_references($pms));
	#dbg('try probable reply mid');
	return 1 if ($self->_sql_select_one(0,$pms->{sentoutdb_references_mid},$pms->{sentoutdb_senders_adr}));
	#dbg('not probable reply mid');
	return 0;
}
sub _sentoutdb_probable_reply {
	my ($self,$pms) = @_;
	dbg('try probable reply');
	return 1 if ($self->_sentoutdb_probable_reply_cnv($pms));
	return 1 if ($self->_sentoutdb_probable_reply_mid($pms));
	dbg('not probable reply');
	return 0;
}

sub _sentoutdb_possible_reply_cnv {
	my ($self,$pms) = @_;
	return 0 unless ($self->_init_senders($pms));
	return 0 unless ($self->_init_recipients($pms));
	#dbg('try possible reply cnv 1');
	return 1 if ($self->_sql_select_one(0,$pms->{sentoutdb_recipients_adr},$pms->{sentoutdb_senders_dom},$self->_subject($pms)));
	#dbg('try possible reply cnv 2');
	return 1 if ($self->_sql_select_one(0,$pms->{sentoutdb_recipients_adr},$pms->{sentoutdb_senders_adr}));
	#dbg('not possible reply cnv');
	return 0;
}
sub _sentoutdb_possible_reply_mid {
	my ($self,$pms) = @_;
	return 0 unless ($self->_init_senders($pms));
	return 0 unless ($self->_init_references($pms));
	#dbg('try possible reply mid');
	return 1 if ($self->_sql_select_one(0,$pms->{sentoutdb_references_mid},$pms->{sentoutdb_senders_dom}));
	#dbg('not possible reply mid');
	return 0;
}
sub _sentoutdb_possible_reply_dsn {
	my ($self,$pms) = @_;
	return 0 unless ($self->_init_senders($pms));
	return 0 unless ($self->_init_recipients($pms));
	return 0 if ($pms->get('EnvelopeFrom:addr'));
	#dbg('try possible reply dsn');
	return 1 if ($self->_sql_select_one(time()-(8*24*60*60),$pms->{sentoutdb_senders_dom},$pms->{sentoutdb_recipients_adr}));
	#dbg('not possible reply dsn');
	return 0;
}
sub _sentoutdb_possible_reply {
	my ($self,$pms) = @_;
	dbg('try possible reply');
	return 1 if ($self->_sentoutdb_possible_reply_cnv($pms));
	return 1 if ($self->_sentoutdb_possible_reply_mid($pms));
	return 1 if ($self->_sentoutdb_possible_reply_dsn($pms));
	dbg('not possible reply');
	return 0;
}

sub sentoutdb_reply {
	my ($self,$pms) = @_;
	return $pms->{sentoutdb_reply} if (defined($pms->{sentoutdb_reply}));
	return 0 unless ($self->_sql_connect());
	$pms->{sentoutdb_reply} = $self->_sentoutdb_reply($pms);
	$self->_sql_disconnect();
	dbg('eval reply %u',$pms->{sentoutdb_reply});
	return $pms->{sentoutdb_reply};
}

sub sentoutdb_probable_reply {
	my ($self,$pms,$pars) = @_;
	return 0 if ($pars && $pars =~ /[Xx]/ && $self->sentoutdb_reply($pms));
	return $pms->{sentoutdb_probable_reply} if (defined($pms->{sentoutdb_probable_reply}));
	$pms->{sentoutdb_probable_reply} = 1 if ($pms->{sentoutdb_reply});
	unless ($pms->{sentoutdb_probable_reply}) {
		return 0 unless ($self->_sql_connect());
		$pms->{sentoutdb_probable_reply} = $self->_sentoutdb_probable_reply($pms);
		$self->_sql_disconnect();
	}
	dbg('eval probable reply %u',$pms->{sentoutdb_probable_reply});
	return $pms->{sentoutdb_probable_reply};
}

sub sentoutdb_possible_reply {
	my ($self,$pms,$pars) = @_;
	return 0 if ($pars && $pars =~ /[Xx]/ && ($self->sentoutdb_reply($pms) || $self->sentoutdb_probable_reply($pms)));
	return $pms->{sentoutdb_possible_reply} if (defined($pms->{sentoutdb_possible_reply}));
	$pms->{sentoutdb_possible_reply} = 1 if ($pms->{sentoutdb_reply} || $pms->{sentoutdb_probable_reply});
	unless ($pms->{sentoutdb_possible_reply}) {
		return 0 unless ($self->_sql_connect());
		$pms->{sentoutdb_possible_reply} = $self->_sentoutdb_possible_reply($pms);
		$self->_sql_disconnect();
	}
	dbg('eval possible reply %u',$pms->{sentoutdb_possible_reply});
	return $pms->{sentoutdb_possible_reply};
}

1;