pts/bin/dispatch.pl

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