| 1 |
#!/usr/bin/perl -w
|
| 2 |
|
| 3 |
# Copyright 2002 Raphaël Hertzog <hertzog@debian.org>
|
| 4 |
# Available under the terms of the General Public License version 2
|
| 5 |
# or (at your option) any later version
|
| 6 |
|
| 7 |
use lib '/org/packages.qa.debian.org/perl';
|
| 8 |
|
| 9 |
use Mail::Internet;
|
| 10 |
use Mail::Address;
|
| 11 |
use DB_File;
|
| 12 |
|
| 13 |
use strict;
|
| 14 |
use vars qw($db $sendmail $pts_dir);
|
| 15 |
|
| 16 |
=head1 Script for *@packages.qa.debian.org
|
| 17 |
|
| 18 |
=head1 INSTALLATION INSTRUCTIONS
|
| 19 |
|
| 20 |
This script needs libmailtools-perl.
|
| 21 |
|
| 22 |
=cut
|
| 23 |
|
| 24 |
require "common.pl";
|
| 25 |
|
| 26 |
# Local configuration variables
|
| 27 |
my $nb_by_group = 20; # Number of emails sent together (in the same sendmail)
|
| 28 |
my $debug = 0;
|
| 29 |
my $spamc = '';
|
| 30 |
my $needs_approval = 1;
|
| 31 |
|
| 32 |
# Get the package name
|
| 33 |
my $package = lc($ENV{'LOCAL_PART'}); # Exim sets that ...
|
| 34 |
$package = lc(shift @ARGV) if ($debug && defined($ARGV[0]) && $ARGV[0]); #
|
| 35 |
die "Aren't you exim ?" if (! (defined($package) && $package));
|
| 36 |
|
| 37 |
open LOG, ">> $pts_dir/logs/dispatch.log";
|
| 38 |
|
| 39 |
my $lp = lc($ENV{'LOCAL_PART'});
|
| 40 |
|
| 41 |
# Parse the mail
|
| 42 |
my $mail;
|
| 43 |
if (not ($mail = Mail::Internet->new(\*STDIN))) {
|
| 44 |
print LOG "$$ ** Parsing message for $lp failed\n";
|
| 45 |
die "Parse failed !\n";
|
| 46 |
}
|
| 47 |
|
| 48 |
my $msgid = $mail->head()->get("Message-ID");
|
| 49 |
chop($msgid);
|
| 50 |
my ($email_obj) = Mail::Address->parse($mail->head()->get("From"));
|
| 51 |
my $from = lc($email_obj->address());
|
| 52 |
print LOG "$$ <= $from for $lp ($msgid)\n";
|
| 53 |
|
| 54 |
# Get the keyword name
|
| 55 |
my $keyword = '';
|
| 56 |
if ($package =~ /(\S+)_(\S+)/) {
|
| 57 |
$package = $1;
|
| 58 |
$keyword = $2;
|
| 59 |
}
|
| 60 |
|
| 61 |
# Stop if bad X-Loop
|
| 62 |
my @xloop = grep { m/$package\@packages.qa.debian.org/ }
|
| 63 |
($mail->head()->get('X-Loop'));
|
| 64 |
if (scalar(@xloop)) {
|
| 65 |
print LOG "$$ %% Discarding, loop detected\n";
|
| 66 |
exit 0;
|
| 67 |
}
|
| 68 |
|
| 69 |
# Find the real keyword
|
| 70 |
if (! $keyword) {
|
| 71 |
$keyword = 'default';
|
| 72 |
if (scalar(grep { m/owner\@bugs\.debian\.org/ }
|
| 73 |
($mail->head()->get('X-Loop'))
|
| 74 |
)
|
| 75 |
and $mail->head()->get('X-Debian-PR-Message')
|
| 76 |
)
|
| 77 |
{
|
| 78 |
$keyword = 'bts';
|
| 79 |
} elsif (scalar(grep { m/debbugs\@master\.debian\.org/ }
|
| 80 |
($mail->head()->get('Sender'))
|
| 81 |
)
|
| 82 |
and ($mail->head()->get('Subject') =~ /^Processed:/)
|
| 83 |
)
|
| 84 |
{
|
| 85 |
$keyword = 'bts-control';
|
| 86 |
} elsif (($mail->head()->get('X-Katie') or $mail->head()->get('X-Lisa'))
|
| 87 |
and
|
| 88 |
($mail->head()->get('Subject') =~ /^Accepted|INSTALLED|ACCEPTED/) and
|
| 89 |
(scalar(grep { /\.dsc\s*$/ } @{$mail->body()}))
|
| 90 |
)
|
| 91 |
{
|
| 92 |
exit(0) if ($mail->head()->get('Subject') =~ /INSTALLED|ACCEPTED/);
|
| 93 |
$keyword = 'upload-source';
|
| 94 |
} elsif (($mail->head()->get('X-Katie') or $mail->head()->get('X-Lisa'))
|
| 95 |
and
|
| 96 |
($mail->head()->get('Subject') =~ /^Accepted|INSTALLED|ACCEPTED/)
|
| 97 |
)
|
| 98 |
{
|
| 99 |
#exit(0) if ($mail->head()->get('Subject') =~ /INSTALLED|ACCEPTED/);
|
| 100 |
$keyword = 'upload-binary';
|
| 101 |
} elsif ($mail->head()->get('X-Katie') or $mail->head()->get('X-Lisa'))
|
| 102 |
{
|
| 103 |
$keyword = 'katie-other';
|
| 104 |
}
|
| 105 |
}
|
| 106 |
|
| 107 |
print LOG "$$ :: $package $keyword\n";
|
| 108 |
|
| 109 |
# Get the list of subscribers
|
| 110 |
open_db_read();
|
| 111 |
my @emails = $db->get_dup($package);
|
| 112 |
|
| 113 |
# Build the real list of interested people
|
| 114 |
my $wantmail = sub {
|
| 115 |
my $address = shift;
|
| 116 |
foreach (get_tags($address, $package)) {
|
| 117 |
return 1 if ($_ eq $keyword);
|
| 118 |
}
|
| 119 |
print LOG "$$ %% $address (tag not allowed)\n";
|
| 120 |
return 0;
|
| 121 |
};
|
| 122 |
@emails = grep { &$wantmail($_) } @emails;
|
| 123 |
close_db();
|
| 124 |
|
| 125 |
# If default keyword, it may be spam ... check with spamassassin
|
| 126 |
# before approving
|
| 127 |
if ($keyword eq "default") {
|
| 128 |
# Some mails comes from trusted sources
|
| 129 |
# which do not need auto-approval
|
| 130 |
if ($mail->head()->get('X-Bugzilla-Product')) {
|
| 131 |
# Bugzilla(s) are trusted sources
|
| 132 |
$needs_approval = 0;
|
| 133 |
}
|
| 134 |
# Check for spam
|
| 135 |
if (defined($spamc) && $spamc) {
|
| 136 |
open(SPAMC, "| $spamc -c >/dev/null") || die "Can't fork spamc: $!\n";
|
| 137 |
$mail->print(\*SPAMC);
|
| 138 |
my $res = close(SPAMC);
|
| 139 |
if (!$res and !$!) {
|
| 140 |
# Looks like it's spam
|
| 141 |
print STDERR "Your message appears to be spam (according to spamassassin).\n";
|
| 142 |
print STDERR "If it wasn't please retry by writing simple plain text mails.\n";
|
| 143 |
exit 2;
|
| 144 |
}
|
| 145 |
}
|
| 146 |
# Check for approval
|
| 147 |
if (defined($needs_approval) && $needs_approval) {
|
| 148 |
if (! $mail->head()->get('X-PTS-Approved')) {
|
| 149 |
print STDERR "The mail isn't auto-approved as it should be. Please include\n";
|
| 150 |
print STDERR "an 'X-PTS-Approved' (non-empty) header if you want to mail \n";
|
| 151 |
print STDERR "directly the Package Tracking System. This is made to avoid spam.\n";
|
| 152 |
print LOG "$$ ** Discarded, missing X-PTS-Approved\n";
|
| 153 |
exit 2;
|
| 154 |
}
|
| 155 |
}
|
| 156 |
}
|
| 157 |
|
| 158 |
# Modify the mail
|
| 159 |
$mail->head()->add("Precedence", "list");
|
| 160 |
$mail->head()->add("X-Loop", "$package\@packages.qa.debian.org");
|
| 161 |
$mail->head()->add("X-PTS-Package", $package);
|
| 162 |
$mail->head()->add("X-PTS-Keyword", $keyword);
|
| 163 |
$mail->head()->add("X-Unsubscribe",
|
| 164 |
"echo 'unsubscribe $package' | mail pts\@qa.debian.org");
|
| 165 |
|
| 166 |
# Forward the mail ... by group of $nb_by_group addresses
|
| 167 |
my @send;
|
| 168 |
while (defined($_ = shift @emails)) {
|
| 169 |
push @send, $_;
|
| 170 |
# techincally, we didn't send yet, but whatever
|
| 171 |
print LOG "$$ => $_\n";
|
| 172 |
if (scalar(@send) == $nb_by_group) {
|
| 173 |
send_mail(@send);
|
| 174 |
@send = ();
|
| 175 |
}
|
| 176 |
}
|
| 177 |
send_mail(@send) if (scalar(@send));
|
| 178 |
print LOG "$$ Completed\n";
|
| 179 |
|
| 180 |
sub send_mail {
|
| 181 |
return 0 if not scalar(@_);
|
| 182 |
open(MAIL, "| $sendmail -oi @_") || die "Can't fork sendmail: $!\n";
|
| 183 |
$mail->print(\*MAIL);
|
| 184 |
if (not close MAIL) {
|
| 185 |
warn "Problem happened with sendmail: $!\n";
|
| 186 |
print LOG "$$ ** sendmail: $!\n";
|
| 187 |
}
|
| 188 |
}
|
Parent Directory
| 
Revision Log