#!/usr/bin/perl -w

# Copyright 2002 Raphaël Hertzog <hertzog@debian.org>
# Available under the terms of the General Public License version 2
# or (at your option) any later version

use lib '/org/packages.qa.debian.org/perl';

use POSIX;
use Mail::Internet;
use Mail::Address;
use DB_File;

use strict;
use vars qw($db $sendmail $pts_dir);

=head1 Script for *@packages.qa.debian.org

=head1 INSTALLATION INSTRUCTIONS

This script needs libmailtools-perl.

=cut

require "common.pl";

# Local configuration variables
my $nb_by_group = 20; # Number of emails sent together (in the same sendmail)
my $debug = 0;
my $spamc = '';
my $needs_approval = 1;

# Get the package name
my $package = lc($ENV{'LOCAL_PART'}); # Exim sets that ...
$package = lc(shift @ARGV) if ($debug && defined($ARGV[0]) && $ARGV[0]); # 
die "Aren't you exim ?" if (! (defined($package) && $package));

open LOG, ">> $pts_dir/logs/dispatch.log"
  or die("Couldn't open logfile: $!");
sub do_log {
	$_ = shift;
    printf LOG "%s $$ $_\n", strftime("%Y-%m-%d %H:%M:%S", gmtime());
}

my $lp = lc($ENV{'LOCAL_PART'});

# Parse the mail
my $mail;
if (not ($mail = Mail::Internet->new(\*STDIN))) {
    do_log "** Parsing message for $lp failed";
    die "Parse failed !\n";
}

my $msgid = $mail->head()->get("Message-ID");
chop($msgid);
my ($email_obj) = Mail::Address->parse($mail->head()->get("From"));
my $from = lc($email_obj->address());
do_log "<= $from for $lp $msgid";

# Get the keyword name
my $keyword = '';
if ($package =~ /(\S+)_(\S+)/) {
    $package = $1;
    $keyword = $2;
}

# Stop if bad X-Loop
my @xloop = grep { m/$package\@packages.qa.debian.org/ } 
		 ($mail->head()->get('X-Loop'));
if (scalar(@xloop)) {
    do_log "%% Discarding, loop detected";
    exit 0;
}

# Find the real keyword
if (! $keyword) {
    $keyword = 'default';
    if (scalar(grep { m/owner\@bugs\.debian\.org/ } 
		    ($mail->head()->get('X-Loop'))
	      )
	and $mail->head()->get('X-Debian-PR-Message')
       )
    {
	$keyword = 'bts';
    } elsif (scalar(grep { m/debbugs\@master\.debian\.org/ }
		    ($mail->head()->get('Sender'))
		   )
	     and ($mail->head()->get('Subject') =~ /^Processed:/)
	    )
    {
	$keyword = 'bts-control';
    } elsif (($mail->head()->get('X-Katie') or $mail->head()->get('X-Lisa'))
    	     and
	     ($mail->head()->get('Subject') =~ /^Accepted|INSTALLED|ACCEPTED/) and
	     (scalar(grep { /\.dsc\s*$/ } @{$mail->body()}))
	    )
    {
	exit(0) if ($mail->head()->get('Subject') =~ /INSTALLED|ACCEPTED/);
	$keyword = 'upload-source';
    } elsif (($mail->head()->get('X-Katie') or $mail->head()->get('X-Lisa'))
             and
	     ($mail->head()->get('Subject') =~ /^Accepted|INSTALLED|ACCEPTED/)
	    )
    {
	#exit(0) if ($mail->head()->get('Subject') =~ /INSTALLED|ACCEPTED/);
	$keyword = 'upload-binary';
    } elsif ($mail->head()->get('X-Katie') or $mail->head()->get('X-Lisa')
        or $mail->head()->get('Subject') =~ /^Comments regarding .*\.changes$/)
    {
	$keyword = 'katie-other';
    }
}

do_log ":: $package $keyword";

# If default keyword, it may be spam ... check with spamassassin
# before approving
if ($keyword eq "default") {
    # Some mails comes from trusted sources
    # which do not need auto-approval
    if ($mail->head()->get('X-Bugzilla-Product')) {
	# Bugzilla(s) are trusted sources
	$needs_approval = 0;
    }
    # Check for spam
    if (defined($spamc) && $spamc) {
	open(SPAMC, "| $spamc -c >/dev/null") || die "Can't fork spamc: $!\n";
	$mail->print(\*SPAMC);
	my $res = close(SPAMC);
	if (!$res and !$!) {
	    # Looks like it's spam
	    print STDERR "Your message appears to be spam (according to spamassassin).\n";
	    print STDERR "If it wasn't please retry by writing simple plain text mails.\n";
	    exit 2;
	}
    }
    # Check for approval
    if (defined($needs_approval) && $needs_approval) {
	if (! $mail->head()->get('X-PTS-Approved')) {
	    print STDERR "The mail isn't auto-approved as it should be. Please include\n";
	    print STDERR "an 'X-PTS-Approved' (non-empty) header if you want to mail \n";
	    print STDERR "directly the Package Tracking System. This is made to avoid spam.\n";
	    do_log "** Discarded, missing X-PTS-Approved";
	    exit 2;
	}
    }
}

# Get the list of subscribers
open_db_read();
my @emails = $db->get_dup($package);

# Build the real list of interested people
my $wantmail = sub {
    my $address = shift;
    foreach (get_tags($address, $package)) {
	return 1 if ($_ eq $keyword);
    }
    return 0;
};
@emails = grep { &$wantmail($_) } @emails;
close_db();

# Modify the mail
$mail->head()->add("Precedence", "list");
$mail->head()->add("X-Loop", "$package\@packages.qa.debian.org");
$mail->head()->add("X-PTS-Package", $package);
$mail->head()->add("X-PTS-Keyword", $keyword);
$mail->head()->add("X-Unsubscribe", 
	"echo 'unsubscribe $package' | mail pts\@qa.debian.org");

# Forward the mail ... by group of $nb_by_group addresses
my @send;
while (defined($_ = shift @emails)) {
    push @send, $_;
    # techincally, we didn't send yet, but whatever
    do_log "=> $_";
    if (scalar(@send) == $nb_by_group) {
	send_mail(@send);
	@send = ();
    }
}
send_mail(@send) if (scalar(@send));
do_log "Completed";

sub send_mail {
    return 0 if not scalar(@_);
    open(MAIL, "| $sendmail -oi @_") || die "Can't fork sendmail: $!\n";
    $mail->print(\*MAIL);
    if (not close MAIL) {
	warn "Problem happened with sendmail: $!\n";
	do_log "** sendmail: $!";
    }
}