#!perl -Tw

=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?  :-)  It looks like this in practice:

  spamassassin reject_threshold 7 leave_old_headers keep

=over 4

=item reject_threshold [threshold]

Set the threshold where 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. 

Depending on your spamassassin configuration a reasonable setting is
typically somewhere between 12 to 20.

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

=item munge_subject_threshold [threshold]

Set the threshold where the plugin will prefix the subject with the
value of C<subject_prefix>. A modified 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 subject_prefix [prefix]

What to prefix the subject with if the message is detected as spam
(i.e. if score is greater than C<munge_subject_threshold>.  Defaults to
C<*** SPAM ***>

=item spamd_socket [/path/to/socket|spamd.host:port]

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, but if you run spamd on a remote machine, you need to
use 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').

=item spamd_user [username]

The username to pass to spamd, if different from the user qpsmtpd runs as.

=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 Qpsmtpd::DSN;
use Socket qw(:DEFAULT :crlf);
use IO::Handle;

sub register {
  my ($self, $qp, @args) = @_;

  $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 hook_data_post { # check_spam
  my ($self, $transaction) = @_;

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

  my $remote  = 'localhost';
  my $port    = 783;
  if (defined $self->{_args}->{spamd_socket}
      && $self->{_args}->{spamd_socket} =~ /^([\w.-]+):(\d+)$/) {
    $remote  = $1;
    $port    = $2;
  }
  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 = $self->{_args}->{spamd_user} || 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) {
    $line0 =~ s/\r?\n$//;
    $self->log(LOGDEBUG, "check_spam: spamd: $line0");

    $self->_cleanup_spam_header($transaction, 'X-Spam-Check-By');

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


  my ($flag, $hits, $required);
  while (<SPAMD>) {
    s/\r?\n$//;
    $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>|| '';
  close SPAMD;
  $tests =~ s/\015//;  # hack for outlook
  $flag = $flag eq 'True' ? 'Yes' : 'No';
  $self->log(LOGDEBUG, "check_spam: finished reading from spamd");

  $self->_cleanup_spam_header($transaction, 'X-Spam-Flag');
  $self->_cleanup_spam_header($transaction, 'X-Spam-Status');
  $self->_cleanup_spam_header($transaction, 'X-Spam-Level');

  $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);

  my $length = int($hits);
  $length = 1 if $length < 1;
  $length = 50 if $length > 50;
  $transaction->header->add('X-Spam-Level', '*' x $length, 0);

  $self->log(LOGNOTICE, "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");

  # default of media_unsupported is DENY, so just change the message
  return Qpsmtpd::DSN->media_unsupported("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_prefix = $self->qp->config('subject_prefix') || '*** SPAM ***';
  my $subject = $transaction->header->get('Subject') || '';
  $transaction->header->replace('Subject', "$subject_prefix $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;


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

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

  return unless $action eq 'drop' or $action eq 'rename';

  my $old_header_name = $header_name;
  $old_header_name = ($old_header_name =~ s/^X-//) ? "X-Old-$old_header_name" : "Old-$old_header_name";

  for my $header ( $transaction->header->get($header_name) ) {
      $transaction->header->add($old_header_name, $header) if $action eq 'rename';
      $transaction->header->delete($header_name);
  }
  
        
}


}