package Mail::SpamAssassin::Spamd::Apache2;
use strict;

use Apache2::Const -compile =>
  qw(OK FORBIDDEN NOT_FOUND MODE_GETLINE MODE_READBYTES SERVER_ERROR);
use Apache2::Connection ();
use Apache2::Filter     ();
use Apache2::Module     ();
use Apache2::ServerRec  ();
use Apache2::ServerUtil ();

use APR::Const -compile => qw(SUCCESS SO_NONBLOCK BLOCK_READ);
use APR::Brigade  ();
use APR::Bucket   ();
use APR::Error    ();
use APR::Pool     ();    # cleanup_register
use APR::SockAddr ();
use APR::Socket   ();
use APR::Status   ();
use Apache::Test;
use constant APACHE24   => have_min_apache_version('2.4.0');

eval { use Time::HiRes qw(time); };

our $spamtest;

use Mail::SpamAssassin ();
use Mail::SpamAssassin::Message ();
use Mail::SpamAssassin::PerMsgStatus ();
use Mail::SpamAssassin::Logger;

use base qw(Mail::SpamAssassin::Spamd);

=head1 NAME

Mail::SpamAssassin::Spamd::Apache2 -- spamd protocol handler for Apache2

=head1 SYNOPSIS

  SetHandler modperl
  PerlProcessConnectionHandler Mail::SpamAssassin::Spamd::Apache2

=head1 DESCRIPTION

What is this obsession with documentation?  Don't you have the source?
                           -- Michael G Schwern on makemaker@perl.org

This is a protocol handler, to be run as C<PerlProcessConnectionHandler>.  It's
different from regular HTTP handlers (C<PerlResponseHandler>) -- we don't have
the C<$r> object (unless we create it) and the only other run-time Apache hook
which will run is C<PerlPreConnectionHandler>.

This means you can't use modules which hook themselves in, for example,
C<PerlAccessHandler>.  If there is a clean way to enable it, don't hesitate to
drop me an e-mail.

=head1 INTERNALS

handler() runs read_headers(), then check_headers().  If the User header has
been provided by the client and user configuration has been enabled, it runs
read_user_config().  Then it reads body, passes it through SA and sends reply.

=cut

sub handler { # -: c
  my ($c) = @_;    # Apache2::Connection
  $c->client_socket->opt_set(APR::Const::SO_NONBLOCK => 0);    # ?

  my $self = __PACKAGE__->new(c => $c, spamtest => $spamtest, pool => $c->pool);
  $self->log_connection;

  # we might be done after this in case of client error or SKIP / PING
  if (defined(my $ret = $self->read_headers)) {
    return $ret;
  }

  $self->check_headers
    or return Apache2::Const::FORBIDDEN;

  # should we complain if returns 0 and --paranoid?
  $self->read_user_config;

  if (defined(my $ret = $self->read_body)) {
    return $ret;
  }

  $self->parse_msgids;

  $self->log_start_work;

  eval {
    if ($self->cfg->{satimeout}) {
      local $SIG{ALRM} = sub { die 'child processing timeout' };
      alarm $self->cfg->{satimeout};
      $self->pass_through_sa; # do the checking
      alarm 0;
    }
    else {
      $self->pass_through_sa; # do the checking
    }
  };

  if ($@) {
    if ( $@ =~ /child processing timeout/ ) {
      $self->service_timeout(
        sprintf '(%d second timeout while trying to %s)',
        $self->cfg->{satimeout},
        $self->{method}
      );
    }
    else {
      warn "spamd: $@";
    }
    return Apache2::Const::SERVER_ERROR;
  }

  $self->send_status_line('EX_OK');
  $self->send_response;
  $self->log_end_work;
  $self->log_result;

  return Apache2::Const::OK;
}



sub new {    # -: A
  my $class = shift;
  my $self  = {@_};    # requires: c, spamtest
  $self->{start_time} ||= time;
  bless $self, (ref $class || $class);
  ##$self->{c} ||= $self->r->connection if $self->r;
  $self->{in}  ||= APR::Brigade->new($self->c->pool, $self->c->bucket_alloc);
  $self->{out} ||= APR::Brigade->new($self->c->pool, $self->c->bucket_alloc);
  $self->{cfg} ||=
    Apache2::Module::get_config('Mail::SpamAssassin::Spamd::Apache2::Config',
    $self->_server);
  $self->{headers_in} ||= {};
  $self;
}


sub DESTROY { # -: a
  my $self = shift;
  if (exists $self->{parsed}) {
    delete $self->{parsed};
    $self->{parsed}->finish if $self->{parsed}; # can't do it before status->rewrite_mail
  }
  if (exists $self->{status}) {
    $self->status->finish if $self->status;
    delete $self->{status};
  }
  $self->in->destroy;
  $self->out->destroy;
}


sub c       { $_[0]->{c} }          # -: A
sub in      { $_[0]->{in} }         # -: a
sub out     { $_[0]->{out} }        # -: a

sub _server      { $_[0]->c->base_server }          # -: a
sub _remote_host { $_[0]->c->get_remote_host }      # -: a
sub _remote_ip   { APACHE24 ? $_[0]->c->client_ip : $_[0]->c->remote_ip; }            # -: a
sub _remote_port { APACHE24 ? $_[0]->c->client_addr->port : $_[0]->c->remote_addr->port }    # -: a


sub send_buffer { # -: A
  my $self = shift;
  for my $buffer (@_) {
    $self->out->insert_tail(APR::Bucket->new($self->out->bucket_alloc, $buffer));
  }
  $self->c->output_filters->fflush($self->out);
}


sub auth_ident { # -: 
  my $self = shift;
  my ($username) = @_;
  my $ident_username =
    Mail::SpamAssassin::Spamd::Apache2::AclRFC1413::get_ident($username);
  my $dn = $ident_username || 'NONE';    # display name
  # we might also log $c->remote_addr->ip_get(), $c->remote_addr->port()
  # dbg("ident: ident_username = $dn, spamc_username = $username\n");
  if (!defined($ident_username) || $username ne $ident_username) {
    info( "ident username ($dn) does not match "
        . "spamc username ($username)");
    return 0;
  }
  1;
}


#sub read_line {  # -: A
#  my $self = shift;
#}


sub getline {
  my $self = shift;
  my $rc   =
    $self->c->input_filters->get_brigade($self->in,
    Apache2::Const::MODE_GETLINE);
  last if APR::Status::is_EOF($rc);
  die APR::Error::strerror($rc) unless $rc == APR::Const::SUCCESS;
  next unless $self->in->flatten(my $line);
  $self->in->cleanup;
  $line =~ y/\r\n//d;
  return $line;
}



sub read_headers { # -: A
  my $self = shift;
  my $line_num;
  while (my $line = $self->getline) {

    # XXX: lower this to 10?
    if (++$line_num > 255) {
      $self->protocol_error('(too many headers)');
      return Apache2::Const::FORBIDDEN;
    }

    if (length $line > 200) {
      $self->protocol_error('(line too long)' . length $line);
      return Apache2::Const::FORBIDDEN;
    }

    # get method name
    unless ($self->{method}) {
      if ($line =~ /^(SKIP|PING|PROCESS|CHECK|SYMBOLS|REPORT|HEADERS|REPORT_IFSPAM|TELL)
                    \ SPAMC\/(\d{1,2}\.\d{1,3})\b/x) {
        $self->{method} = $1;
        $self->{client_version} = $2;
        if ($self->{method} eq 'PING') {
          $self->send_status_line('EX_OK', 'PONG');
          return Apache2::Const::OK;
        }
        elsif ($self->{method} eq 'SKIP') {
          return Apache2::Const::OK;
        }
        elsif ($self->{method} eq 'TELL' && !$self->cfg->{allow_tell}) {
          $self->service_unavailable_error('TELL commands have not been enabled.');
          return Apache2::Const::FORBIDDEN;
        }
        next;
      }
      elsif ($line =~ /^GET /) { # treat this like ping
        $self->send_buffer(
          join "\r\n",
          'HTTP/1.0 200 SA running',
          'Content-Type: text/plain',
          'Content-Length: 0', ''
        );
        return Apache2::Const::OK;
      }
      $self->protocol_error('method required' . ": '$line'");
      return Apache2::Const::NOT_FOUND;    # something more reasonable?
    }

    last unless length $line;    # end of headers

    # get headers, ignore unknown
    my ($header, $value) = split /:\s+/, $line, 2;
    unless (defined $header && length $header
         && defined $value  && length $value) {
      $self->protocol_error("(header not in 'Name: value' format)");
      return Apache2::Const::FORBIDDEN;
    }

    return Apache2::Const::FORBIDDEN
      if $header =~ /[^a-z\d_-]/i || $value =~ /[^\x20-\xFF]/;    # naughty

    if ($header =~ /^(?:Content-[Ll]ength|User|Message-[Cc]lass|Set|Remove)$/) {
      $header =~ y/A-Z-/a-z_/;
      $self->headers_in->{$header} = $value;
    }
    else {    # FIXME: remove
      warn "unknown header: '$header'='$value'";
    }
  }
  undef;
}


sub read_body { # -: A
  my $self = shift;
  my ($message, $len) = ('', 0);
  my $content_length = $self->headers_in->{content_length};

  while (1) {
    my $rc =
      $self->c->input_filters->get_brigade($self->in, Apache2::Const::MODE_READBYTES,
      APR::Const::BLOCK_READ,
      ($content_length ? $content_length - $len : ()));
    last if APR::Status::is_EOF($rc);
    die APR::Error::strerror($rc) unless $rc == APR::Const::SUCCESS;    # timeout
    next unless $self->in->flatten(my $chunk);
    $self->in->cleanup;

    my $chlen = length $chunk;
    $len += $chlen;

    # this is never true, actually...  get_brigade ensures we won't get
    # more bytes...  well, at least it's logically correct. ;-)
    # we could check if $message ends with "\n" to detect weird cases.
    if ($content_length && $len > $content_length) {
      $self->protocol_error('(Content-Length mismatch: Expected'
          . " $content_length bytes, got $len bytes");
      return Apache2::Const::FORBIDDEN;
    }

    $message .= $chunk;
    last if $content_length && $len == $content_length;
  }

  $self->{actual_length} = $len;
  $self->{parsed} = $self->spamtest->parse($message , 0);

  undef;
}




#
# Code to deal with user configuration.
#
# Run handle_* directly (ie. not from read_user_config) only if you know
# what you are doing.
#
# Change handle_* to return undef if not found and 0 if something's wrong?
#


sub handle_user_local { # -: a
  require File::Spec;
  my $self = shift;
  my($username) = @_;
  my ($name, $uid, $gid, $dir) = (getpwnam $username)[0, 2, 3, 7];

  unless (defined $uid) {
    my $errmsg = "handle_user unable to find user: '$username'";
    if ($self->spamtest->{'paranoid'}) {  # FIXME: return something? die? whatever?
      $self->service_unavailable_error($errmsg);
    }
    else {
      # if we are given a username, but can't look it up, maybe name
      # services are down?  let's break out here to allow them to get
      # 'defaults' when we are not running paranoid
      info($errmsg);
    }
    return 0;
  }

  my $cf_dir  = File::Spec->catdir($dir,     '.spamassassin');
  my $cf_file = File::Spec->catfile($cf_dir, 'user_prefs');
  if (!-l $cf_dir && -d _ && !-d $cf_file && -f _ && -s _) {
    $self->spamtest->read_scoreonly_config($cf_file);

    # if the $cf_dir group matches ours, assume we can write there
    my $user_dir = $) == (stat $cf_dir)[5] ? $dir : undef;

    $self->spamtest->signal_user_changed(
      { username => $username, user_dir => $user_dir, });
  }
  return 1;
}


=head1 TODO

Timeout...

NetSet

=head1 BUGS

See E<lt>http://bugzilla.spamassassin.org/E<gt>.

=head1 SEE ALSO

C<httpd(8)>,
C<spamd(1)>,
C<apache-spamd(1)>,
C<Mail::SpamAssassin::Spamd::Apache2::Config(3)>

=cut

1;

# vim: ts=2 sw=2 et