#!/usr/bin/perl -w

# Copyright 2002-2006 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 Mail::Verp;
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 and libmail-verp-perl.

=cut

require "common.pl";

# Local configuration variables
my $debug = 0;
my $needs_approval = 1;
my $bounce_addr = 'bounces+DATE@packages.qa.debian.org';

# 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));

if ($package =~ /^bounces\+/) {
	# Execute bounce handler ...
	exec "$pts_dir/bin/bounces-handler.pl", @ARGV;
}

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

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");
$msgid = 'no-msgid-present@localhost' unless defined($msgid);
chomp($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') =~ /^transcript/)
	    )
    {
	$keyword = 'bts-control';
    } elsif (scalar(grep { m/owner\@bugs\.debian\.org/ } 
		    ($mail->head()->get('X-Loop'))) and
	     $mail->head()->get('X-Debian-PR-Message')
       )
    {
	$keyword = 'bts';
    } elsif ($mail->head()->get('X-DAK') 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-DAK') 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-DAK') or
	     $mail->head()->get('Subject') =~ /^Comments regarding .*\.changes$/)
    {
	$keyword = 'katie-other';
    }
}

do_log ":: $package $keyword";

# If default keyword, it may be spam ... only approve special mails
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 approval
    if (defined($needs_approval) && $needs_approval) {
	if (! $mail->head()->get('X-PTS-Approved')) {
            do_log "** Discarded, missing X-PTS-Approved";
            exit 0;
	}
    }
}

# 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-Debian", "PTS");
$mail->head()->add("X-Debian-Package", $package);
$mail->head()->add("X-PTS-Package", $package);
$mail->head()->add("X-PTS-Keyword", $keyword);
$mail->head()->add("List-Unsubscribe", 
	"<mailto:pts\@qa.debian.org?body=unsubscribe+$package>");

# Forward the mail ... with a VERP header
my $date = strftime('%Y%m%d', gmtime());
$bounce_addr =~ s/DATE/$date/;

# Keep track of sent mails (to be able to match them with bounces later)
open_db_bounces();
foreach my $email (@emails) {
    update_bounces_db($date, $email, 1);
}
close_db_bounces();

# Really send mails
my $archive = 1;
my $verp = Mail::Verp->new(separator => '-');
foreach my $email (@emails) {
    my $from = $verp->encode($bounce_addr, $email);
    send_mail($from, $email, $archive);
    do_log "=> $email";
    $archive = 0;
}
do_log "Completed";

sub send_mail {
    my ($from, $to, $archive) = @_;
    if ($archive) {
	open(MAIL, "| $sendmail -f $from -oi archive-outgoing\@packages.qa.debian.org $to") || die "Can't fork sendmail: $!\n";
    } else {
	open(MAIL, "| $sendmail -f $from -oi $to") || die "Can't fork sendmail: $!\n";
    }
    $mail->print(\*MAIL);
    if (not close MAIL) {
	warn "Problem happened with sendmail: $!\n";
	do_log "** sendmail: $!";
    }
}