#!/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 ConfirmationSpool;
use MIME::Parser;
use MIME::Entity;
use Mail::Address;
use DB_File;

use strict;
use vars qw($spool_dir $conf_sub_template $conf_unsub_template
	    $conf_unsuball_template $sendmaildefault $sendmailnobody
	    %db_tags_content);

# Mailbot for pts@qa.debian.org

=head1 INSTALLATION INSTRUCTIONS

This script needs libmime-perl and libmailtools-perl.

=cut

require "common.pl";

# Create a ConfirmationSpool object to handle the email authentication
my $cs = ConfirmationSpool->new($spool_dir);
$cs->set_sendmail($sendmaildefault);
$cs->clean();

# Parse the mail
my $parser = MIME::Parser->new();
$parser->output_to_core(1);
my $mail = $parser->parse(\*STDIN) or die "Parse failed !\n";

# Stop if bad X-Loop
my $xloop = $mail->head()->get('X-Loop');
if (defined($xloop) && ($xloop =~ /pts\@qa.debian.org/)) {
    exit 0;
}

# Extract the subject and the sender email
my $subject = $mail->head()->get("Subject") || "Your mail";
my $mid = $mail->head()->get("Message-ID") || "";
my $ref = $mail->head()->get("References") || "";
my ($email_obj) = Mail::Address->parse($mail->head()->get("From"));
my $email = lc($email_obj->address());
my @cc;

# Find the text/plain part containing commands...
if ($mail->is_multipart()) {
    $mail = $mail->parts(0); # Assume the first part is the interesting one
}

# Lines of the answer that we'll send
my @ans = ();

# Lines of the mail we got
my @lines = ("Subject: " . $subject);
if (defined $mail->bodyhandle()) {
    push @lines, $mail->bodyhandle()->as_lines();
} else {
    push @ans, ("Warning: your message's body couldn't be decoded.\n", 
    		"Try again with a simple plain-text message.\n", "\n");
}

push @ans, ("Processing commands for pts\@qa.debian.org:\n", "\n");
my $nb_err = 0;
my %done;

# Prepare the subject for the answer
if ($subject !~ /^\s*Re: /) {
    $subject = "Re: $subject";
}

foreach my $line (@lines) {
    push @ans, "> $line";
    
    # Hack for subject ...
    if ($line =~ /^Subject: (?:Re\s*:\s*)?(.*)$/i) {
	push @ans, "\n";
	$line = $1;
    }
    
    # Try to detect commands
    if ($line =~ /^\s*#/) {
	next;
	
    } elsif ($line =~ /^\s*subscribe\s+(\S+)(?:\s+(\S+))?/i) {
	my ($package, $address) = (lc($1), lc($2));
	$address = $email if (! (defined($address) && $address));
	next if (defined($done{"SUBSCRIBE $package $address"})); # Not twice..
	my @explanation;
	($package, @explanation) = map_package($package);
	push @ans, @explanation;
	$cs->set_confirmation_template($conf_sub_template);
	$cs->ask_confirmation($address, "SUBSCRIBE $package $address",
			      { "PACKAGE" => $package });
	$done{"SUBSCRIBE $package $address"} = 1;
	push @ans, "A confirmation mail has been sent to $address.\n";
	push @ans, "\n";
	push @cc, $address if ($address ne $email);
	
    } elsif ($line =~ /^\s*unsubscribe\s+(\S+)(?:\s+(\S+))?/i) {
	my ($package, $address) = (lc($1), lc($2));
	$address = $email if (! (defined($address) && $address));
	if (not is_subscribed_to($address, $package)) {
	    my @explanation;
	    ($package, @explanation) = map_package($package);
	    push @ans, @explanation;
	}
	$cs->set_confirmation_template($conf_unsub_template);
	$cs->ask_confirmation($address, "UNSUBSCRIBE $package $address",
			      { "PACKAGE" => $package });
	$done{"UNSUBSCRIBE $package $address"} = 1;
	push @ans, "A confirmation mail has been sent to $address.\n";
	push @ans, "\n";
	push @cc, $address if ($address ne $email);
	
    } elsif ($line =~ /^\s*unsubscribeall(?:\s+(\S+))?/i) {
	my $address = lc($1);
	$address = $email if (! (defined($address) && $address));
	my @explanation;
	$cs->set_confirmation_template($conf_unsuball_template);
	$cs->ask_confirmation($address, "UNSUBSCRIBEALL $address");
	$done{"UNSUBSCRIBEALL $address"} = 1;
	push @ans, "A confirmation mail has been sent to $address.\n";
	push @ans, "\n";
	push @cc, $address if ($address ne $email);
	
    } elsif ($line =~ /^\s*confirm\s+(\S+)/i) {
	my $key = $1;
	next if (defined($done{"CONFIRM $key"})); # Not twice..
	my $cmd = $cs->confirm($key);
	if (defined($cmd)) {
	    my ($package, $address);
	    if ($cmd =~ /^SUBSCRIBE (\S+) (\S+)/) {
		($package, $address) = (lc($1), lc($2));
		if (subscribe($address, $package)) {
		    push @ans, "$address has been subscribed to " .
			    "$package\@packages.qa.debian.org.\n";
		    $subject = "You are now subscribed to $package";
		} else {
		    push @ans, "$address is already subscribed ...\n";
		}
	    } elsif ($cmd =~ /^UNSUBSCRIBE (\S+) (\S+)/) {
		($package, $address) = (lc($1), lc($2));
		if (unsubscribe($address, $package)) {
		    push @ans, "$address has been unsubscribed from " .
			    "$package\@packages.qa.debian.org.\n";
		    $subject = "You are no longer subscribed to $package";
		} else {
		    push @ans, "$address is not subscribed, you can't unsubscribe.\n";
		}
	    } elsif ($cmd =~ /^UNSUBSCRIBEALL (\S+)/) {
		$address = lc($1);
		push @ans, "All your subscriptions have been terminated :\n";
		foreach my $package (which($address)) {
		    if (unsubscribe($address, $package)) {
			push @ans, "$address has been unsubscribed from " .
			    "$package\@packages.qa.debian.org.\n";
			$subject = "All your subcriptions have been terminated";
		    } else {
			push @ans, "$address is not subscribed, you can't unsubscribe.\n";
		    }
		}
	    } else {
		push @ans, "Confirmation failed. Retry with a new command.\n";
	    }
	    $done{"CONFIRM $key"} = 1;
	    push @cc, $address if ($address ne $email);
	} else {
	    push @ans, "Confirmation failed. Retry with a new command.\n";
	}
	push @ans, "\n";
	
    } elsif ($line =~ /^\s*which(?:\s+(\S+))?/i) {

	my $address = lc($1);
	$address = $email if (! (defined($address) && $address));
	$done{"WHICH $address"} = 1;
	push @ans, "Here's the list of subscriptions for $address :\n";
	push @ans, map { $_ . "\n" } (which($address));
	push @ans, "\n";
	
    } elsif ($line =~ /^\s*list\s+(\S+)/i) {

	my $package = lc($1);
	$done{"LIST $package"} = 1;
	push @ans, "Here's the list of subscribers to $package :\n";
	push @ans, map { $_ . "\n" } (list($package));
	push @ans, "\n";

    } elsif ($line =~ /^\s*(?:keyword|tag)s?(?:\s+(\S+@\S+))?\s*$/i) {

	my $address = lc($1);
	$address = $email if (! (defined($address) && $address));
	$done{"KEYWORD $address"} = 1;
	push @ans, "Here's the default list of accepted keywords " .
		   "for $address :\n";
	push @ans, map { "* " . $_ . "\n" } (get_default_tags($address));
	push @ans, "\n";

    } elsif ($line =~ /^\s*(?:keyword|tag)s?\s+(\S+)(?:\s+(\S+@\S+))?\s*$/i) {

	my $package = lc($1);
	my $address = lc($2);
	$address = $email if (! (defined($address) && $address));
	$done{"KEYWORD $package $address"} = 1;
	push @ans, "Here's the list of accepted keywords associated to " . 
	           "package\n";
	push @ans, "$package for $address :\n";
	push @ans, map { "* " . $_ . "\n" } (get_tags($address, $package));
	push @ans, "\n";

    } elsif ($line =~ /^\s*(?:keyword|tag)s?(?:\s+(\S+@\S+))?\s+([-+=])\s+(\S+(?:\s+\S+)*)\s*$/i) {

	my $address = lc($1);
	$address = $email if (! (defined($address) && $address));
	my $cmd = $2;
	my @t = split(/[,\s]+/, lc($3));
	$done{"KEYWORD $address $cmd @t"} = 1;
	foreach (@t) {
	    push @ans, "WARNING: $_ is not a valid keyword.\n"
						    if (! is_valid_tag($_));
	}
	open_db_write();
	if ($cmd eq "=") {
	    set_default_tags($address, @t);
	} elsif ($cmd eq "+") {
	    my @tags = get_default_tags($address);
	    push @tags, @t;
	    set_default_tags($address, @tags);
	} elsif ($cmd eq "-") {
	    my $check = sub {
				foreach my $t (@t) {
				    return 0 if ($_[0] eq $t);
				}
				return 1;
			    };
	    my @tags = grep { &$check($_) } (get_default_tags($address));
	    set_default_tags($address, @tags);
	}
	push @ans, "Here's the new default list of accepted keywords " .
		   "for $address :\n";
	push @ans, map { "* " . $_ . "\n" } (get_default_tags($address));
	push @ans, "\n";
	close_db();
	push @cc, $address if ($address ne $email);

    } elsif ($line =~ /^\s*(?:keyword|tag)s?all(?:\s+(\S+@\S+))?\s+([-+=])\s+(\S+(?:\s+\S+)*)\s*$/i) {

	my $address = lc($1);
	$address = $email if (! (defined($address) && $address));
	my $cmd = $2;
	my @t = split(/[,\s]+/, lc($3));
	$done{"KEYWORD $address $cmd @t"} = 1;
	foreach (@t) {
	    push @ans, "WARNING: $_ is not a valid keyword.\n"
						    if (! is_valid_tag($_));
	}
	open_db_write();
	if (not exists $db_tags_content{$address}) {
	    my @tags = get_default_tags($address);
	    set_default_tags($address, @tags);
	}
	foreach (sort keys %db_tags_content) {
	    if (/^\Q$address\E(?:#([^#]+))?$/) {
		my $package = (defined($1) && $1) ? $1 : "";
		if ($cmd eq "=") {
		    if ($package) {
			set_tags($address, $package, @t);
		    } else {
			set_default_tags($address, @t);
		    }
		} elsif ($cmd eq "+") {
		    if ($package) {
			my @tags = get_tags($address, $package);
			push @tags, @t;
			set_tags($address, $package, @tags);
		    } else {
			my @tags = get_default_tags($address);
			push @tags, @t;
			set_default_tags($address, @tags);
		    }
		} elsif ($cmd eq "-") {
		    my $check = sub {
					foreach my $t (@t) {
					    return 0 if ($_[0] eq $t);
					}
					return 1;
				    };
		    if ($package) {
			my @tags = grep { &$check($_) } (get_tags($address, $package));
			set_tags($address, $package, @tags);
		    } else {
			my @tags = grep { &$check($_) } (get_default_tags($address));
			set_default_tags($address, @tags);
		    }
		}
		if ($package) {
		    push @ans, "Updated the list of keywords accepted by $address ". 
			       "for the package $package.\n";
		} else {
		    push @ans, "Updated the default list of keywords accepted by $address.\n";
		}
	    }
	}
	close_db();
	push @cc, $address if ($address ne $email);

    } elsif ($line =~ /^\s*(?:keyword|tag)s?\s+(\S+)(?:\s+(\S+@\S+))?\s+([-+=])\s+(\S+(?:\s+\S+)*)\s*$/i) {

	my $package = lc($1);
	my $address = lc($2);
	$address = $email if (! (defined($address) && $address));
	my $cmd = $3;
	my @t = split(/[,\s]+/, lc($4));
	$done{"KEYWORD $package $address $cmd @t"} = 1;
	foreach (@t) {
	    push @ans, "$_ is not a valid keyword.\n" if (! is_valid_tag($_));
	}
	open_db_write();
	if ($cmd eq "=") {
	    set_tags($address, $package, @t);
	} elsif ($cmd eq "+") {
	    my @tags = get_tags($address, $package);
	    push @tags, @t;
	    set_tags($address, $package, @tags);
	} elsif ($cmd eq "-") {
	    my $check = sub {
				foreach my $t (@t) {
				    return 0 if ($_[0] eq $t);
				}
				return 1;
			    };
	    my @tags = grep { &$check($_) } (get_tags($address, $package));
	    set_tags($address, $package, @tags);
	}
	push @ans, "Here's the new list of accepted keywords associated to " . 
	           "package\n";
	push @ans, "$package for $address :\n";
	push @ans, map { "* " . $_ . "\n" } (get_tags($address, $package));
	push @ans, "\n";
	close_db();
	push @cc, $address if ($address ne $email);
	
    } elsif ($line =~ /^\s*help/i) {
	push @ans, <DATA>;
	$done{"HELP"} = 1;
    
    } elsif ($line =~ /^(--|\s*quit|\s*thanks?|\s*txs)/i) {
	push @ans, "Stopping processing here.\n";
	last;
	
    } else {
	# accept a few lines of garbage and then stop
	if (++$nb_err > 5) {
	    if (scalar(keys %done)) {
	        push @ans, "Five lines without new commands: stopping.\n";
		push @ans, scalar(keys %done)." command(s) successfully treated. Good bye !\n";
	    } else {
	        push @ans, "Too much garbage. Stopping.\n";
		# This really happens only for spam ... so do not reply
		exit 0;
	    }
	    last;
	}
    }
}

if ((! scalar(keys %done)) and ($nb_err <= 5)) {
	# No commands treated
	# Must be spam with less than 5 lines
	# Use "nobody" as sender to drop useless bounces
	push @ans, "No command found in the message. Stopping.\n";
	$sendmaildefault = $sendmailnobody;
}

my $answer = MIME::Entity->build(From => 'owner@packages.qa.debian.org',
				 To => $email,
				 Subject => $subject,
				 Encoding => '8bit',
				 'X-Loop' => 'pts@qa.debian.org',
				 'Bcc' => 'archive-outgoing-control@packages.qa.debian.org',
				 'References' => "$ref $mid",
				 'In-Reply-To:' => $mid,
				 Data => \@ans);
my %uniq;
foreach (@cc) { $uniq{$_} = 1; }
@cc = (keys %uniq);
$answer->head()->add('Cc', join(", ", @cc)) if (scalar @cc);

open(MAIL, "| $sendmaildefault -oi -t") || die "Can't fork sendmail: $!\n";
$answer->print(\*MAIL);
close MAIL or die "Problem happened with sendmail: $!\n";


__DATA__

Debian Package Tracking System
------------------------------

The Package Tracking System (PTS) has the following commands:

subscribe <srcpackage> [<email>]
  Subscribes <email> to all messages regarding <srcpackage>. If
  <email> is not given, it subscribes the From address. If the
  <srcpackage> is not a valid source package, you'll get a warning.
  If it's a valid binary package, the mapping will automatically be
  done for you.

unsubscribe <srcpackage> [<email>]
  Unsubscribes <email> from <srcpackage>. Like the subscribe command,
  it will use the From address if <email> is not given.

unsubscribeall [<email>]
  Cancel all subscriptions of <email>. Like the subscribe command,
  it will use the From address if <email> is not given.

which [<email>]
  Tells you which packages <email> is subscribed to.

keyword [<email>]
  Tells you the keywords that you are accepting. Each mail sent through
  the Package Tracking System is associated to a keyword and you receive
  only the mails associated to keywords that you are accepting. Here is
  the list of available keywords :
  * bts: mails coming from the Debian Bug Tracking System
  * bts-control: mails sent to control@bugs.debian.org
  * summary: automatic summary mails about the state of a package
  * cvs: notification of cvs commits
  * ddtp: notification of translations from the DDTP (cf ddtp.debian.org)
  * derivatives: notification of changes in derivative distributions
  * upload-source: announce of a new source upload that has been installed
  * upload-binary: announce of a new binary-only upload (porting)
  * katie-other: other mails from ftpmasters (override disparity, etc.)
  * contact: mails sent to the maintainer via <pkg>@packages.debian.org
  * default: all the other mails (those which aren't "automatic")
  By default you have the following keywords : bts, bts-control, summary,
  upload-source, katie-other, default.
  
keyword <srcpackage> [<email>]
  Same as previous item but for the given source package since
  you may select a different set of keywords for each source package.

keyword [<email>] {+|-|=} <list of keywords>
  Accept (+) or refuse (-) mails associated to the given keyword(s).
  Define the list (=) of accepted keywords.
  
keyword <srcpackage> [<email>] {+|-|=} <list of keywords>
  Same as previous item but overrides the keywords list for the indicated
  source package.
  
quit
thanks
  Stops processing commands.