qpsmtpd/plugins/spamassassin

=head1 NAME

spamassassin - SpamAssassin integration for qpsmtpd

=head1 DESCRIPTION

Plugin that checks if the mail is spam by using the "spamd" daemon
from the SpamAssassin package.  F<http://www.spamassassin.org>

SpamAssassin 2.6 or newer is required.

=head1 CONFIG

Configured in the plugins file without any parameters, the
spamassassin plugin will add relevant headers from the spamd
(X-Spam-Status etc).

The format goes like

  spamassassin  option value  [option value]

Options being those listed below and the values being parameters to
the options.  Confused yet?  :-)

=over 4

=item reject_threshold [threshold]

Set the threshold over which the plugin will reject the mail.  Some
mail servers are so useless that they ignore 55x responses not coming
after RCPT TO, so they might just keep retrying and retrying and
retrying until the mail expires from their queue. 

I like to configure this with 15 or 20 as the threshold.  

The default is to never reject mail based on the SpamAssassin score.

=item munge_subject_threshold [threshold]

Set the threshold over which we will prefix the subject with
'***SPAM***'.  A messed up subject is easier to filter on than the
other headers for many people with not so clever mail clients.  You
might want to make another plugin that does this on a per user basis.

The default is to never munge the subject based on the SpamAssassin score.

=item spamd_socket [/path/to/socket]

Beginning with Mail::SpamAssassin 2.60, it is possible to use Unix 
domain sockets for spamd.  This is faster and more secure than using
a TCP connection.

=item leave_old_headers [drop|rename|keep]

Another mail server before might have checked this mail already and may have
added X-Spam-Status, X-Spam-Flag and X-Spam-Check-By lines. Normally you can
not trust such headers and should either rename them to X-Old-... (default,
parameter 'rename') or have them removed (parameter 'drop'). If you know
what you are doing, you can also leave them intact (parameter 'keep').

=back

With both of the first options the configuration line will look like the following

 spamasssasin  reject_threshold 18  munge_subject_threshold 8

=head1 TODO

Make the "subject munge string" configurable

=cut


use Socket qw(:DEFAULT :crlf);
use IO::Handle;

sub register {
  my ($self, $qp, @args) = @_;
  $self->register_hook("data_post", "check_spam");

  $self->log(LOGERROR, "Bad parameters for the spamassassin plugin")
    if @_ % 2;

  %{$self->{_args}} = @args;

  $self->register_hook("data_post", "check_spam_reject")
    if $self->{_args}->{reject_threshold};

  $self->register_hook("data_post", "check_spam_munge_subject")
    if $self->{_args}->{munge_subject_threshold};

}

sub check_spam {
  my ($self, $transaction) = @_;

  $self->log(LOGDEBUG, "check_spam");
  return (DECLINED) if $transaction->body_size > 500_000;

  my $leave_old_headers = lc($self->{_args}->{leave_old_headers}) || 'rename';

  my $remote  = 'localhost';
  my $port    = 783;
  if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
  die "No port" unless $port;
  my $iaddr   = inet_aton($remote) or 
    $self->log(LOGERROR, "Could not resolve host: $remote") and return (DECLINED);
  my $paddr   = sockaddr_in($port, $iaddr);

  my $proto   = getprotobyname('tcp');
  if ($self->{_args}->{spamd_socket} and
      $self->{_args}->{spamd_socket} =~ /^([\w\/.-]+)$/ ) { # connect to Unix Domain Socket
    my $spamd_socket = $1;
    
    socket(SPAMD, PF_UNIX, SOCK_STREAM, 0)
      or $self->log(LOGERROR, "Could not open socket: $!") and return (DECLINED);

    $paddr = sockaddr_un($spamd_socket); 
  }
  else {
    socket(SPAMD, PF_INET, SOCK_STREAM, $proto)
      or $self->log(LOGERROR, "Could not open socket: $!") and return (DECLINED);
  }

  connect(SPAMD, $paddr) 
    or $self->log(LOGERROR, "Could not connect to spamassassin daemon: $!") and return DECLINED;
  $self->log(LOGDEBUG, "check_spam: connected to spamd");

  SPAMD->autoflush(1);
  
  $transaction->body_resetpos;
  my $username = getpwuid($>);

  print SPAMD "SYMBOLS SPAMC/1.3" . CRLF;
  print SPAMD "User: $username" . CRLF;
       # Content-Length: 
  print SPAMD  CRLF;
  # or CHECK or REPORT or SYMBOLS

  print SPAMD "X-Envelope-From: ", $transaction->sender->format, CRLF
    or $self->log(LOGWARN, "Could not print to spamd: $!");

  print SPAMD join CRLF, split /\n/, $transaction->header->as_string
    or $self->log(LOGWARN, "Could not print to spamd: $!");

  print SPAMD CRLF
    or $self->log(LOGWARN, "Could not print to spamd: $!");

  while (my $line = $transaction->body_getline) {
    chomp $line;
    print SPAMD $line, CRLF
      or $self->log(LOGWARN, "Could not print to spamd: $!");
  }

  print SPAMD CRLF;
  shutdown(SPAMD, 1);
  $self->log(LOGDEBUG, "check_spam: finished sending to spamd");
  my $line0 = <SPAMD>; # get the first protocol lines out
  if ($line0) {
    $self->log(LOGDEBUG, "check_spam: spamd: $line0");

    if ( $leave_old_headers eq 'rename' )
    {
      foreach my $header ( $transaction->header->get('X-Spam-Check-By') )
      {
        $transaction->header->add('X-Old-Spam-Check-By', $header);
      }
    }
    
    if ( $leave_old_headers eq 'drop' || $leave_old_headers eq 'rename' )
    {
      $transaction->header->delete('X-Spam-Check-By');
    }

    $transaction->header->add("X-Spam-Check-By", $self->qp->config('me'), 0);
  }

  my ($flag, $hits, $required);
  while (<SPAMD>) {
    $self->log(LOGDEBUG, "check_spam: spamd: $_");
    #warn "GOT FROM SPAMD1: $_";
    last unless m/\S/;
    if (m{Spam: (True|False) ; (-?\d+\.\d) / (-?\d+\.\d)}) {
	($flag, $hits, $required) = ($1, $2, $3);
    }

  }
  my $tests = <SPAMD>;
  $tests =~ s/\015//;  # hack for outlook
  $flag = $flag eq 'True' ? 'Yes' : 'No';
  $self->log(LOGDEBUG, "check_spam: finished reading from spamd");

  if ( $leave_old_headers eq 'rename' )
  {
    foreach my $header ( $transaction->header->get('X-Spam-Flag') )
    {
      $transaction->header->add('X-Old-Spam-Flag', $header);
    }

    foreach my $header ( $transaction->header->get('X-Spam-Status') )
    {
      $transaction->header->add('X-Old-Spam-Status', $header);
    }
  }
    
  if ( $leave_old_headers eq 'drop' || $leave_old_headers eq 'rename' )
  {
    $transaction->header->delete('X-Spam-Flag');
    $transaction->header->delete('X-Spam-Status');
  }

  $transaction->header->add('X-Spam-Flag', 'YES', 0) if ($flag eq 'Yes');
  $transaction->header->add('X-Spam-Status',
			    "$flag, hits=$hits required=$required\n" .
			    "\ttests=$tests", 0);
  $self->log(5, "check_spam: $flag, hits=$hits, required=$required, " .
			     "tests=$tests");

  return (DECLINED);
}

sub check_spam_reject {
  my ($self, $transaction) = @_;

  $self->log(LOGDEBUG, "check_spam_reject: reject_threshold=" . $self->{_args}->{reject_threshold});
  my $score = $self->get_spam_score($transaction) or return DECLINED;  
  $self->log(LOGDEBUG, "check_spam_reject: score=$score");

  return (DENY, "spam score exceeded threshold")
    if $score >= $self->{_args}->{reject_threshold};

  $self->log(LOGDEBUG, "check_spam_reject: passed");
  return DECLINED;
}


sub check_spam_munge_subject {
  my ($self, $transaction) = @_;
  my $score = $self->get_spam_score($transaction) or return DECLINED;  

  return DECLINED unless $score >= $self->{_args}->{munge_subject_threshold};

  my $subject = $transaction->header->get('Subject') || '';
  $transaction->header->replace('Subject', "***SPAM*** $subject");

  return DECLINED;
}

sub get_spam_score {
  my ($self, $transaction) = @_;
  my $status  = $transaction->header->get('X-Spam-Status') or return; 
  my ($score) = ($status =~ m/hits=(-?\d+\.\d+)/)[0];
  return $score;
}