/[qa]/trunk/pts/bin/dispatch.pl
ViewVC logotype

Contents of /trunk/pts/bin/dispatch.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3166 - (show annotations) (download)
Tue Jun 10 08:27:57 2014 UTC (4 months, 2 weeks ago) by myon
File MIME type: text/plain
File size: 5500 byte(s)
Add List-Id header to PTS mail (Raphael Geissert)
1 #!/usr/bin/perl -w
2
3 # Copyright 2002-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 '/srv/packages.qa.debian.org/perl';
8
9 use POSIX;
10 use Mail::Internet;
11 use Mail::Address;
12 use Mail::Verp;
13 use DB_File;
14
15 use strict;
16 use vars qw($db $sendmail $pts_dir);
17
18 =head1 Script for *@packages.qa.debian.org
19
20 =head1 INSTALLATION INSTRUCTIONS
21
22 This script needs libmailtools-perl and libmail-verp-perl.
23
24 =cut
25
26 require "common.pl";
27
28 # Local configuration variables
29 my $debug = 0;
30 my $needs_approval = 1;
31 my $bounce_addr = 'bounces+DATE@packages.qa.debian.org';
32
33 # Get the package name
34 my $package = lc($ENV{'LOCAL_PART'}.$ENV{'LOCAL_PART_SUFFIX'}); # 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 if ($package =~ /^bounces\+/) {
39 # Execute bounce handler ...
40 exec "$pts_dir/bin/bounces-handler.pl", @ARGV;
41 }
42
43 sub do_log($) {
44 my ($msg) = @_;
45 open LOG, ">>", "$pts_dir/logs/dispatch.log"
46 or die("Couldn't open logfile: $!");
47 printf LOG ("%s $$ %s\n", strftime("%Y-%m-%d %H:%M:%S", gmtime()), $msg);
48 close LOG;
49 }
50
51 my $lp = lc($ENV{'LOCAL_PART'}.$ENV{'LOCAL_PART_SUFFIX'});
52
53 # Parse the mail
54 my $mail;
55 if (not ($mail = Mail::Internet->new(\*STDIN))) {
56 do_log "** Parsing message for $lp failed";
57 die "Parse failed !\n";
58 }
59
60 my $msgid = $mail->head()->get("Message-ID");
61 $msgid = 'no-msgid-present@localhost' unless defined($msgid);
62 chomp($msgid);
63 my ($email_obj) = Mail::Address->parse($mail->head()->get("From"));
64 my $from = lc($email_obj->address());
65 do_log "<= $from for $lp $msgid";
66
67 # Get the keyword name
68 my $keyword = '';
69 if ($package =~ /(\S+)_(\S+)/) {
70 $package = $1;
71 $keyword = $2;
72 }
73
74 # Stop if bad X-Loop
75 my @xloop = grep { m/$package\@packages.qa.debian.org/ }
76 ($mail->head()->get('X-Loop'));
77 if (scalar(@xloop)) {
78 do_log "\%\% Discarding, loop detected";
79 exit 0;
80 }
81
82 # Find the real keyword
83 if (! $keyword) {
84 $keyword = 'default';
85 if (scalar(grep { m/owner\@bugs\.debian\.org/ }
86 ($mail->head()->get('X-Loop'))
87 )
88 and ($mail->head()->get('X-Debian-PR-Message') =~ /^transcript/)
89 )
90 {
91 $keyword = 'bts-control';
92 } elsif (scalar(grep { m/owner\@bugs\.debian\.org/ }
93 ($mail->head()->get('X-Loop'))) and
94 $mail->head()->get('X-Debian-PR-Message')
95 )
96 {
97 $keyword = 'bts';
98 } elsif ($mail->head()->get('X-DAK') and
99 $mail->head()->get('Subject') =~ /^Accepted|INSTALLED|ACCEPTED/ and
100 (scalar(grep { /\.dsc\s*$/ } @{$mail->body()}))
101 )
102 {
103 exit(0) if ($mail->head()->get('Subject') =~ /INSTALLED|ACCEPTED/);
104 $keyword = 'upload-source';
105 } elsif ($mail->head()->get('X-DAK') and
106 $mail->head()->get('Subject') =~ /^Accepted|INSTALLED|ACCEPTED/)
107 {
108 #exit(0) if ($mail->head()->get('Subject') =~ /INSTALLED|ACCEPTED/);
109 $keyword = 'upload-binary';
110 } elsif ($mail->head()->get('X-DAK') or
111 $mail->head()->get('Subject') =~ /^Comments regarding .*\.changes$/)
112 {
113 $keyword = 'katie-other';
114 }
115 }
116
117 do_log ":: $package $keyword";
118
119 # If default keyword, it may be spam ... only approve special mails
120 if ($keyword eq "default") {
121 # Some mails comes from trusted sources
122 # which do not need auto-approval
123 if ($mail->head()->get('X-Bugzilla-Product')) {
124 # Bugzilla(s) are trusted sources
125 $needs_approval = 0;
126 }
127 # Check for approval
128 if (defined($needs_approval) && $needs_approval) {
129 if (! $mail->head()->get('X-PTS-Approved')) {
130 do_log "** Discarded, missing X-PTS-Approved";
131 exit 0;
132 }
133 }
134 }
135
136 # Get the list of subscribers
137 open_db_read();
138 my @emails = $db->get_dup($package);
139
140 # Build the real list of interested people
141 my $wantmail = sub {
142 my $address = shift;
143 foreach (get_tags($address, $package)) {
144 return 1 if ($_ eq $keyword);
145 }
146 return 0;
147 };
148 @emails = grep { &$wantmail($_) } @emails;
149 close_db();
150
151 # Modify the mail
152 $mail->head()->add("Precedence", "list");
153 $mail->head()->add("X-Loop", "$package\@packages.qa.debian.org");
154 $mail->head()->add("X-Debian", "PTS");
155 $mail->head()->add("X-Debian-Package", $package);
156 $mail->head()->add("X-PTS-Package", $package);
157 $mail->head()->add("X-PTS-Keyword", $keyword);
158 $mail->head()->add("List-Id", "<$package.$keyword.packages.qa.debian.org>");
159 $mail->head()->add("List-Unsubscribe",
160 "<mailto:pts\@qa.debian.org?body=unsubscribe%20$package>");
161
162 # Forward the mail ... with a VERP header
163 my $date = strftime('%Y%m%d', gmtime());
164 $bounce_addr =~ s/DATE/$date/;
165
166 # Keep track of sent mails (to be able to match them with bounces later)
167 open_db_bounces();
168 foreach my $email (@emails) {
169 update_bounces_db($date, $email, 1);
170 }
171 close_db_bounces();
172
173 # Really send mails
174 my $archive = 1;
175 my $verp = Mail::Verp->new(separator => '-');
176 foreach my $email (@emails) {
177 my $from = $verp->encode($bounce_addr, $email);
178 send_mail($from, $email, $archive);
179 do_log "=> $email";
180 $archive = 0;
181 }
182 do_log "Completed";
183
184 sub send_mail {
185 my ($from, $to, $archive) = @_;
186 if ($archive) {
187 open(MAIL, "| $sendmail -f $from -oi archive-outgoing\@packages.qa.debian.org $to") || die "Can't fork sendmail: $!\n";
188 } else {
189 open(MAIL, "| $sendmail -f $from -oi $to") || die "Can't fork sendmail: $!\n";
190 }
191 $mail->print(\*MAIL);
192 if (not close MAIL) {
193 warn "Problem happened with sendmail: $!\n";
194 do_log "** sendmail: $!";
195 }
196 }

Properties

Name Value
svn:eol-style native
svn:executable *
svn:keywords Author Date Id Revision

  ViewVC Help
Powered by ViewVC 1.1.5