| 1 |
hertzog |
1327 |
#!/usr/bin/perl -w
|
| 2 |
|
|
|
| 3 |
|
|
# Copyright 2006 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 POSIX;
|
| 10 |
|
|
use Mail::Verp;
|
| 11 |
|
|
use DB_File;
|
| 12 |
hertzog |
2242 |
use MIME::Entity;
|
| 13 |
hertzog |
1327 |
|
| 14 |
|
|
use strict;
|
| 15 |
|
|
use vars qw($sendmailnobody $pts_dir);
|
| 16 |
|
|
|
| 17 |
|
|
require "common.pl";
|
| 18 |
|
|
|
| 19 |
|
|
sub do_log {
|
| 20 |
|
|
$_ = shift;
|
| 21 |
|
|
open LOG, ">> $pts_dir/logs/bounces-handler.log"
|
| 22 |
|
|
or die("Couldn't open logfile: $!");
|
| 23 |
|
|
printf LOG "%s $$ $_\n", strftime("%Y-%m-%d %H:%M:%S", gmtime());
|
| 24 |
|
|
close LOG;
|
| 25 |
|
|
}
|
| 26 |
|
|
|
| 27 |
|
|
# Extract bounce information
|
| 28 |
hertzog |
1330 |
my $lp = $ENV{'LOCAL_PART'} || "";
|
| 29 |
|
|
die "Aren't you exim?" if (! $lp);
|
| 30 |
|
|
my $verp = Mail::Verp->new(separator => '-');
|
| 31 |
|
|
my ($bounce_addr, $recipient) = $verp->decode("$lp\@packages.qa.debian.org");
|
| 32 |
hertzog |
1327 |
|
| 33 |
hertzog |
1330 |
if ($bounce_addr =~ m/^bounces\+(\d{8})\@packages.qa.debian.org/) {
|
| 34 |
hertzog |
1327 |
my $date = $1;
|
| 35 |
|
|
do_log "<= received bounce for $recipient/$date";
|
| 36 |
|
|
# Update stats and check
|
| 37 |
|
|
open_db_bounces();
|
| 38 |
|
|
update_bounces_db($date, $recipient, 0);
|
| 39 |
|
|
my $toomany = has_too_many_bounces($recipient);
|
| 40 |
|
|
close_db_bounces();
|
| 41 |
|
|
# Unsubscribe email if it bounces too much
|
| 42 |
|
|
if ($toomany) {
|
| 43 |
|
|
do_log ":: too many bounces for $recipient";
|
| 44 |
|
|
my @msg = ("The email $recipient bounces too much, it has been unsubscribed\n",
|
| 45 |
|
|
"from the Debian Package Tracking System. Here's the list of\n",
|
| 46 |
|
|
"subscriptions wich have been removed:\n");
|
| 47 |
|
|
for my $pkg (which($recipient)) {
|
| 48 |
|
|
do_log ":: removed from $pkg";
|
| 49 |
hertzog |
1332 |
unsubscribe($recipient, $pkg);
|
| 50 |
hertzog |
1327 |
push @msg, "* $pkg\@packages.qa.debian.org";
|
| 51 |
|
|
}
|
| 52 |
|
|
push @msg, "-- \n";
|
| 53 |
|
|
push @msg, "Debian Package Tracking System\n";
|
| 54 |
|
|
|
| 55 |
|
|
# Generate the mail
|
| 56 |
|
|
my $mail = MIME::Entity->build(From => 'owner@packages.qa.debian.org',
|
| 57 |
|
|
To => $recipient,
|
| 58 |
hertzog |
1332 |
Cc => 'owner@packages.qa.debian.org',
|
| 59 |
hertzog |
1327 |
Subject => "All your subscriptions from the PTS have been cancelled",
|
| 60 |
|
|
Encoding => '8bit',
|
| 61 |
|
|
'X-Loop' => 'pts@qa.debian.org',
|
| 62 |
|
|
Data => \@msg);
|
| 63 |
|
|
|
| 64 |
|
|
# Send the mail
|
| 65 |
hertzog |
1332 |
open(MAIL, "| $sendmailnobody -oi $recipient owner\@packages.qa.debian.org") || die "Can't fork sendmail: $!\n";
|
| 66 |
|
|
$mail->print(\*MAIL);
|
| 67 |
|
|
if (not close MAIL) {
|
| 68 |
|
|
do_log "** sendmail: $!";
|
| 69 |
|
|
}
|
| 70 |
hertzog |
1328 |
} else {
|
| 71 |
|
|
do_log ":: not enough bounces to discard $recipient";
|
| 72 |
hertzog |
1327 |
}
|
| 73 |
|
|
} else {
|
| 74 |
hertzog |
1331 |
do_log "\%\% couldn't extract email from $lp: $bounce_addr $recipient";
|
| 75 |
hertzog |
1327 |
}
|
| 76 |
|
|
|
| 77 |
hertzog |
2241 |
exit 0;
|
Parent Directory
| 
Revision Log