package Apache::SpamD;

use 5.008001;
use strict;
use warnings;

use Apache::Connection();
use Apache::Const -compile => 'OK';
use APR::Socket ();

our $VERSION = '0.01';

my %resphash = (
  EX_OK          => 0,     # no problems
  EX_USAGE       => 64,    # command line usage error
  EX_DATAERR     => 65,    # data format error
  EX_NOINPUT     => 66,    # cannot open input
  EX_NOUSER      => 67,    # addressee unknown
  EX_NOHOST      => 68,    # host name unknown
  EX_UNAVAILABLE => 69,    # service unavailable
  EX_SOFTWARE    => 70,    # internal software error
  EX_OSERR       => 71,    # system error (e.g., can't fork)
  EX_OSFILE      => 72,    # critical OS file missing
  EX_CANTCREAT   => 73,    # can't create (user) output file
  EX_IOERR       => 74,    # input/output error
  EX_TEMPFAIL    => 75,    # temp failure; user is invited to retry
  EX_PROTOCOL    => 76,    # remote error in protocol
  EX_NOPERM      => 77,    # permission denied
  EX_CONFIG      => 78,    # configuration error
);


sub getline {
  my $socket = shift;
  
  my $line;
  $socket->recv($line, 1024);
  return unless $line;
  $line =~ s/[\r\n]*$//;
  
  return $line;
}

sub handler {
  my $c = shift;

  my $socket = $c->client_socket;

  local ($_) = getline($socket);

  if ( !defined $_ ) {
    protocol_error($socket, "(closed before headers)");
    return Apache::OK;
  }

  s/\r?\n//;

  # It may be a SKIP message, meaning that the client (spamc)
  # thinks it is too big to check.  So we don't do any real work
  # in that case.

  if (/PING SPAMC\/(.*)/) {
    send_ping($socket);
  }
  elsif (/(PROCESS|CHECK|SYMBOLS|REPORT|REPORT_IFSPAM) SPAMC\/(.*)/) {
    check( $socket, $1, $2, $start, $remote_hostname, $remote_hostaddr );
  }
  else {
    protocol_error($socket,$_);
  }

  return Apache::OK;
}

sub check {
  my ($socket, $method, $version) = @_;

  local ($_);

  my $hdrs = parse_headers($socket, {
				     'Content-length' => \&validate_numeric_header,
				     'User'           => \&got_user_header
				    });

  # parse_headers will return undef on error
  unless (defined($hdrs)) {
    return 1;
  }

  my $expected_length = $hdrs->{Content-length};

  if ( $opt{'sql-config'} && !defined($current_user) ) {
    unless (handle_user_sql('nobody')) {
      service_unavailable_error("Error fetching user preferences via SQL");
      return 1;
    }
  }

  my $resp = "EX_OK";

  # Now read in message
  my @msglines;
  my $actual_length = 0;
  while ($_ = getline($socket)) {
    $actual_length += length($_);
    push(@msglines, $_);    
    last if (defined $expected_length && $actual_length >= $expected_length);
  }
  
  # Now parse *only* the message headers; the MIME tree won't be generated 
  # yet, check() will do this on demand later on.
  my $mail = $spamtest->parse(\@msglines, 0);
  # Free some mem.
  undef @msglines;

  # Check length if we're supposed to.
  if ( defined $expected_length && $actual_length != $expected_length ) {
    protocol_error(
      "(Content-Length mismatch: Expected $expected_length bytes, got $actual_length bytes)"
    );
    $mail->finish();
    return 1;
  }

  # Go ahead and check the message
  my $status = $spamtest->check($mail);

  my $msg_score     = sprintf( "%.1f", $status->get_score );
  my $msg_threshold = sprintf( "%.1f", $status->get_required_score );

  my $response_spam_status = "";
  if ( $status->is_spam ) {
    $response_spam_status = $method eq "REPORT_IFSPAM" ? "Yes" : "True";
  }
  else {
    $response_spam_status = $method eq "REPORT_IFSPAM" ? "No" : "False";
  }

  my $spamhdr = "Spam: $response_spam_status ; $msg_score / $msg_threshold";
  if ( $method eq 'PROCESS' ) {
    $status->set_tag('REMOTEHOSTNAME', $remote_hostname);
    $status->set_tag('REMOTEHOSTADDR', $remote_hostaddr);

    # Build the message to send back and measure it
    my $msg_resp        = $status->rewrite_mail();
    my $msg_resp_length = length($msg_resp);

    $socket->send("SPAMD/1.1 $resphash{$resp} $resp\r\n",
		  "Content-length: $msg_resp_length\r\n$spamhdr\r\n\r\n$msg_resp");
  }
  elsif ($method eq "CHECK") { # $method eq 'CHECK' et al
    $socket->send("SPAMD/1.1 $resphash{$resp} $resp\r\n$spamhdr\r\n\r\n");
  }
  elsif ($method eq "REPORT") {
    my $msg_resp = $status->get_report();
    $socket->send("SPAMD/1.1 $resphash{$resp} $resp\r\n",
		  "Content-length: %d\r\n%s\r\n\r\n%s", length($msg_resp), $spamhdr, $msg_resp);
  }
  elsif ($method eq "REPORT_IFSPAM") {
    my $msg_resp = '';
    if ($status->is_spam()) {
      $msg_resp = $status->get_report();
    }
    $socket->send("SPAMD/1.1 $resphash{$resp} $resp\r\n",
		  "Content-length: %d\r\n%s\r\n\r\n%s", length($msg_resp), $spamhdr, $msg_resp);
  }
  elsif ($method eq "SYMBOLS") {
    $msg_resp = $status->get_names_of_tests_hit;
    $msg_resp .= "\r\n";
    $socket->send("SPAMD/1.1 $resphash{$resp} $resp\r\n",
		  "Content-length: %d\r\n%s\r\n\r\n%s", length($msg_resp), $spamhdr, $msg_resp);
  }
  else {
    protocol_error(XXX);
  }

  $status->finish();    # added by jm to allow GC'ing
  $mail->finish();
}

sub parse_headers {
  my ($socket, $subs) = @_;

  my $hdrs;

  # max 255 headers
  for my $hcount ( 0 .. 255 ) {
    my $line = getline($socket);
    if ( !defined $line ) {
      protocol_error("(EOF during headers)");
      return undef;
    }
    $line =~ s/\r\n$//;
    if ( !$line ) {
      return $hdrs;
    }

    my ( $header, $value ) = split ( /:\s*/, $line, 2 );
    if ( !defined $value ) {
      protocol_error("(header not in 'Name: value' format)");
      return undef;
    }

    my $ent = $subs->{$header};
    if (defined($ent)) {
      $hdrs->{$header} = &{$ent}($socket, $header, $value) ) {
      return undef if (!defined($hdrs->{$header}));
    }
  }

  # avoid too-many-headers DOS attack
  protocol_error("(too many headers)");
  return undef;
}

sub valididate_numeric_header {
  my ($socket, $header, $value) = @_;

  if ($value !~ /^(\d*)$/) {
    protocol_error($socket, "($header contains non-numeric bytes)");
    return undef;
  }
  return $value;
}

sub got_user_header {
  my ($socket, $header, $value) = @_;

  if ( $value !~ /^([\x20-\xFF]*)$/ ) {
    protocol_error($socket, "($header header contains control chars)");
    return 1;
  }

  $current_user = $1;

  unless ( handle_user_sql($current_user) ) {
    service_unavailable_error("Error fetching user preferences via SQL");
    return undef;
  }

  return 0;
}

sub send_ping {
  my ($socket) = @_;

  $socket->send("SPAMD/1.2 $resphash{EX_OK} PONG\r\n");

  return;
}


sub protocol_error {
  my ($socket, $err) = @_;
  my $resp = "EX_PROTOCOL";
  $socket->send("SPAMD/1.0 $resphash{$resp} Bad header line: $err\r\n");
}



1;
__END__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

Apache::SpamD - Perl extension for blah blah blah

=head1 SYNOPSIS

  use Apache::SpamD;
  blah blah blah

=head1 DESCRIPTION

Stub documentation for Apache::SpamD, created by h2xs. It looks like the
author of the extension was negligent enough to leave the stub
unedited.

Blah blah blah.

=head2 EXPORT

None by default.



=head1 SEE ALSO

Mention other useful documentation such as the documentation of
related modules or operating system documentation (such as man pages
in UNIX), or any relevant external documentation such as RFCs or
standards.

If you have a mailing list set up for your module, mention it here.

If you have a web site set up for your module, mention it here.

=head1 AUTHOR

Michael Parker, E<lt>parker@suse.deE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2004 by Michael Parker

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.1 or,
at your option, any later version of Perl 5 you may have available.


=cut