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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2369 - (show annotations) (download)
Fri May 14 10:04:44 2010 UTC (3 years ago) by hertzog
File MIME type: text/plain
File size: 15391 byte(s)
Add support for derivatives-bugs tag in the PTS.
1 #!/usr/bin/perl -w
2
3 # Copyright 2002-2010 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 ConfirmationSpool;
10 use MIME::Parser;
11 use MIME::Entity;
12 use Mail::Address;
13 use DB_File;
14
15 use strict;
16 use vars qw($spool_dir $conf_sub_template $conf_unsub_template
17 $conf_unsuball_template $sendmaildefault $sendmailnobody
18 %db_tags_content);
19
20 # Mailbot for pts@qa.debian.org
21
22 =head1 INSTALLATION INSTRUCTIONS
23
24 This script needs libmime-perl and libmailtools-perl.
25
26 =cut
27
28 require "common.pl";
29
30 # Create a ConfirmationSpool object to handle the email authentication
31 my $cs = ConfirmationSpool->new($spool_dir);
32 $cs->set_sendmail($sendmaildefault);
33 $cs->clean();
34
35 # Parse the mail
36 my $parser = MIME::Parser->new();
37 $parser->output_to_core(1);
38 my $mail = $parser->parse(\*STDIN) or die "Parse failed !\n";
39
40 # Stop if bad X-Loop
41 my $xloop = $mail->head()->get('X-Loop');
42 if (defined($xloop) && ($xloop =~ /pts\@qa.debian.org/)) {
43 exit 0;
44 }
45
46 # Extract the subject and the sender email
47 my $subject = $mail->head()->get("Subject") || "Your mail";
48 my $mid = $mail->head()->get("Message-ID") || "";
49 my $ref = $mail->head()->get("References") || "";
50 my ($email_obj) = Mail::Address->parse($mail->head()->get("From"));
51 my $email = lc($email_obj->address());
52 my @cc;
53
54 # Find the text/plain part containing commands...
55 if ($mail->is_multipart()) {
56 $mail = $mail->parts(0); # Assume the first part is the interesting one
57 }
58
59 # Lines of the answer that we'll send
60 my @ans = ();
61
62 # Lines of the mail we got
63 my @lines = ("Subject: " . $subject);
64 if (defined $mail->bodyhandle()) {
65 push @lines, $mail->bodyhandle()->as_lines();
66 } else {
67 push @ans, ("Warning: your message's body couldn't be decoded.\n",
68 "Try again with a simple plain-text message.\n", "\n");
69 }
70
71 push @ans, ("Processing commands for pts\@qa.debian.org:\n", "\n");
72 my $nb_err = 0;
73 my %done;
74
75 # Prepare the subject for the answer
76 if ($subject !~ /^\s*Re: /) {
77 $subject = "Re: $subject";
78 }
79
80 foreach my $line (@lines) {
81 push @ans, "> $line";
82
83 # Hack for subject ...
84 if ($line =~ /^Subject: (?:Re\s*:\s*)?(.*)$/i) {
85 push @ans, "\n";
86 $line = $1;
87 }
88
89 # Try to detect commands
90 if ($line =~ /^\s*#/) {
91 next;
92
93 } elsif ($line =~ /^\s*subscribe\s+(\S+)(?:\s+(\S+))?/i) {
94 my ($package, $address) = (lc($1), lc($2));
95 $address = $email if (! (defined($address) && $address));
96 next if (defined($done{"SUBSCRIBE $package $address"})); # Not twice..
97 my @explanation;
98 ($package, @explanation) = map_package($package);
99 push @ans, @explanation;
100 $cs->set_confirmation_template($conf_sub_template);
101 $cs->ask_confirmation($address, "SUBSCRIBE $package $address",
102 { "PACKAGE" => $package });
103 $done{"SUBSCRIBE $package $address"} = 1;
104 push @ans, "A confirmation mail has been sent to $address.\n";
105 push @ans, "\n";
106 push @cc, $address if ($address ne $email);
107
108 } elsif ($line =~ /^\s*unsubscribe\s+(\S+)(?:\s+(\S+))?/i) {
109 my ($package, $address) = (lc($1), lc($2));
110 $address = $email if (! (defined($address) && $address));
111 if (not is_subscribed_to($address, $package)) {
112 my @explanation;
113 ($package, @explanation) = map_package($package);
114 push @ans, @explanation;
115 }
116 $cs->set_confirmation_template($conf_unsub_template);
117 $cs->ask_confirmation($address, "UNSUBSCRIBE $package $address",
118 { "PACKAGE" => $package });
119 $done{"UNSUBSCRIBE $package $address"} = 1;
120 push @ans, "A confirmation mail has been sent to $address.\n";
121 push @ans, "\n";
122 push @cc, $address if ($address ne $email);
123
124 } elsif ($line =~ /^\s*unsubscribeall(?:\s+(\S+))?/i) {
125 my $address = lc($1);
126 $address = $email if (! (defined($address) && $address));
127 my @explanation;
128 $cs->set_confirmation_template($conf_unsuball_template);
129 $cs->ask_confirmation($address, "UNSUBSCRIBEALL $address");
130 $done{"UNSUBSCRIBEALL $address"} = 1;
131 push @ans, "A confirmation mail has been sent to $address.\n";
132 push @ans, "\n";
133 push @cc, $address if ($address ne $email);
134
135 } elsif ($line =~ /^\s*confirm\s+(\S+)/i) {
136 my $key = $1;
137 next if (defined($done{"CONFIRM $key"})); # Not twice..
138 my $cmd = $cs->confirm($key);
139 if (defined($cmd)) {
140 my ($package, $address);
141 if ($cmd =~ /^SUBSCRIBE (\S+) (\S+)/) {
142 ($package, $address) = (lc($1), lc($2));
143 if (subscribe($address, $package)) {
144 push @ans, "$address has been subscribed to " .
145 "$package\@packages.qa.debian.org.\n";
146 $subject = "You are now subscribed to $package";
147 } else {
148 push @ans, "$address is already subscribed ...\n";
149 }
150 } elsif ($cmd =~ /^UNSUBSCRIBE (\S+) (\S+)/) {
151 ($package, $address) = (lc($1), lc($2));
152 if (unsubscribe($address, $package)) {
153 push @ans, "$address has been unsubscribed from " .
154 "$package\@packages.qa.debian.org.\n";
155 $subject = "You are no longer subscribed to $package";
156 } else {
157 push @ans, "$address is not subscribed, you can't unsubscribe.\n";
158 }
159 } elsif ($cmd =~ /^UNSUBSCRIBEALL (\S+)/) {
160 $address = lc($1);
161 push @ans, "All your subscriptions have been terminated :\n";
162 foreach my $package (which($address)) {
163 if (unsubscribe($address, $package)) {
164 push @ans, "$address has been unsubscribed from " .
165 "$package\@packages.qa.debian.org.\n";
166 $subject = "All your subcriptions have been terminated";
167 } else {
168 push @ans, "$address is not subscribed, you can't unsubscribe.\n";
169 }
170 }
171 } else {
172 push @ans, "Confirmation failed. Retry with a new command.\n";
173 }
174 $done{"CONFIRM $key"} = 1;
175 push @cc, $address if ($address ne $email);
176 } else {
177 push @ans, "Confirmation failed. Retry with a new command.\n";
178 }
179 push @ans, "\n";
180
181 } elsif ($line =~ /^\s*which(?:\s+(\S+))?/i) {
182
183 my $address = lc($1);
184 $address = $email if (! (defined($address) && $address));
185 $done{"WHICH $address"} = 1;
186 my $default_tags = join ',', get_default_tags($address);
187 push @ans, "Here's the list of subscriptions for $address :\n";
188 push @ans, map {
189 my $tags = join ',', get_tags($address, $_);
190 "* $_" . ($tags ne $default_tags ? " [$tags]" : "") . "\n"
191 } (which($address));
192 push @ans, "\n";
193
194 } elsif ($line =~ /^\s*(?:list|who)\s+(\S+)/i) {
195
196 my $package = lc($1);
197 $done{"LIST $package"} = 1;
198 push @ans, "Here's the list of subscribers to $package :\n";
199 push @ans, map { $_ . "\n" } (list($package));
200 push @ans, "\n";
201
202 } elsif ($line =~ /^\s*(?:keyword|tag)s?(?:\s+(\S+@\S+))?\s*$/i) {
203
204 my $address = lc($1);
205 $address = $email if (! (defined($address) && $address));
206 $done{"KEYWORD $address"} = 1;
207 push @ans, "Here's the default list of accepted keywords " .
208 "for $address :\n";
209 push @ans, map { "* " . $_ . "\n" } (get_default_tags($address));
210 push @ans, "\n";
211
212 } elsif ($line =~ /^\s*(?:keyword|tag)s?\s+(\S+)(?:\s+(\S+@\S+))?\s*$/i) {
213
214 my $package = lc($1);
215 my $address = lc($2);
216 $address = $email if (! (defined($address) && $address));
217 $done{"KEYWORD $package $address"} = 1;
218 push @ans, "Here's the list of accepted keywords associated to " .
219 "package\n";
220 push @ans, "$package for $address :\n";
221 push @ans, map { "* " . $_ . "\n" } (get_tags($address, $package));
222 push @ans, "\n";
223
224 } elsif ($line =~ /^\s*(?:keyword|tag)s?(?:\s+(\S+@\S+))?\s+([-+=])\s+(\S+(?:\s+\S+)*)\s*$/i) {
225
226 my $address = lc($1);
227 $address = $email if (! (defined($address) && $address));
228 my $cmd = $2;
229 my @t = split(/[,\s]+/, lc($3));
230 $done{"KEYWORD $address $cmd @t"} = 1;
231 foreach (@t) {
232 push @ans, "WARNING: $_ is not a valid keyword.\n"
233 if (! is_valid_tag($_));
234 }
235 open_db_write();
236 if ($cmd eq "=") {
237 set_default_tags($address, @t);
238 } elsif ($cmd eq "+") {
239 my @tags = get_default_tags($address);
240 push @tags, @t;
241 set_default_tags($address, @tags);
242 } elsif ($cmd eq "-") {
243 my $check = sub {
244 foreach my $t (@t) {
245 return 0 if ($_[0] eq $t);
246 }
247 return 1;
248 };
249 my @tags = grep { &$check($_) } (get_default_tags($address));
250 set_default_tags($address, @tags);
251 }
252 push @ans, "Here's the new default list of accepted keywords " .
253 "for $address :\n";
254 push @ans, map { "* " . $_ . "\n" } (get_default_tags($address));
255 push @ans, "\n";
256 close_db();
257 push @cc, $address if ($address ne $email);
258
259 } elsif ($line =~ /^\s*(?:keyword|tag)s?all(?:\s+(\S+@\S+))?\s+([-+=])\s+(\S+(?:\s+\S+)*)\s*$/i) {
260
261 my $address = lc($1);
262 $address = $email if (! (defined($address) && $address));
263 my $cmd = $2;
264 my @t = split(/[,\s]+/, lc($3));
265 $done{"KEYWORD $address $cmd @t"} = 1;
266 foreach (@t) {
267 push @ans, "WARNING: $_ is not a valid keyword.\n"
268 if (! is_valid_tag($_));
269 }
270 open_db_write();
271 if (not exists $db_tags_content{$address}) {
272 my @tags = get_default_tags($address);
273 set_default_tags($address, @tags);
274 }
275 foreach (sort keys %db_tags_content) {
276 if (/^\Q$address\E(?:#([^#]+))?$/) {
277 my $package = (defined($1) && $1) ? $1 : "";
278 if ($cmd eq "=") {
279 if ($package) {
280 set_tags($address, $package, @t);
281 } else {
282 set_default_tags($address, @t);
283 }
284 } elsif ($cmd eq "+") {
285 if ($package) {
286 my @tags = get_tags($address, $package);
287 push @tags, @t;
288 set_tags($address, $package, @tags);
289 } else {
290 my @tags = get_default_tags($address);
291 push @tags, @t;
292 set_default_tags($address, @tags);
293 }
294 } elsif ($cmd eq "-") {
295 my $check = sub {
296 foreach my $t (@t) {
297 return 0 if ($_[0] eq $t);
298 }
299 return 1;
300 };
301 if ($package) {
302 my @tags = grep { &$check($_) } (get_tags($address, $package));
303 set_tags($address, $package, @tags);
304 } else {
305 my @tags = grep { &$check($_) } (get_default_tags($address));
306 set_default_tags($address, @tags);
307 }
308 }
309 if ($package) {
310 push @ans, "Updated the list of keywords accepted by $address ".
311 "for the package $package.\n";
312 } else {
313 push @ans, "Updated the default list of keywords accepted by $address.\n";
314 }
315 }
316 }
317 close_db();
318 push @cc, $address if ($address ne $email);
319
320 } elsif ($line =~ /^\s*(?:keyword|tag)s?\s+(\S+)(?:\s+(\S+@\S+))?\s+([-+=])\s+(\S+(?:\s+\S+)*)\s*$/i) {
321
322 my $package = lc($1);
323 my $address = lc($2);
324 $address = $email if (! (defined($address) && $address));
325 my $cmd = $3;
326 my @t = split(/[,\s]+/, lc($4));
327 $done{"KEYWORD $package $address $cmd @t"} = 1;
328 foreach (@t) {
329 push @ans, "$_ is not a valid keyword.\n" if (! is_valid_tag($_));
330 }
331 open_db_write();
332 if ($cmd eq "=") {
333 set_tags($address, $package, @t);
334 } elsif ($cmd eq "+") {
335 my @tags = get_tags($address, $package);
336 push @tags, @t;
337 set_tags($address, $package, @tags);
338 } elsif ($cmd eq "-") {
339 my $check = sub {
340 foreach my $t (@t) {
341 return 0 if ($_[0] eq $t);
342 }
343 return 1;
344 };
345 my @tags = grep { &$check($_) } (get_tags($address, $package));
346 set_tags($address, $package, @tags);
347 }
348 push @ans, "Here's the new list of accepted keywords associated to " .
349 "package\n";
350 push @ans, "$package for $address :\n";
351 push @ans, map { "* " . $_ . "\n" } (get_tags($address, $package));
352 push @ans, "\n";
353 close_db();
354 push @cc, $address if ($address ne $email);
355
356 } elsif ($line =~ /^\s*help/i) {
357 push @ans, <DATA>;
358 $done{"HELP"} = 1;
359
360 } elsif ($line =~ /^(--|\s*quit|\s*thanks?|\s*txs)/i) {
361 push @ans, "Stopping processing here.\n";
362 last;
363
364 } else {
365 # accept a few lines of garbage and then stop
366 if (++$nb_err > 5) {
367 if (scalar(keys %done)) {
368 push @ans, "Five lines without new commands: stopping.\n";
369 push @ans, scalar(keys %done)." command(s) successfully treated. Good bye !\n";
370 } else {
371 push @ans, "Too much garbage. Stopping.\n";
372 # This really happens only for spam ... so do not reply
373 exit 0;
374 }
375 last;
376 }
377 }
378 }
379
380 if ((! scalar(keys %done)) and ($nb_err <= 5)) {
381 # No commands treated
382 # Must be spam with less than 5 lines
383 # Use "nobody" as sender to drop useless bounces
384 push @ans, "No command found in the message. Stopping.\n";
385 $sendmaildefault = $sendmailnobody;
386 }
387
388 my $answer = MIME::Entity->build(From => 'owner@packages.qa.debian.org',
389 To => $email,
390 Subject => $subject,
391 Encoding => '8bit',
392 'X-Loop' => 'pts@qa.debian.org',
393 'Bcc' => 'archive-outgoing-control@packages.qa.debian.org',
394 'References' => "$ref $mid",
395 'In-Reply-To:' => $mid,
396 Data => \@ans);
397 my %uniq;
398 foreach (@cc) { $uniq{$_} = 1; }
399 @cc = (keys %uniq);
400 $answer->head()->add('Cc', join(", ", @cc)) if (scalar @cc);
401
402 open(MAIL, "| $sendmaildefault -oi -t") || die "Can't fork sendmail: $!\n";
403 $answer->print(\*MAIL);
404 close MAIL or die "Problem happened with sendmail: $!\n";
405
406
407 __DATA__
408
409 Debian Package Tracking System
410 ------------------------------
411
412 The Package Tracking System (PTS) has the following commands:
413
414 subscribe <srcpackage> [<email>]
415 Subscribes <email> to all messages regarding <srcpackage>. If
416 <email> is not given, it subscribes the From address. If the
417 <srcpackage> is not a valid source package, you'll get a warning.
418 If it's a valid binary package, the mapping will automatically be
419 done for you.
420
421 unsubscribe <srcpackage> [<email>]
422 Unsubscribes <email> from <srcpackage>. Like the subscribe command,
423 it will use the From address if <email> is not given.
424
425 unsubscribeall [<email>]
426 Cancel all subscriptions of <email>. Like the subscribe command,
427 it will use the From address if <email> is not given.
428
429 which [<email>]
430 Tells you which packages <email> is subscribed to.
431
432 keyword [<email>]
433 Tells you the keywords that you are accepting. Each mail sent through
434 the Package Tracking System is associated to a keyword and you receive
435 only the mails associated to keywords that you are accepting. Here is
436 the list of available keywords :
437 * bts: mails coming from the Debian Bug Tracking System
438 * bts-control: mails sent to control@bugs.debian.org
439 * summary: automatic summary mails about the state of a package
440 * cvs: notification of cvs commits
441 * ddtp: notification of translations from the DDTP (cf ddtp.debian.org)
442 * derivatives: notification of changes in derivative distributions
443 * derivatives-bugs: bug traffic in derivative distributions
444 * upload-source: announce of a new source upload that has been installed
445 * upload-binary: announce of a new binary-only upload (porting)
446 * katie-other: other mails from ftpmasters (override disparity, etc.)
447 * contact: mails sent to the maintainer via <pkg>@packages.debian.org
448 * buildd: notification of build failures on build daemons
449 * default: all the other mails (those which aren't "automatic")
450 By default you have the following keywords : bts, bts-control, summary,
451 upload-source, katie-other, buildd, default.
452
453 keyword <srcpackage> [<email>]
454 Same as previous item but for the given source package since
455 you may select a different set of keywords for each source package.
456
457 keyword [<email>] {+|-|=} <list of keywords>
458 Accept (+) or refuse (-) mails associated to the given keyword(s).
459 Define the list (=) of accepted keywords.
460
461 keyword <srcpackage> [<email>] {+|-|=} <list of keywords>
462 Same as previous item but overrides the keywords list for the indicated
463 source package.
464
465 quit
466 thanks
467 Stops processing commands.
468

Properties

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

  ViewVC Help
Powered by ViewVC 1.1.5