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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2001 - (show annotations) (download)
Fri Oct 10 17:17:06 2008 UTC (4 years, 8 months ago) by myon
File MIME type: text/plain
File size: 15090 byte(s)
Remove several perl and python includes of private home directories. python-zsi is now officially installed on master.
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 '/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 push @ans, "Here's the list of subscriptions for $address :\n";
187 push @ans, map { $_ . "\n" } (which($address));
188 push @ans, "\n";
189
190 } elsif ($line =~ /^\s*list\s+(\S+)/i) {
191
192 my $package = lc($1);
193 $done{"LIST $package"} = 1;
194 push @ans, "Here's the list of subscribers to $package :\n";
195 push @ans, map { $_ . "\n" } (list($package));
196 push @ans, "\n";
197
198 } elsif ($line =~ /^\s*(?:keyword|tag)s?(?:\s+(\S+@\S+))?\s*$/i) {
199
200 my $address = lc($1);
201 $address = $email if (! (defined($address) && $address));
202 $done{"KEYWORD $address"} = 1;
203 push @ans, "Here's the default list of accepted keywords " .
204 "for $address :\n";
205 push @ans, map { "* " . $_ . "\n" } (get_default_tags($address));
206 push @ans, "\n";
207
208 } elsif ($line =~ /^\s*(?:keyword|tag)s?\s+(\S+)(?:\s+(\S+@\S+))?\s*$/i) {
209
210 my $package = lc($1);
211 my $address = lc($2);
212 $address = $email if (! (defined($address) && $address));
213 $done{"KEYWORD $package $address"} = 1;
214 push @ans, "Here's the list of accepted keywords associated to " .
215 "package\n";
216 push @ans, "$package for $address :\n";
217 push @ans, map { "* " . $_ . "\n" } (get_tags($address, $package));
218 push @ans, "\n";
219
220 } elsif ($line =~ /^\s*(?:keyword|tag)s?(?:\s+(\S+@\S+))?\s+([-+=])\s+(\S+(?:\s+\S+)*)\s*$/i) {
221
222 my $address = lc($1);
223 $address = $email if (! (defined($address) && $address));
224 my $cmd = $2;
225 my @t = split(/[,\s]+/, lc($3));
226 $done{"KEYWORD $address $cmd @t"} = 1;
227 foreach (@t) {
228 push @ans, "WARNING: $_ is not a valid keyword.\n"
229 if (! is_valid_tag($_));
230 }
231 open_db_write();
232 if ($cmd eq "=") {
233 set_default_tags($address, @t);
234 } elsif ($cmd eq "+") {
235 my @tags = get_default_tags($address);
236 push @tags, @t;
237 set_default_tags($address, @tags);
238 } elsif ($cmd eq "-") {
239 my $check = sub {
240 foreach my $t (@t) {
241 return 0 if ($_[0] eq $t);
242 }
243 return 1;
244 };
245 my @tags = grep { &$check($_) } (get_default_tags($address));
246 set_default_tags($address, @tags);
247 }
248 push @ans, "Here's the new default list of accepted keywords " .
249 "for $address :\n";
250 push @ans, map { "* " . $_ . "\n" } (get_default_tags($address));
251 push @ans, "\n";
252 close_db();
253 push @cc, $address if ($address ne $email);
254
255 } elsif ($line =~ /^\s*(?:keyword|tag)s?all(?:\s+(\S+@\S+))?\s+([-+=])\s+(\S+(?:\s+\S+)*)\s*$/i) {
256
257 my $address = lc($1);
258 $address = $email if (! (defined($address) && $address));
259 my $cmd = $2;
260 my @t = split(/[,\s]+/, lc($3));
261 $done{"KEYWORD $address $cmd @t"} = 1;
262 foreach (@t) {
263 push @ans, "WARNING: $_ is not a valid keyword.\n"
264 if (! is_valid_tag($_));
265 }
266 open_db_write();
267 if (not exists $db_tags_content{$address}) {
268 my @tags = get_default_tags($address);
269 set_default_tags($address, @tags);
270 }
271 foreach (sort keys %db_tags_content) {
272 if (/^\Q$address\E(?:#([^#]+))?$/) {
273 my $package = (defined($1) && $1) ? $1 : "";
274 if ($cmd eq "=") {
275 if ($package) {
276 set_tags($address, $package, @t);
277 } else {
278 set_default_tags($address, @t);
279 }
280 } elsif ($cmd eq "+") {
281 if ($package) {
282 my @tags = get_tags($address, $package);
283 push @tags, @t;
284 set_tags($address, $package, @tags);
285 } else {
286 my @tags = get_default_tags($address);
287 push @tags, @t;
288 set_default_tags($address, @tags);
289 }
290 } elsif ($cmd eq "-") {
291 my $check = sub {
292 foreach my $t (@t) {
293 return 0 if ($_[0] eq $t);
294 }
295 return 1;
296 };
297 if ($package) {
298 my @tags = grep { &$check($_) } (get_tags($address, $package));
299 set_tags($address, $package, @tags);
300 } else {
301 my @tags = grep { &$check($_) } (get_default_tags($address));
302 set_default_tags($address, @tags);
303 }
304 }
305 if ($package) {
306 push @ans, "Updated the list of keywords accepted by $address ".
307 "for the package $package.\n";
308 } else {
309 push @ans, "Updated the default list of keywords accepted by $address.\n";
310 }
311 }
312 }
313 close_db();
314 push @cc, $address if ($address ne $email);
315
316 } elsif ($line =~ /^\s*(?:keyword|tag)s?\s+(\S+)(?:\s+(\S+@\S+))?\s+([-+=])\s+(\S+(?:\s+\S+)*)\s*$/i) {
317
318 my $package = lc($1);
319 my $address = lc($2);
320 $address = $email if (! (defined($address) && $address));
321 my $cmd = $3;
322 my @t = split(/[,\s]+/, lc($4));
323 $done{"KEYWORD $package $address $cmd @t"} = 1;
324 foreach (@t) {
325 push @ans, "$_ is not a valid keyword.\n" if (! is_valid_tag($_));
326 }
327 open_db_write();
328 if ($cmd eq "=") {
329 set_tags($address, $package, @t);
330 } elsif ($cmd eq "+") {
331 my @tags = get_tags($address, $package);
332 push @tags, @t;
333 set_tags($address, $package, @tags);
334 } elsif ($cmd eq "-") {
335 my $check = sub {
336 foreach my $t (@t) {
337 return 0 if ($_[0] eq $t);
338 }
339 return 1;
340 };
341 my @tags = grep { &$check($_) } (get_tags($address, $package));
342 set_tags($address, $package, @tags);
343 }
344 push @ans, "Here's the new list of accepted keywords associated to " .
345 "package\n";
346 push @ans, "$package for $address :\n";
347 push @ans, map { "* " . $_ . "\n" } (get_tags($address, $package));
348 push @ans, "\n";
349 close_db();
350 push @cc, $address if ($address ne $email);
351
352 } elsif ($line =~ /^\s*help/i) {
353 push @ans, <DATA>;
354 $done{"HELP"} = 1;
355
356 } elsif ($line =~ /^(--|\s*quit|\s*thanks?|\s*txs)/i) {
357 push @ans, "Stopping processing here.\n";
358 last;
359
360 } else {
361 # accept a few lines of garbage and then stop
362 if (++$nb_err > 5) {
363 if (scalar(keys %done)) {
364 push @ans, "Five lines without new commands: stopping.\n";
365 push @ans, scalar(keys %done)." command(s) successfully treated. Good bye !\n";
366 } else {
367 push @ans, "Too much garbage. Stopping.\n";
368 # This really happens only for spam ... so do not reply
369 exit 0;
370 }
371 last;
372 }
373 }
374 }
375
376 if ((! scalar(keys %done)) and ($nb_err <= 5)) {
377 # No commands treated
378 # Must be spam with less than 5 lines
379 # Use "nobody" as sender to drop useless bounces
380 push @ans, "No command found in the message. Stopping.\n";
381 $sendmaildefault = $sendmailnobody;
382 }
383
384 my $answer = MIME::Entity->build(From => 'owner@packages.qa.debian.org',
385 To => $email,
386 Subject => $subject,
387 Encoding => '8bit',
388 'X-Loop' => 'pts@qa.debian.org',
389 'Bcc' => 'archive-outgoing-control@packages.qa.debian.org',
390 'References' => "$ref $mid",
391 'In-Reply-To:' => $mid,
392 Data => \@ans);
393 my %uniq;
394 foreach (@cc) { $uniq{$_} = 1; }
395 @cc = (keys %uniq);
396 $answer->head()->add('Cc', join(", ", @cc)) if (scalar @cc);
397
398 open(MAIL, "| $sendmaildefault -oi -t") || die "Can't fork sendmail: $!\n";
399 $answer->print(\*MAIL);
400 close MAIL or die "Problem happened with sendmail: $!\n";
401
402
403 __DATA__
404
405 Debian Package Tracking System
406 ------------------------------
407
408 The Package Tracking System (PTS) has the following commands:
409
410 subscribe <srcpackage> [<email>]
411 Subscribes <email> to all messages regarding <srcpackage>. If
412 <email> is not given, it subscribes the From address. If the
413 <srcpackage> is not a valid source package, you'll get a warning.
414 If it's a valid binary package, the mapping will automatically be
415 done for you.
416
417 unsubscribe <srcpackage> [<email>]
418 Unsubscribes <email> from <srcpackage>. Like the subscribe command,
419 it will use the From address if <email> is not given.
420
421 unsubscribeall [<email>]
422 Cancel all subscriptions of <email>. Like the subscribe command,
423 it will use the From address if <email> is not given.
424
425 which [<email>]
426 Tells you which packages <email> is subscribed to.
427
428 keyword [<email>]
429 Tells you the keywords that you are accepting. Each mail sent through
430 the Package Tracking System is associated to a keyword and you receive
431 only the mails associated to keywords that you are accepting. Here is
432 the list of available keywords :
433 * bts: mails coming from the Debian Bug Tracking System
434 * bts-control: mails sent to control@bugs.debian.org
435 * summary: automatic summary mails about the state of a package
436 * cvs: notification of cvs commits
437 * ddtp: notification of translations from the DDTP (cf ddtp.debian.org)
438 * derivatives: notification of changes in derivative distributions
439 * upload-source: announce of a new source upload that has been installed
440 * upload-binary: announce of a new binary-only upload (porting)
441 * katie-other: other mails from ftpmasters (override disparity, etc.)
442 * contact: mails sent to the maintainer via <pkg>@packages.debian.org
443 * default: all the other mails (those which aren't "automatic")
444 By default you have the following keywords : bts, bts-control, summary,
445 upload-source, katie-other, default.
446
447 keyword <srcpackage> [<email>]
448 Same as previous item but for the given source package since
449 you may select a different set of keywords for each source package.
450
451 keyword [<email>] {+|-|=} <list of keywords>
452 Accept (+) or refuse (-) mails associated to the given keyword(s).
453 Define the list (=) of accepted keywords.
454
455 keyword <srcpackage> [<email>] {+|-|=} <list of keywords>
456 Same as previous item but overrides the keywords list for the indicated
457 source package.
458
459 quit
460 thanks
461 Stops processing commands.
462

Properties

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

  ViewVC Help
Powered by ViewVC 1.1.5