« back to all changes in this revision
Viewing changes to bin/buildd-mail
- browse files at revision 17
- compare with another revision
- download diff
- download tarball
- view history from revision 17
- Committer: Bazaar Package Importer
- Author(s): Kees Cook
- Date: 2009-05-09 16:06:44 UTC
- mfrom: (8.1.6 upstream) (3.1.3 squeeze)
- Revision ID: james.westby@ubuntu.com-20090509160644-9k0fgp6c2ajcu54h
Tags: 0.58.2-1ubuntu1
* Merge from debian unstable, remaining changes:
- bin/sbuild, lib/Sbuild/{Base,Conf,Options}.pm: add --setup-hook
to allow pre-build modifications to underlying chroots (needed
to adjust pockets and components in sources.list). (debian bug
500746).
- bin/sbuild, lib/Sbuild/{Base,Conf,Options}.pm: add --setup-hook
to allow pre-build modifications to underlying chroots (needed
to adjust pockets and components in sources.list). (debian bug
500746).
- files added:
- bin/buildd
- db
- lib/Sbuild/DB
- files removed:
- scripts/config.guess
- src
- files modified:
- ChangeLog
added
removed
bin/buildd-mail
1
#!/usr/bin/perl
2
#
3
# buildd-mail: mail answer processor for buildd
4
# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
5
#
6
# This program is free software: you can redistribute it and/or modify
7
# it under the terms of the GNU General Public License as published by
8
# the Free Software Foundation, either version 2 of the License, or
9
# (at your option) any later version.
10
#
11
# This program is distributed in the hope that it will be useful, but
12
# WITHOUT ANY WARRANTY; without even the implied warranty of
13
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14
# General Public License for more details.
15
#
16
# You should have received a copy of the GNU General Public License
17
# along with this program. If not, see
18
# <http://www.gnu.org/licenses/>.
19
#
20
#######################################################################
21
22
use strict;
23
use warnings;
24
use Buildd;
25
use Buildd::Conf;
26
use Sbuild qw(binNMU_version);
27
use POSIX;
28
use File::Basename;
29
use MIME::QuotedPrint;
30
use MIME::Base64;
31
32
sub process_mail ();
33
sub prepare_for_upload ($$);
34
sub redo_new_version ($$$);
35
sub purge_pkg ($$);
36
sub remove_from_upload ($);
37
sub append_to_REDO ($$);
38
sub remove_from_REDO ($);
39
sub append_to_SKIP ($);
40
sub check_is_outdated ($$);
41
sub is_outdated ($$);
42
sub register_outdated ($$$);
43
sub set_to_failed ($$$);
44
sub set_to_depwait ($$$);
45
sub give_back ($$);
46
sub no_build ($$);
47
sub get_fail_msg ($$);
48
sub check_state ($$@);
49
sub check_building_any_dist ($);
50
sub get_files_from_changes ($);
51
sub is_for_non_us ($$);
52
sub is_for_security ($);
53
sub get_dists_from_changes ($);
54
sub reply ($);
55
sub is_blacklisted ($);
56
sub add_error_mail ();
57
58
Buildd::Conf::init();
59
60
chdir( $Buildd::Conf::HOME );
61
62
lock_file( "daemon.log" );
63
END { unlock_file( "daemon.log" ); }
64
open_log();
65
66
my($error, $short_error, %header, $body_text);
67
68
process_mail();
69
exit 0;
70
71
72
sub process_mail () {
73
74
my $header_text = "";
75
my $lastheader = "";
76
$body_text = "";
77
undef %header;
78
$error = $short_error = "";
79
80
while( <STDIN> ) {
81
$header_text .= $_;
82
last if /^$/;
83
84
if (/^\s/ && $lastheader) {
85
$_ =~ s/^\s+//;
86
$_ = "$lastheader $_";
87
}
88
89
if (/^From (\S+)/) {
90
;
91
}
92
if (/^([\w\d-]+):\s*(.*)\s*$/) {
93
my $hname;
94
($hname = $1) =~ y/A-Z/a-z/;
95
$header{$hname} = $2;
96
$lastheader = $_;
97
chomp( $lastheader );
98
}
99
else {
100
$lastheader = "";
101
}
102
}
103
while( <STDIN> ) {
104
last if !/^\s*$/;
105
}
106
$body_text .= $_;
107
108
if (!eof)
109
{ local($/); undef $/; $body_text .= <STDIN>; }
110
111
if ($header{'from'} =~ /mail\s+delivery\s+(sub)?system|mailer.\s*daemon/i) {
112
# is an error mail from a mailer daemon
113
# To avoid mail loops if this error resulted from a mail we sent
114
# outselves, we break the loop by not forwarding this mail after the 5th
115
# error mail within 8 hours or so.
116
my $n = add_error_mail();
117
if ($n > 5) {
118
logger( "Too much error mails ($n) within ",
119
int($Buildd::Conf::error_mail_window/(60*60)), " hours\n",
120
"Not forwarding mail from $header{'from'}\n",
121
"Subject: $header{'subject'}\n" );
122
return;
123
}
124
}
125
126
goto forward_mail if !$header{'subject'};
127
my $subject = $header{'subject'};
128
129
if ($subject =~ /^Re: Log for \S+ build of (\S+)(?: on [\w-]+)? \(dist=(\S+)\)/i) {
130
# reply to a build log
131
my( $package, $dist ) = ( $1, $2 );
132
$body_text =~ /^(\S+)/;
133
if (defined($header{'content-transfer-encoding'})) {
134
# Decode the mail if necessary.
135
if ($header{'content-transfer-encoding'} =~ /quoted-printable/) {
136
$body_text = decode_qp($body_text);
137
} elsif ($header{'content-transfer-encoding'} =~ /base64/) {
138
$body_text = decode_base64($body_text);
139
}
140
}
141
my $keyword = $1;
142
my $from = $header{'from'};
143
$from = $1 if $from =~ /<(.+)>/;
144
logger( "Log reply from $from\n" );
145
my %newv;
146
147
if ($keyword =~ /^not-for-us/) {
148
no_build( $package, $dist );
149
purge_pkg( $package, $dist );
150
}
151
elsif ($keyword =~ /^up(l(oad)?)?-rem/) {
152
remove_from_upload( $package );
153
}
154
elsif (check_is_outdated( $dist, $package )) {
155
# $error has been set already -> no action here
156
}
157
elsif ($keyword =~ /^fail/) {
158
my $text = $body_text;
159
$text =~ s/^fail.*\n(\s*\n)*//;
160
$text =~ s/\n+$/\n/;
161
set_to_failed( $package, $dist, $text );
162
purge_pkg( $package, $dist );
163
}
164
elsif ($keyword =~ /^ret/) {
165
if (!check_state( $package, $dist, "Building" )) {
166
# $error already set
167
}
168
else {
169
append_to_REDO( $package, $dist );
170
}
171
}
172
elsif ($keyword =~ /^d(ep(endency)?)?-(ret|w)/) {
173
if (!check_state( $package, $dist, "Building" )) {
174
# $error already set
175
}
176
else {
177
$body_text =~ /^\S+\s+(.*)$/m;
178
my $deps = $1;
179
set_to_depwait( $package, $dist, $deps );
180
purge_pkg( $package, $dist );
181
}
182
}
183
elsif ($keyword =~ /^man/) {
184
if (!check_state( $package, $dist, "Building" )) {
185
# $error already set
186
}
187
else {
188
# no action
189
logger( "$package($dist) will be finished manually\n" );
190
}
191
}
192
elsif ($keyword =~ /^newv/) {
193
# build a newer version instead
194
$body_text =~ /^newv\S*\s+(\S+)/;
195
my $newv = $1;
196
if ($newv =~ /_/) {
197
logger( "Removing unneeded package name from $newv\n" );
198
$newv =~ s/^.*_//;
199
logger( "Result: $newv\n" );
200
}
201
my $pkgname;
202
($pkgname = $package) =~ s/_.*$//;
203
redo_new_version( $dist, $package, "${pkgname}_${newv}" );
204
purge_pkg( $package, $dist );
205
}
206
elsif ($keyword =~ /^(give|back)/) {
207
$body_text =~ /^(give|back) ([-0-9]+)/;
208
my $pri = $1;
209
if (!check_state( $package, $dist, "Building" )) {
210
# $error already set
211
}
212
else {
213
give_back( $package, $dist );
214
purge_pkg( $package, $dist );
215
}
216
}
217
elsif ($keyword =~ /^purge/) {
218
purge_pkg( $package, $dist );
219
}
220
elsif ($body_text =~ /^---+\s*BEGIN PGP SIGNED MESSAGE/) {
221
if (prepare_for_upload( $package, $body_text )) {
222
purge_pkg( $package, $dist );
223
}
224
}
225
elsif ($body_text =~ /^--/ && $header{'content-type'} =~ m,multipart/signed,) {
226
my ($prot) = ($header{'content-type'} =~ m,protocol="([^"]*)",);
227
my ($bound) = ($header{'content-type'} =~ m,boundary="([^"]*)",);
228
$body_text =~ s,^--\Q$bound\E\nContent-Type: text/plain; charset=us-ascii\n\n,-----BEGIN PGP SIGNED MESSAGE-----\n\n,;
229
$body_text =~ s,--\Q$bound\E\nContent-Type: application/pgp-signature\n\n,,;
230
$body_text =~ s,\n\n--\Q$bound\E--\n,,;
231
if (prepare_for_upload( $package, $body_text )) {
232
purge_pkg( $package, $dist );
233
}
234
}
235
else {
236
$short_error .= "Bad keyword in answer $keyword\n";
237
$error .= "Answer not understood (expected retry, failed, manual,\n".
238
"dep-wait, giveback, not-for-us, purge, upload-rem,\n".
239
"newvers, or a signed changes file)\n";
240
}
241
}
242
elsif ($subject =~ /^Re: Should I build (\S+) \(dist=(\S+)\)/i) {
243
# reply whether a prev-failed package should be built
244
my( $package, $dist ) = ( $1, $2 );
245
$body_text =~ /^(\S+)/;
246
my $keyword = $1;
247
logger( "Should-build reply for $package($dist)\n" );
248
if (check_is_outdated( $dist, $package )) {
249
# $error has been set already -> no action here
250
}
251
elsif (!check_state( $package, $dist, "Building" )) {
252
# $error already set
253
}
254
elsif ($keyword =~ /^(build|ok)/) {
255
append_to_REDO( $package, $dist );
256
}
257
elsif ($keyword =~ /^fail/) {
258
my $text = get_fail_msg( $package, $dist );
259
set_to_failed( $package, $dist, $text );
260
}
261
elsif ($keyword =~ /^(not|no-b)/) {
262
no_build( $package, $dist );
263
}
264
elsif ($keyword =~ /^(give|back)/) {
265
give_back( $package, $dist );
266
}
267
else {
268
$short_error .= "Bad keyword in answer $keyword\n";
269
$error .= "Answer not understood (expected build, ok, fail, ".
270
"give-back, or no-build)\n";
271
}
272
}
273
elsif ($subject =~ /^Processing of (\S+)/) {
274
my $job = $1;
275
# mail from Erlangen queue daemon: forward all non-success messages
276
goto forward_mail if $body_text !~ /uploaded successfully/mi;
277
logger( "$job processed by upload queue\n" )
278
if $Buildd::Conf::log_queued_messages;
279
}
280
elsif ($subject =~ /^([-+~\.\w]+\.changes) (INSTALL|ACCEPT)ED/) {
281
# success mail from dinstall
282
my $changes_f = $1;
283
my( @to_remove, $upload_f, $pkgv );
284
my $upload_dir = "$Buildd::Conf::HOME/upload";
285
$upload_dir .= "-security" if -f "$upload_dir-security/$changes_f";
286
287
if (-f "$upload_dir/$changes_f" && open( F, "<$upload_dir/$changes_f" )) {
288
local($/); undef $/;
289
my $changetext = <F>;
290
close( F );
291
push( @to_remove, get_files_from_changes( $changetext ) );
292
} else {
293
foreach (split( "\n", $body_text )) {
294
if (/^(\[-+~\.\w]+\.(u?deb))$/) {
295
my $f = $1;
296
push( @to_remove, $f ) if !grep { $_ eq $f } @to_remove;
297
}
298
}
299
}
300
($upload_f = $changes_f) =~ s/\.changes$/\.upload/;
301
push( @to_remove, $changes_f, $upload_f );
302
($pkgv = $changes_f) =~ s/_(\S+)\.changes//;
303
logger( "$pkgv has been installed; removing from upload dir:\n",
304
"@to_remove\n" );
305
306
my @dists;
307
if (open( F, "<$upload_dir/$changes_f" )) {
308
my $changes_text;
309
{ local($/); undef $/; $changes_text = <F>; }
310
close( F );
311
@dists = get_dists_from_changes( $changes_text );
312
} else {
313
logger( "Cannot get dists from $upload_dir/$changes_f: $! (assuming unstable)\n" );
314
@dists = ( "unstable" );
315
}
316
317
FILE: foreach (@to_remove) {
318
if (/\.deb$/) {
319
# first listed wins
320
foreach my $dist (@dists) {
321
if ( -d "$Buildd::Conf::HOME/build/chroot-$dist" && -w "$Buildd::Conf::HOME/build/chroot-$dist/var/cache/apt/archives/") {
322
# TODO: send all of to_remove to perl-apt if it's available, setting a try_mv list
323
# that only has build-depends in it.
324
# if that's too much cpu, have buildd use perl-apt if avail to export the
325
# build-depends list, which could then be read in at this point
326
if (system "mv $upload_dir/$_ $Buildd::Conf::HOME/build/chroot-$dist/var/cache/apt/archives/") {
327
logger( "Cannot move $upload_dir/$_ to cache dir\n" );
328
} else {
329
next FILE;
330
}
331
}
332
}
333
}
334
unlink "$upload_dir/$_"
335
or logger( "Can't remove $upload_dir/$_: $!\n" );
336
}
337
}
338
elsif ($subject =~ /^(\S+\.changes) is NEW$/) {
339
# "is new" mail from dinstall
340
my $changes_f = $1;
341
my $pkgv;
342
($pkgv = $changes_f) =~ s/_(\S+)\.changes//;
343
logger( "$pkgv must be manually dinstall-ed -- delayed\n" );
344
}
345
elsif ($subject =~ /^new version of (\S+) \(dist=(\S+)\)$/) {
346
# notice from wanna-build
347
my ($pkg, $dist) = ($1, $2);
348
goto forward if $body_text !~ /^in version (\S+)\.$/m;
349
my $pkgv = $pkg."_".$1;
350
$body_text =~ /new source version (\S+)\./m;
351
my $newv = $1;
352
logger( "Build of $pkgv ($dist) obsolete -- new version $newv\n" );
353
register_outdated( $dist, $pkgv, $pkg."_".$newv );
354
355
my @ds;
356
if (!(@ds = check_building_any_dist( $pkgv ))) {
357
if (!remove_from_REDO( $pkgv )) {
358
append_to_SKIP( $pkgv );
359
}
360
purge_pkg( $pkgv, $dist );
361
}
362
else {
363
logger( "Not deleting, still building for @ds\n" );
364
}
365
}
366
elsif ($body_text =~ /^blacklist (\S+)\n$/) {
367
my $pattern = "\Q$1\E";
368
if (open( F, ">>mail-blacklist" )) {
369
print F "$pattern\n";
370
close( F );
371
logger( "Added $pattern to blacklist.\n" );
372
}
373
else {
374
logger( "Can't open mail-blacklist for appending: $!\n" );
375
}
376
}
377
else {
378
goto forward_mail;
379
}
380
381
if ($error) {
382
logger( "Error: ", $short_error || $error );
383
reply( "Your mail could not be processed:\n$error" );
384
}
385
return;
386
387
forward_mail:
388
logger( "Mail from $header{'from'}\nSubject: $subject\n" );
389
if (is_blacklisted( $header{'from'} )) {
390
logger( "Address is blacklisted, deleting mail.\n" );
391
}
392
else {
393
logger( "Not for me, forwarding to admin\n" );
394
ll_send_mail( $Buildd::Conf::admin_mail,
395
"To: $header{'to'}\n".
396
($header{'cc'} ? "Cc: $header{'cc'}\n" : "").
397
"From: $header{'from'}\n".
398
"Subject: $header{'subject'}\n".
399
"Date: $header{'date'}\n".
400
"Message-Id: $header{'message-id'}\n".
401
($header{'reply-to'} ? "Reply-To: $header{'reply-to'}\n" : "").
402
($header{'in-reply-to'} ? "In-Reply-To: $header{'in-reply-to'}\n" : "").
403
($header{'references'} ? "References: $header{'references'}\n" : "").
404
"Resent-From: $Buildd::gecos <$Buildd::username\@$Buildd::hostname>\n".
405
"Resent-To: $Buildd::Conf::admin_mail\n\n".
406
$body_text );
407
}
408
}
409
410
411
sub prepare_for_upload ($$) {
412
my $pkg = shift;
413
my $changes = shift;
414
my( @files, @md5, @missing, @md5fail, $i );
415
416
my @to_dists = get_dists_from_changes( $changes );
417
if (!@to_dists) { # probably not a valid changes
418
$short_error = $error;
419
$error .= "Couldn't find a valid Distribution: line.\n";
420
return 0;
421
}
422
$changes =~ /^Files:\s*\n((^[ ]+.*\n)*)/m;
423
foreach (split( "\n", $1 )) {
424
push( @md5, (split( /\s+/, $_ ))[1] );
425
push( @files, (split( /\s+/, $_ ))[5] );
426
}
427
if (!@files) { # probably not a valid changes
428
$short_error = $error;
429
$error .= "No files listed in changes.\n";
430
return 0;
431
}
432
my @wrong_dists = ();
433
foreach my $d (@to_dists) {
434
push( @wrong_dists, $d )
435
if !check_state($pkg, $d, qw(Building Install-Wait Reupload-Wait));
436
}
437
if (@wrong_dists) {
438
$short_error = $error;
439
$error .= "Package $pkg has target distributions @wrong_dists\n".
440
"for which it isn't registered as Building.\n".
441
"Please fix this by either modifying the Distribution: ".
442
"header or\n".
443
"taking the package in those distributions, too.\n";
444
return 0;
445
}
446
447
for( $i = 0; $i < @files; ++$i ) {
448
if (! -f "$Buildd::Conf::HOME/build/$files[$i]") {
449
push( @missing, $files[$i] ) ;
450
}
451
else {
452
chomp( my $sum = `md5sum $Buildd::Conf::HOME/build/$files[$i]` );
453
push( @md5fail, $files[$i] ) if (split(/\s+/,$sum))[0] ne $md5[$i];
454
}
455
}
456
if (@missing) {
457
$short_error .= "Missing files for move: @missing\n";
458
$error .= "While trying to move the built package $pkg to upload,\n".
459
"the following files mentioned in the .changes were not found:\n".
460
"@missing\n";
461
return 0;
462
}
463
if (@md5fail) {
464
$short_error .= "md5 failure during move: @md5fail\n";
465
$error .= "While trying to move the built package $pkg to upload,\n".
466
"the following files had bad md5 checksums:\n".
467
"@md5fail\n";
468
return 0;
469
}
470
471
my $upload_dir = "$Buildd::Conf::HOME/upload" .
472
(is_for_security( $changes ) ? "-security" : "");
473
474
if (! -d $upload_dir &&!mkdir( $upload_dir, 0750 )) {
475
$error .= "Cannot create directory $upload_dir";
476
logger( "Cannot create dir $upload_dir\n" );
477
return 0;
478
}
479
480
lock_file( "$upload_dir" );
481
my $errs = 0;
482
foreach (@files) {
483
if (system "mv $Buildd::Conf::HOME/build/$_ $upload_dir/$_") {
484
logger( "Cannot move $_ to upload dir\n" );
485
++$errs;
486
}
487
}
488
if ($errs) {
489
$error .= "Could not move all files to upload dir.";
490
return 0;
491
}
492
493
my $pkg_noep = $pkg;
494
$pkg_noep =~ s/_\d*:/_/;
495
my $changes_name = "${pkg_noep}_$Buildd::Conf::arch.changes";
496
unlink( "$Buildd::Conf::HOME/build/$changes_name" )
497
or logger( "Cannot remove ~/build/$changes_name: $!\n" );
498
open( F, ">$upload_dir/$changes_name" );
499
print F $changes;
500
close( F );
501
unlock_file( "$upload_dir" );
502
logger( "Moved $pkg to ", basename($upload_dir), "\n" );
503
}
504
505
sub redo_new_version ($$$) {
506
my $dist = shift;
507
my $oldv = shift;
508
my $newv = shift;
509
my $err = 0;
510
511
if (open( PIPE,"$Buildd::Conf::sshcmd wanna-build -v ".
512
($Buildd::Conf::wanna_build_dbbase? "--database=$Buildd::Conf::wanna_build_dbbase ":"").
513
"--user=$Buildd::Conf::wanna_build_user --dist=$dist $newv 2>&1 |")) {
514
while( <PIPE> ) {
515
next if /^wanna-build Revision/ ||
516
/^\S+: Warning: Older version / ||
517
/^\S+: ok$/;
518
$error .= "$_";
519
$err = 1;
520
}
521
close( PIPE );
522
}
523
else {
524
logger( "Can't spawn wanna-build: $!\n" );
525
$error .= "Can't spawn wanna-build: $!\n";
526
return;
527
}
528
if ($err) {
529
logger( "Can't take newer version $newv due to wanna-build errors\n" );
530
return;
531
}
532
logger( "Going to build $newv instead of $oldv\n" );
533
534
append_to_REDO( $newv, $dist );
535
}
536
537
sub purge_pkg ($$) {
538
my $pkg = shift;
539
my $dist = shift;
540
my $dir;
541
local( *F );
542
543
remove_from_REDO( $pkg );
544
545
# remove .changes and .deb in build dir (if existing)
546
my $pkg_noep = $pkg;
547
$pkg_noep =~ s/_\d*:/_/;
548
my $changes = "${pkg_noep}_$Buildd::Conf::arch.changes";
549
if (-f "build/$changes" && open( F, "<build/$changes" )) {
550
local($/); undef $/;
551
my $changetext = <F>;
552
close( F );
553
my @files = get_files_from_changes( $changetext );
554
push( @files, $changes );
555
logger( "Purging files: $changes\n" );
556
unlink( map { "build/$_" } @files );
557
}
558
559
# schedule dir for purging
560
($dir = $pkg_noep) =~ s/-[^-]*$//; # remove Debian revision
561
$dir =~ s/_/-/; # change _ to -
562
if (-d "build/chroot-$dist/build/$Buildd::username/$dir") {
563
$dir = "build/chroot-$dist/build/$Buildd::username/$dir";
564
}
565
else {
566
$dir = "build/$dir";
567
}
568
return if ! -d $dir;
569
570
lock_file( "build/PURGE" );
571
if (open( F, ">>build/PURGE" )) {
572
print F "$dir\n";
573
close( F );
574
logger( "Scheduled $dir for purging\n" );
575
}
576
else {
577
$error .= "Can't open build/PURGE: $!\n";
578
logger( "Can't open build/PURGE: $!\n" );
579
}
580
unlock_file( "build/PURGE" );
581
}
582
583
sub remove_from_upload ($) {
584
my $pkg = shift;
585
my($changes_f, $upload_f, $changes_text, @to_remove);
586
local( *F );
587
588
logger( "Remove $pkg from upload dir\n" );
589
my $pkg_noep = $pkg;
590
$pkg_noep =~ s/_\d*:/_/;
591
$changes_f = "${pkg_noep}_$Buildd::Conf::arch.changes";
592
my $upload_dir = "$Buildd::Conf::HOME/upload";
593
$upload_dir .= "-security" if -f "$upload_dir-security/$changes_f";
594
595
if (!-f "$upload_dir/$changes_f") {
596
logger( "$changes_f does not exist\n" );
597
return;
598
}
599
if (!open( F, "<$upload_dir/$changes_f" )) {
600
logger( "Cannot open $upload_dir/$changes_f: $!\n" );
601
return;
602
}
603
{ local($/); undef $/; $changes_text = <F>; }
604
close( F );
605
@to_remove = get_files_from_changes( $changes_text );
606
607
($upload_f = $changes_f) =~ s/\.changes$/\.upload/;
608
push( @to_remove, $changes_f, $upload_f );
609
610
logger( "Removing files:\n", "@to_remove\n" );
611
foreach (@to_remove) {
612
unlink "$upload_dir/$_"
613
or logger( "Can't remove $upload_dir/$_: $!\n" );
614
}
615
}
616
617
sub append_to_REDO ($$) {
618
my $pkg = shift;
619
my $dist = shift;
620
local( *F );
621
622
lock_file( "build/REDO" );
623
624
if (open( F, "build/REDO" )) {
625
my @pkgs = <F>;
626
close( F );
627
if (grep( /^\Q$pkg\E\s/, @pkgs )) {
628
logger( "$pkg is already in REDO -- not rescheduled\n" );
629
goto unlock;
630
}
631
}
632
633
if (open( F, ">>build/REDO" )) {
634
print F "$pkg $dist\n";
635
close( F );
636
logger( "Scheduled $pkg for rebuild\n" );
637
}
638
else {
639
$error .= "Can't open build/REDO: $!\n";
640
logger( "Can't open build/REDO: $!\n" );
641
}
642
643
unlock:
644
unlock_file( "build/REDO" );
645
}
646
647
sub remove_from_REDO ($) {
648
my $pkg = shift;
649
local( *F );
650
651
lock_file( "build/REDO" );
652
goto unlock if !open( F, "<build/REDO" );
653
my @pkgs = <F>;
654
close( F );
655
if (!open( F, ">build/REDO" )) {
656
logger( "Can't open REDO for writing: $!\n",
657
"Would write: @pkgs\nminus $pkg\n" );
658
goto unlock;
659
}
660
my $done = 0;
661
foreach (@pkgs) {
662
if (/^\Q$pkg\E\s/) {
663
++$done;
664
}
665
else {
666
print F $_;
667
}
668
}
669
close( F );
670
logger( "Deleted $pkg from REDO list.\n" ) if $done;
671
unlock:
672
unlock_file( "build/REDO" );
673
return $done;
674
}
675
676
sub append_to_SKIP ($) {
677
my $pkg = shift;
678
local( *F );
679
680
return if !open( F, "<build/build-progress" );
681
my @lines = <F>;
682
close( F );
683
684
if (grep( /^\s*\Q$pkg\E$/, @lines )) {
685
# pkg is in build-progress, but without a suffix (failed,
686
# successful, currently building), so it can be skipped
687
lock_file( "build/SKIP" );
688
if (open( F, ">>build/SKIP" )) {
689
print F "$pkg\n";
690
close( F );
691
logger( "Told sbuild to skip $pkg\n" );
692
}
693
unlock_file( "build/SKIP" );
694
}
695
}
696
697
sub check_is_outdated ($$) {
698
my $dist = shift;
699
my $package = shift;
700
my %newv;
701
my $have_changes = 0;
702
703
return 0 if !(%newv = is_outdated( $dist, $package ));
704
705
$have_changes = 1 if $body_text =~ /^---+\s*BEGIN PGP SIGNED MESSAGE/;
706
707
# If we have a changes file, we can see which distributions that
708
# package is aimed to. Otherwise, we're out of luck because we can't see
709
# reliably anymore for which distribs the package was for. Let the user
710
# find out this...
711
#
712
# If the package is outdated in all dists we have to consider,
713
# send a plain error message. If only outdated in some of them, send a
714
# modified error that tells to send a restricted changes (with
715
# Distribution: only for those dists where it isn't outdated), or to do
716
# the action manually, because it would be (wrongly) propagated.
717
goto all_outdated if !$have_changes;
718
719
my @check_dists = ();
720
@check_dists = get_dists_from_changes( $body_text );
721
722
my @not_outdated = ();
723
my @outdated = ();
724
foreach (@check_dists) {
725
if (!exists $newv{$_}) {
726
push( @not_outdated, $_ );
727
}
728
else {
729
push( @outdated, $_ );
730
}
731
}
732
return 0 if !@outdated;
733
if (@not_outdated) {
734
$short_error .= "$package ($dist) partially outdated ".
735
"(ok for @not_outdated)\n";
736
$error .=
737
"Package $package ($dist) is partially outdated.\n".
738
"The following new versions have appeared in the meantime:\n ".
739
join( "\n ", map { "$_: $newv{$_}" } keys %newv )."\n\n".
740
"Please send a .changes for the following distributions only:\n".
741
" Distribution: ".join( " ", @not_outdated )."\n";
742
}
743
else {
744
all_outdated:
745
$short_error .= "$package ($dist) outdated; new versions ".
746
join( ", ", map { "$_:$newv{$_}" } keys %newv )."\n";
747
$error .=
748
"Package $package ($dist) is outdated.\n".
749
"The following new versions have appeared in the meantime:\n ".
750
join( "\n ", map { "$_: $newv{$_}" } keys %newv )."\n";
751
}
752
return 1;
753
}
754
755
sub is_outdated ($$) {
756
my $dist = shift;
757
my $pkg = shift;
758
my %result = ();
759
local( *F );
760
761
lock_file( "outdated-packages" );
762
goto unlock if !open( F, "<outdated-packages" );
763
while( <F> ) {
764
my($oldpkg, $newpkg, $t, $d) = split( /\s+/, $_ );
765
$d ||= "unstable";
766
if ($oldpkg eq $pkg && $d eq $dist) {
767
$result{$d} = $newpkg;
768
}
769
}
770
close( F );
771
unlock:
772
unlock_file( "outdated-packages" );
773
return %result;
774
}
775
776
sub register_outdated ($$$) {
777
my $dist = shift;
778
my $oldv = shift;
779
my $newv = shift;
780
my(@pkgs);
781
local( *F );
782
783
lock_file( "outdated-packages" );
784
785
if (open( F, "<outdated-packages" )) {
786
@pkgs = <F>;
787
close( F );
788
}
789
790
if (!open( F, ">outdated-packages" )) {
791
logger( "Cannot open outdated-packages for writing: $!\n" );
792
goto unlock;
793
}
794
my $now = time;
795
my @d = ();
796
foreach (@pkgs) {
797
my($oldpkg, $newpkg, $t, $d) = split( /\s+/, $_ );
798
$d ||= "unstable";
799
next if ($oldpkg eq $oldv && $d eq $dist) || ($now - $t) > 21*24*60*60;
800
print F $_;
801
}
802
print F "$oldv $newv $now $dist\n";
803
close( F );
804
unlock:
805
unlock_file( "outdated-packages" );
806
}
807
808
sub set_to_failed ($$$) {
809
my $pkg = shift;
810
my $dist = shift;
811
my $text = shift;
812
my $is_bugno = 0;
813
814
$text =~ s/^\.$/../mg;
815
$is_bugno = 1 if $text =~ /^\(see #\d+\)$/;
816
return if !check_state( $pkg, $dist, $is_bugno ? "Failed" : "Building" );
817
818
open( PIPE, "|-" )
819
or (open( STDOUT, ">/dev/null"),
820
exec "$Buildd::Conf::sshcmd wanna-build --failed --no-down-propagation ".
821
"--user=$Buildd::Conf::wanna_build_user ".($Buildd::Conf::wanna_build_dbbase?
822
"--database=$Buildd::Conf::wanna_build_dbbase ":""). "--dist=$dist $pkg");
823
print PIPE "${text}.\n";
824
close( PIPE );
825
if ($?) {
826
my $t = "wanna-build --failed failed with status ".exitstatus($?)."\n";
827
logger( $t );
828
$error .= $t;
829
}
830
elsif ($is_bugno) {
831
logger( "Bug# appended to fail message of $pkg ($dist)\n" );
832
}
833
else {
834
logger( "Set package $pkg ($dist) to Failed\n" );
835
write_stats( "failed", 1 );
836
}
837
}
838
839
sub set_to_depwait ($$$) {
840
my $pkg = shift;
841
my $dist = shift;
842
my $deps = shift;
843
844
open( PIPE, "|-" )
845
or (open( STDOUT, ">/dev/null"),
846
exec "$Buildd::Conf::sshcmd wanna-build --dep-wait --no-down-propagation ".
847
"--user=$Buildd::Conf::wanna_build_user ".($Buildd::Conf::wanna_build_dbbase?
848
"--database=$Buildd::Conf::wanna_build_dbbase ":""). "--dist=$dist $pkg");
849
print PIPE "$deps\n";
850
close( PIPE );
851
if ($?) {
852
my $t = "wanna-build --dep-wait failed with status ".exitstatus($?)."\n";
853
logger( $t );
854
$error .= $t;
855
}
856
else {
857
logger( "Set package $pkg ($dist) to Dep-Wait\nDependencies: $deps\n" );
858
}
859
write_stats( "dep-wait", 1 );
860
}
861
862
sub give_back ($$) {
863
my $pkg = shift;
864
my $dist = shift;
865
my $answer_cmd;
866
867
$answer_cmd = "$Buildd::Conf::sshcmd wanna-build --give-back --no-down-propagation --user=$Buildd::Conf::wanna_build_user ".
868
($Buildd::Conf::wanna_build_dbbase? "--database=$Buildd::Conf::wanna_build_dbbase ":""). "--dist=$dist $pkg";
869
my $answer = `$answer_cmd`;
870
if ($?) {
871
$error .= "wanna-build --give-back failed:\n$answer";
872
}
873
else {
874
logger( "Given back package $pkg ($dist)\n" );
875
}
876
}
877
878
sub no_build ($$) {
879
my $pkg = shift;
880
my $dist = shift;
881
my $answer_cmd;
882
883
$answer_cmd = "$Buildd::Conf::sshcmd wanna-build --no-build --no-down-propagation --user=$Buildd::Conf::wanna_build_user ".
884
($Buildd::Conf::wanna_build_dbbase? "--database=$Buildd::Conf::wanna_build_dbbase ":""). "--dist=$dist $pkg";
885
my $answer = `$answer_cmd`;
886
if ($?) {
887
$error .= "no-build failed:\n$answer";
888
}
889
else {
890
logger( "Package $pkg ($dist) to set Not-For-Us\n" );
891
}
892
write_stats( "no-build", 1 );
893
}
894
895
sub get_fail_msg ($$) {
896
my $pkg = shift;
897
my $dist = shift;
898
local( *PIPE );
899
900
$pkg =~ s/_.*//;
901
if (open( PIPE, "$Buildd::Conf::sshcmd wanna-build --info --dist=$dist ".
902
($Buildd::Conf::wanna_build_dbbase? "--database=$Buildd::Conf::wanna_build_dbbase ":""). "$pkg |" )) {
903
my $msg = "";
904
while( <PIPE> ) {
905
if (/^\s*Old-Failed\s*:/) {
906
while( <PIPE> ) {
907
last if /^ \S+\s*/;
908
$_ =~ s/^\s+//;
909
if (/^----+\s+\S+\s+----+$/) {
910
last if $msg;
911
}
912
else {
913
$msg .= $_;
914
}
915
}
916
last;
917
}
918
}
919
close( PIPE );
920
return $msg if $msg;
921
$error .= "Couldn't find Old-Failed in info for $pkg\n";
922
return "Same as previous version (couldn't extract the text)\n";
923
}
924
else {
925
$error .= "Couldn't start wanna-build --info: $!\n";
926
return "Same as previous version (couldn't extract the text)\n";
927
}
928
}
929
930
sub check_state ($$@) {
931
my $pkgv = shift;
932
my $dist = shift;
933
my @wanted_states = @_;
934
local( *PIPE );
935
936
$pkgv =~ /^([^_]+)_(.+)/;
937
my ($pkg, $vers) = ($1, $2);
938
if (!open( PIPE, "$Buildd::Conf::sshcmd wanna-build --info ".
939
($Buildd::Conf::wanna_build_dbbase? "--database=$Buildd::Conf::wanna_build_dbbase ":""). "--dist=$dist $pkg |" )){
940
$error .= "Couldn't start wanna-build --info: $!\n";
941
return 0;
942
}
943
944
my ($av, $as, $ab, $an);
945
while( <PIPE> ) {
946
$av = $1 if /^\s*Version\s*:\s*(\S+)/;
947
$as = $1 if /^\s*State\s*:\s*(\S+)/;
948
$ab = $1 if /^\s*Builder\s*:\s*(\S+)/;
949
$an = $1 if /^\s*Binary-NMU-Version\s*:\s*(\d+)/;
950
}
951
close( PIPE );
952
953
my $msg = "$pkgv($dist) check_state(@wanted_states): ";
954
$av = binNMU_version($av,$an) if (defined $an);
955
if ($av ne $vers) {
956
$error .= $msg."version $av registered as $as\n";
957
return 0;
958
}
959
if (!Buildd::isin( $as, @wanted_states)) {
960
$error .= $msg."state is $as\n";
961
return 0;
962
}
963
if ($as eq "Building" && $ab ne $Buildd::Conf::wanna_build_user) {
964
$error .= $msg."is building by $ab\n";
965
return 0;
966
}
967
return 1;
968
}
969
970
sub check_building_any_dist ($) {
971
my $pkgv = shift;
972
my @dists;
973
local( *PIPE );
974
975
$pkgv =~ /^([^_]+)_(.+)/;
976
my ($pkg, $vers) = ($1, $2);
977
if (!open( PIPE, "$Buildd::Conf::sshcmd wanna-build --info ".
978
($Buildd::Conf::wanna_build_dbbase? "--database=$Buildd::Conf::wanna_build_dbbase ":""). "--dist=all $pkg |" )){
979
$error .= "Couldn't start wanna-build --info: $!\n";
980
return 0;
981
}
982
983
my $text;
984
{ local ($/); $text = <PIPE>; }
985
close( PIPE );
986
987
while( $text =~ /^\Q$pkg\E\((\w+)\):(.*)\n((\s.*\n)*)/mg ) {
988
my ($dist, $rest, $info) = ($1, $2, $3);
989
next if $rest =~ /not registered/;
990
my ($av, $as, $ab);
991
$av = $1 if $info =~ /^\s*Version\s*:\s*(\S+)/mi;
992
$as = $1 if $info =~ /^\s*State\s*:\s*(\S+)/mi;
993
$ab = $1 if $info =~ /^\s*Builder\s*:\s*(\S+)/mi;
994
push( @dists, $dist )
995
if $av eq $vers && $as eq "Building" &&
996
$ab eq $Buildd::Conf::wanna_build_user;
997
}
998
return @dists;
999
}
1000
1001
sub get_files_from_changes ($) {
1002
my $changes_text = shift;
1003
my(@filelines, @files);
1004
1005
$changes_text =~ /^Files:\s*\n((^[ ]+.*\n)*)/m;
1006
@filelines = split( "\n", $1 );
1007
foreach (@filelines) {
1008
push( @files, (split( /\s+/, $_ ))[5] );
1009
}
1010
return @files;
1011
}
1012
1013
sub is_for_non_us ($$) {
1014
my $pkg = shift;
1015
my $changes_text = shift;
1016
1017
$pkg =~ s/_.*$//;
1018
1019
# check if there's a "non-US" in the sections
1020
$changes_text =~ /^Files:\s*\n((^[ ]+.*\n)*)/m;
1021
my @filelines = split( "\n", $1 );
1022
foreach (@filelines) {
1023
return 1 if (split( /\s+/, $_ ))[3] =~ /non-us/i;
1024
}
1025
return 0;
1026
}
1027
1028
sub is_for_security ($) {
1029
my $changes_text = shift;
1030
1031
# check if there's a "-security" in the distribution
1032
my @dists = get_dists_from_changes( $changes_text );
1033
foreach (@dists) {
1034
return 1 if /-security$/;
1035
}
1036
return 0;
1037
}
1038
1039
sub get_dists_from_changes ($) {
1040
my $changes_text = shift;
1041
1042
$changes_text =~ /^Distribution:\s*(.*)\s*$/mi;
1043
return split( /\s+/, $1 );
1044
}
1045
1046
sub reply ($) {
1047
my $text = shift;
1048
my( $to, $subj, $quoting );
1049
1050
$to = $header{'reply-to'} || $header{'from'};
1051
$subj = $header{'subject'};
1052
$subj = "Re: $subj" if $subj !~ /^Re\S{0,2}:/;
1053
($quoting = $body_text) =~ s/\n+$/\n/;
1054
$quoting =~ s/^/> /mg;
1055
1056
send_mail( $to, $subj, "$quoting\n$text",
1057
"In-Reply-To: $header{'message-id'}\n" );
1058
}
1059
1060
sub is_blacklisted ($) {
1061
my $addr = shift;
1062
local( *BL );
1063
1064
$addr = $1 if $addr =~ /<(.*)>/;
1065
return 0 if !open( BL, "<mail-blacklist" );
1066
while( <BL> ) {
1067
chomp;
1068
if ($addr =~ /$_$/) {
1069
close( BL );
1070
return 1;
1071
}
1072
}
1073
close( BL );
1074
return 0;
1075
}
1076
1077
sub add_error_mail () {
1078
local( *F );
1079
my $now = time;
1080
my @em = ();
1081
1082
if (open( F, "<mail-errormails" )) {
1083
chomp( @em = <F> );
1084
close( F );
1085
}
1086
push( @em, $now );
1087
shift @em while @em && ($now - $em[0]) > $Buildd::Conf::error_mail_window;
1088
1089
if (@em) {
1090
open( F, ">mail-errormails" );
1091
print F join( "\n", @em ), "\n";
1092
close( F );
1093
}
1094
else {
1095
unlink( "mail-errormails" );
1096
}
1097
1098
return scalar(@em);
1099
}
1100
Loggerhead is a web-based interface for Breezy
Version: 2.0.1