=head1 NAME

milter

=head1 DESCRIPTION

This plugin allows you to attach to milter filters (yes, those written for
sendmail) as though they were qpsmtpd plugins.

In order to do this you need the C<Net::Milter> module from CPAN.

=head1 CONFIG

It takes two required parameters - a milter name (for logging) and the port
to connect to on the localhost. This can also contain a hostname if
the filter is on another machine:

  milter Brightmail 5513

or

  milter Brightmail bmcluster:5513

This plugin has so far only been tested with Brightmail's milter module.

=cut

use Net::Milter;
no warnings;

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

  die "Invalid milter setup args: '@args'" unless @args > 1;
  my ($name, $port) = @args;
  my $host = '127.0.0.1';
  if ($port =~ s/^(.*)://) {
    $host = $1;
  }
  
  $self->{name} = $name;
  $self->{host} = $host;
  $self->{port} = $port;
  
  $self->register_hook("connect", "connect_handler");
  $self->register_hook("helo", "helo_handler");
  $self->register_hook("mail", "mail_handler");
  $self->register_hook("rcpt", "rcpt_handler");
  $self->register_hook("data_post", "data_handler");
  $self->register_hook("disconnect", "disconnect_handler");
}

sub disconnect_handler {
    my ($self) = @_;

    my $milter = $self->qp->connection->notes('milter') || return DECLINED;
    $milter->send_quit();
    
    $self->qp->connection->notes('spam', undef);
    $self->qp->connection->notes('milter', undef);

    return DECLINED;
}

sub check_results {
    my ($self, $transaction, $where, @results) = @_;
    foreach my $result (@results) {
        next if $result->{action} eq 'continue';
        $self->log(LOGINFO, "milter $self->{name} result action: $result->{action}");
        if ($result->{action} eq 'reject') {
            die("Rejected at $where by $self->{name} milter ($result->{explanation})");
        }
        elsif ($result->{action} eq 'add') {
            if ($result->{header} eq 'body') {
                $transaction->body_write($result->{value});
            }
            else {
                push @{$transaction->notes('milter_header_changes')->{add}},
                        [$result->{header}, $result->{value}];
            }
        }
        elsif ($result->{action} eq 'delete') {
            push @{$transaction->notes('milter_header_changes')->{delete}},
                $result->{header};
        }
        elsif ($result->{action} eq 'accept') {
            # TODO - figure out what this is used for
        }
        elsif ($result->{action} eq 'replace') {
            push @{$transaction->notes('milter_header_changes')->{replace}},
                    [$result->{header}, $result->{value}];
        }
    }
}

sub connect_handler {
    my ($self, $transaction) = @_;
    
    $self->log(LOGDEBUG, "milter $self->{name} opening connection to milter backend");
    my $milter = Net::Milter->new();
    $milter->open($self->{host}, $self->{port}, 'tcp');
    $milter->protocol_negotiation();

    $self->qp->connection->notes(milter => $milter);

    $self->qp->connection->notes(
        milter_header_changes => { add => [], delete => [], replace => [], }
    );    
    my $remote_ip = $self->qp->connection->remote_ip;
    my $remote_host = $self->qp->connection->remote_host;
    $self->log(LOGDEBUG, "milter $self->{name} checking connect from $remote_host\[$remote_ip\]");
    
    eval {
        $self->check_results($transaction, "connection",
            $milter->send_connect($remote_host, 'tcp4', 0, $remote_ip));
    };
    $self->qp->connection->notes('spam', $@) if $@;

    return DECLINED;
}

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

    if (my $txt = $self->qp->connection->notes('spam')) {
        return DENY, $txt;
    }
    
    my $milter = $self->qp->connection->notes('milter');
    
    my $helo = $self->qp->connection->hello;
    my $host = $self->qp->connection->hello_host;

    $self->log(LOGDEBUG, "milter $self->{name} checking HELO $host");
    
    eval { $self->check_results($transaction, "HELO",
                                $milter->send_helo($host)) };
    return(DENY, $@) if $@;
    
    return DECLINED;
}

sub mail_handler {
    my ($self, $transaction, $address) = @_;
    
    my $milter = $self->qp->connection->notes('milter');

    $self->log(LOGDEBUG, "milter $self->{name} checking MAIL FROM " . $address->format);
    eval { $self->check_results($transaction, "MAIL FROM",
                                $milter->send_mail_from($address->format)) };
    return(DENY, $@) if $@;

    return DECLINED;
}

sub rcpt_handler {
    my ($self, $transaction, $address) = @_;
    
    my $milter = $self->qp->connection->notes('milter');

    $self->log(LOGDEBUG, "milter $self->{name} checking RCPT TO " . $address->format);

    eval { $self->check_results($transaction, "RCPT TO",
                                $milter->send_rcpt_to($address->format)) };
    return(DENY, $@) if $@;

    return DECLINED;
}

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

    my $milter = $self->qp->connection->notes('milter');

    $self->log(LOGDEBUG, "milter $self->{name} checking headers");

    my $headers = $transaction->header(); # Mail::Header object
    foreach my $h ($headers->tags) {
        # munge these headers because milters prefer them this way
        $h =~ s/\b(\w)/\U$1/g;
        $h =~ s/\bid\b/ID/g;
        foreach my $val ($headers->get($h)) {
            # $self->log(LOGDEBUG, "milter $self->{name} checking header: $h: $val");
            eval { $self->check_results($transaction, "header $h",
                                $milter->send_header($h, $val)) };
            return(DENY, $@) if $@;
        }
    }
    
    eval { $self->check_results($transaction, "end headers",
                                $milter->send_end_headers()) };
    return(DENY, $@) if $@;
     
    $transaction->body_resetpos;
    
    # skip past headers
    while (my $line = $transaction->body_getline) {
        $line =~ s/\r?\n//;
        $line =~ s/\s*$//;
        last unless length($line);
    }

    $self->log(LOGDEBUG, "milter $self->{name} checking body");

    my $data = '';
    while (my $line = $transaction->body_getline) {
        $data .= $line;
        if (length($data) > 60000) {
            eval { $self->check_results($transaction, "body",
                                $milter->send_body($data)) };
            return(DENY, $@) if $@;
            $data = '';
        }
    }
    
    if (length($data)) {
        eval { $self->check_results($transaction, "body",
                                $milter->send_body($data)) };
        return(DENY, $@) if $@;
        $data = '';
    }
    
    eval { $self->check_results($transaction, "end of DATA",
                                $milter->send_end_body()) };
    return(DENY, $@) if $@;

    my $milter_header_changes = $transaction->notes('milter_header_changes'); 

    foreach my $add (@{$milter_header_changes->{add}}) {
        $headers->add($add->[0], $add->[1]);
    }
    foreach my $del (@{$milter_header_changes->{'delete'}}) {
        $headers->delete($del);
    }
    foreach my $repl (@{$milter_header_changes->{replace}}) {
        $headers->replace($repl->[0], $repl->[1]);
    }
    
    return DECLINED;
}