#!/usr/bin/perl

=head1 NAME

moderator-assistant - Mailman の司会作業を補助する

=head1 SYNOPSIS FOR QMAIL

C<.qmail> の中で

    |preline moderator-assistant
    &realuser

と指定する．

=head1 SYNOPSIS FOR OTHER MTA

C<.forward> の中で

    |"moderator-assistant --to realuser"

と指定する．

=head1 DESCRIPTION

標準入力から Mailman の司会要請メッセージを読み込み，司会対象のメッセー
ジを取り出して，clamscan と bsfilter で検査する．Virus または SPAM と判
定された場合は，破棄するように Mailman にコマンドメールを，司会者には破
棄したメールのコピーを送る．

=cut
use 5.8.0;
use Getopt::Long;
use English qw/ $CHILD_ERROR /;
use File::Temp qw/ tempdir /;
use Mail::Address;
use MIME::Parser;
use MIME::Entity;
use Net::SMTP;
use strict;
use open IO => ':bytes';

=head1 OPTIONS

=over 4

=item --host HOST

コマンドメールの送信に利用する SMTP サーバを指定する．無指定の場合は，
C<localhost> を使用する．

=item --from ADDRESS

コマンドメールの From 行に記入するメールアドレスを指定する．無指定の場
合は，司会要請メッセージの送信先アドレスを用いる．

=item --to ADDRESS

Virus でも SPAM でもないと判定されたメールの転送先を指定する．

転送先が指定されている場合には，終了コードとして sendmail や Postfix 向
けのコードを用いる．すなわち，転送が失敗したり，bsfilter や clamscan が
見つからなかった場合は，終了コード 75 で終了する．それ以外の場合は，終
了コード 0 で終了する．

転送先が指定されていない場合は，終了コードとして qmail 向けのコードを用
いる．すなわち，メールが SPAM または Virus と判定されると，終了コード
99 で終了する．そうでなければ，終了コード 0 で終了する．また，bsfilter
や clamscan が見つからなかった場合は，終了コード 111 で終了する．これら
の終了コードの意味は，L<http://man.qmail.jp/jman8/qmail-command.html>
を参照．

=item --password MAILING-LIST=PASSWORD

Mailman の司会用パスワードを指定する．パスワードが指定されている時に，
Virus でも SPAM でもないメールを受け取った場合は，そのメールを承認する
ようにコマンドメールを送信する．

C<--password _default_=XXXX> と，メーリングリスト名として C<_default_>
を指定することもできる．

=item --no-spamcheck

bsfilter による spam 判定を行わない．

=item --no-viruscheck

clamscan による spam 判定を行わない．

=item --debug

=back

=cut
our $SPAMCHECK = 1;
our $VIRUSCHECK = 1;
our $HOST = 'localhost';
our $FROM;
our $TO;
our %PASSWORD;
our @REJECTFROM;
our $DATADIR;
our $DEBUG;
&GetOptions( 'spamcheck!'   => \$SPAMCHECK,
	     'viruscheck!'  => \$VIRUSCHECK,
	     'rejectfrom=s' => \@REJECTFROM,
	     'host=s'       => \$HOST,
	     'from=s'       => \$FROM,
	     'to=s'	    => \$TO,
	     'password=s'   => \%PASSWORD,
	     'datadir=s'    => \$DATADIR,
	     'debug!'       => \$DEBUG );

our $IGNORE_FURTHER_DELIVERY = $TO ? 0 : 99;
our $TEMPORARY_FAILURE = $TO ? 75 : 111;

our $BSFILTER = '/usr/bin/bsfilter';
$BSFILTER = sprintf( '%s --homedir %s', $BSFILTER, $DATADIR ) if $DATADIR;
our $CLAMSCAN = sprintf( '/usr/bin/%s --no-summary --quiet -',
			 ( ( -x '/usr/bin/clamdscan' ) ? 'clamdscan' : 'clamscan' ) );

my $top = &read_message();
if( my( @entity ) = &make_reply( $top ) ){
    if( $DEBUG ){
	for my $e ( @entity ){
	    $e->print( \*STDOUT );
	}
    } else {
	for my $e ( @entity ){
	    $e->smtpsend( Host => $HOST );
	}
    }
    exit $IGNORE_FURTHER_DELIVERY;
} else {
    if( $TO ){
	my $from = $FROM || ( $top->head->get('delivered-to') )[0];
	$from =~ s/\s+\Z//;
	if( $DEBUG ){
	    print 'MAIL FROM: ', $from, "\n";
	    print 'RCPT TO: ', $TO, "\n";
	    $top->print( \*STDOUT );
	    print "\n";
	} else {
	    my $smtp = Net::SMTP->new( $HOST );
	    my $ok = ( $smtp->mail( $from ) &&
		       $smtp->to( $TO ) &&
		       $smtp->data( $top->as_string ) );
	    $ok || exit $TEMPORARY_FAILURE;
	}
    }
    exit 0;
}

sub read_message {
    my $parser = MIME::Parser->new();
    $parser->output_under( &tempdir( CLEANUP => 1 ) );
    $parser->parse( \*STDIN );
}

sub make_reply {
    my( $top ) = @_;

    # Mailman からの司会要請メッセージには，メーリングリスト名が記入されているはず．
    my $name = $top->head->get('x-beenthere');
    $name =~ s/\A\s+//;
    $name =~ s/\s+\Z//;
    return () unless $name;

    # Mailman からの司会要請メッセージは3パートからなるはず．
    return () unless $top->parts == 3;

    my( undef, $target, $confirm ) = $top->parts;
    return () unless $target->mime_type eq 'message/rfc822';
    $target = $target->parts(0);

    return () unless $confirm->mime_type eq 'message/rfc822';
    $confirm = $confirm->parts(0);

    # 第3パートは「confirm 〜」という表題のはず．
    return () unless $confirm->head->get('subject') =~ m/\Aconfirm [a-zA-Z0-9]+\r?\n?\Z/;

    my $reply = MIME::Entity->build( From     => $FROM || $top->head->get('to'),
				     To       => $confirm->head->get('from'),
				     Subject  => $confirm->head->get('subject'),
				     Type     => 'text/plain',
				     Encoding => '7bit',
				     Data     => [ '' ] );
    if( &rejectfrom_p($target) or &virus_p($target) or &spam_p($target) ){
	my $log = MIME::Entity->build( From     => $top->head->get('to'),
				       To       => $FROM || $top->head->get('to'),
				       Subject  => sprintf( 'Revoked: %s', $target->head->get('subject') ),
				       Type     => 'message/rfc822',
				       Encoding => 'binary',
				       Data     => [ $target->as_string ] );
	( $reply, $log );
    } elsif( my $pass = ( $PASSWORD{$name} || $PASSWORD{'_default_'} ) ){
	$reply->head->set( 'approved', $pass );
	( $reply );
    } else {
	();
    }
}

sub rejectfrom_p {
    my( $target ) = @_;
    for my $x ( Mail::Address->parse( $target->head->get('from') ) ){
	for my $pat ( @REJECTFROM ){
	    if( my( $dom ) = ( $pat =~ m/\A\@(.*)\Z/ ) ){
		return 1 if $x->host eq $dom; # domain part check
	    } elsif( $pat =~ m/\@/ ){
		return 1 if $x->address eq $pat; # whole address check
	    } else {
		return 1 if $x->user eq $pat; # local part check
	    }
	}
    }
    0;
}

sub virus_p {
    my( $target ) = @_;
    if( $VIRUSCHECK ){
	open( my $clamscan, "|$CLAMSCAN" ) or exit $TEMPORARY_FAILURE;
	binmode( $clamscan, ':bytes' );
	$target->print( $clamscan );
	close $clamscan;
	( ( $CHILD_ERROR >> 8 ) == 1 );
    } else {
	0;
    }
}

sub spam_p {
    my( $target ) = @_;
    if( $SPAMCHECK ){
	open( my $bsfilter, "|$BSFILTER" ) or exit $TEMPORARY_FAILURE;
	binmode( $bsfilter, ':bytes' );
	$target->print( $bsfilter );
	close $bsfilter;
	( ( $CHILD_ERROR >> 8 ) == 0 );
    } else {
	0;
    }
}

=head1 AUTHOR

TSUCHIYA Masatoshi <tsuchiya@namazu.org>

=head1 COPYRIGHT

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.

Last Update: $Date: 2012/02/21 08:37:55 $

=cut