diff options
Diffstat (limited to '')
-rw-r--r-- | lib/Buildd.pm | 192 | ||||
-rw-r--r-- | lib/Buildd/Base.pm | 190 | ||||
-rw-r--r-- | lib/Buildd/Client.pm | 135 | ||||
-rw-r--r-- | lib/Buildd/ClientConf.pm | 177 | ||||
-rw-r--r-- | lib/Buildd/Conf.pm | 628 | ||||
-rw-r--r-- | lib/Buildd/Daemon.pm | 998 | ||||
-rw-r--r-- | lib/Buildd/DistConf.pm | 159 | ||||
-rw-r--r-- | lib/Buildd/Mail.pm | 1354 | ||||
-rw-r--r-- | lib/Buildd/Makefile.am | 42 | ||||
-rw-r--r-- | lib/Buildd/UploadQueueConf.pm | 96 | ||||
-rw-r--r-- | lib/Buildd/Uploader.pm | 274 | ||||
-rw-r--r-- | lib/Buildd/Watcher.pm | 528 |
12 files changed, 4773 insertions, 0 deletions
diff --git a/lib/Buildd.pm b/lib/Buildd.pm new file mode 100644 index 0000000..9b90e07 --- /dev/null +++ b/lib/Buildd.pm @@ -0,0 +1,192 @@ +#! /usr/bin/perl +# +# Buildd.pm: library for buildd and friends +# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de> +# Copyright © 2005 Ryan Murray <rmurray@debian.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +####################################################################### + +package Buildd; + +use strict; +use warnings; +use POSIX; +use FileHandle; +use Sbuild::LogBase; + +require Exporter; +@Buildd::ISA = qw(Exporter); + +@Buildd::EXPORT = qw(unset_env lock_file unlock_file send_mail + ll_send_mail exitstatus isin); + +$Buildd::lock_interval = 15; +$Buildd::max_lock_trys = 120; +($Buildd::progname = $0) =~ s,.*/,,; +my @pwinfo = getpwuid($>); +$Buildd::username = $pwinfo[0]; +$Buildd::gecos = $pwinfo[6]; +$Buildd::gecos =~ s/,.*$//; +$Buildd::hostname = `/bin/hostname -f`; +$Buildd::hostname =~ /^(\S+)$/; $Buildd::hostname = $1; # untaint + +sub isin ($@); +sub unset_env (); +sub lock_file ($;$); +sub unlock_file ($); +sub send_mail ($$$;$); +sub ll_send_mail ($$); +sub exitstatus ($); + +sub isin ($@) { + my $val = shift; + return grep( $_ eq $val, @_ ); +} + +sub unset_env () { + # unset any locale variables (sorted to match output from locale(1)) + delete $ENV{'LANG'}; + delete $ENV{'LANGUAGE'}; + delete $ENV{'LC_CTYPE'}; + delete $ENV{'LC_NUMERIC'}; + delete $ENV{'LC_TIME'}; + delete $ENV{'LC_COLLATE'}; + delete $ENV{'LC_MONETARY'}; + delete $ENV{'LC_MESSAGES'}; + delete $ENV{'LC_PAPER'}; + delete $ENV{'LC_NAME'}; + delete $ENV{'LC_ADDRESS'}; + delete $ENV{'LC_TELEPHONE'}; + delete $ENV{'LC_MEASUREMENT'}; + delete $ENV{'LC_IDENTIFICATION'}; + delete $ENV{'LC_ALL'}; + # other unneeded variables that might be set + delete $ENV{'DISPLAY'}; + delete $ENV{'TERM'}; + delete $ENV{'XDG_RUNTIME_DIR'}; + delete $ENV{'XDG_SEAT'}; + delete $ENV{'XDG_SESSION_COOKIE'}; + delete $ENV{'XDG_SESSION_ID'}; + delete $ENV{'XDG_VTNR'}; +} + +sub lock_file ($;$) { + my $file = shift; + my $nowait = shift; + my $lockfile = "$file.lock"; + my $try = 0; + my $username = (getpwuid($<))[0] || $ENV{'LOGNAME'} || $ENV{'USER'}; + + if (!defined($nowait)) { + $nowait = 0; + } + + repeat: + if (!sysopen( F, $lockfile, O_WRONLY|O_CREAT|O_TRUNC|O_EXCL, 0644 )){ + if ($! == EEXIST) { + # lock file exists, wait + goto repeat if !open( F, "<$lockfile" ); + my $line = <F>; + close( F ); + # If this goes wrong it would be a spinlock and the world will + # end. + goto repeat if !defined( $line ); + if ($line !~ /^(\d+)\s+([\w\d.-]+)$/) { + warn "Bad lock file contents ($lockfile) -- still trying\n"; + } + else { + my($pid, $user) = ($1, $2); + my $cnt = kill( 0, $pid ); + if ($cnt == 0 && $! == ESRCH) { + # process doesn't exist anymore, remove stale lock + warn "Removing stale lock file $lockfile ". + " (pid $pid, user $user)\n"; + unlink( $lockfile ); + goto repeat; + } elsif ($cnt >= 1 and $nowait == 1) { + # process exists. + return 0; + } + } + if (++$try > $Buildd::max_lock_trys) { + warn "Lockfile $lockfile still present after ". + "$Buildd::max_lock_trys * $Buildd::lock_interval ". + " seconds -- giving up\n"; + return 0; + } + sleep $Buildd::lock_interval; + goto repeat; + } + die "$Buildd::progname: Can't create lock file $lockfile: $!\n"; + } + F->print("$$ $username\n"); + F->close(); + return 1; +} + +sub unlock_file ($) { + my $file = shift; + my $lockfile = "$file.lock"; + + unlink( $lockfile ); +} + + +sub send_mail ($$$;$) { + my $addr = shift; + my $subject = shift; + my $text = shift; + my $add_headers = shift; + + return ll_send_mail( $addr, + "To: $addr\n". + "Subject: $subject\n". + "From: $Buildd::gecos ". + "<$Buildd::username\@$Buildd::hostname>\n". + ($add_headers ? $add_headers : ""). + "\n$text\n" ); +} + +sub ll_send_mail ($$) { + my $to = shift; + my $text = shift; + local( *MAIL ); + + # TODO: Don't log to STDERR: Implement as class method using + # standard pipe interface using normal log streams. + + $text =~ s/^\.$/../mg; + local $SIG{'PIPE'} = 'IGNORE'; + if (!open( MAIL, "|/usr/sbin/sendmail -oem '$to'" )) { + print STDERR "Could not open pipe to /usr/sbin/sendmail: $!\n"; + return 0; + } + print MAIL $text; + if (!close( MAIL )) { + print STDERR "sendmail failed (exit status ", exitstatus($?), ")\n"; + return 0; + } + return 1; +} + +sub exitstatus ($) { + my $stat = shift; + + return ($stat >> 8) . "/" . ($stat % 256); +} + +1; diff --git a/lib/Buildd/Base.pm b/lib/Buildd/Base.pm new file mode 100644 index 0000000..c7240c0 --- /dev/null +++ b/lib/Buildd/Base.pm @@ -0,0 +1,190 @@ +# Buildd common base functionality +# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de> +# Copyright © 2009 Roger Leigh <rleigh@debian.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +####################################################################### + +package Buildd::Base; + +use strict; +use warnings; + +use IO::File; +use Buildd qw(lock_file unlock_file); +use Buildd::Client qw(); + +use Sbuild::Base; +use Sbuild qw($devnull); + +BEGIN { + use Exporter (); + our (@ISA, @EXPORT); + + @ISA = qw(Exporter Sbuild::Base); + + @EXPORT = qw(); +} + +sub new { + my $class = shift; + my $conf = shift; + + my $self = $class->SUPER::new($conf); + bless($self, $class); + + $self->set('PID', $$); + + $self->open_log(); + + return $self; +} + +sub open_log ($) { + my $self = shift; + + my $logfile = $self->get_conf('DAEMON_LOG_FILE'); + + my $log = IO::File->new("$logfile", O_CREAT|O_WRONLY|O_APPEND, 0640) + or die "$0: Cannot open logfile $logfile: $!\n"; + $log->autoflush(1); + + # Since we are a daemon, fully detach from terminal by reopening + # stdout and stderr to redirect to the log file. Note messages + # should be printed using log(), not printing directly to the + # filehandle. This is a fallback only. + open(STDOUT, '>&', $log) or warn "Can't redirect stderr\n"; + open(STDERR, '>&', $log) or warn "Can't redirect stderr\n"; + + $self->set('Log Stream', $log); + + return $log; +} + +sub close_log ($) { + my $self = shift; + + # We can't close stdout and stderr, so redirect to /dev/null. + open(STDOUT, '>&', $devnull) or warn "Can't redirect stderr\n"; + open(STDERR, '>&', $devnull) or warn "Can't redirect stderr\n"; + + my $log = $self->get('Log Stream'); + $self->set('Log Stream', undef); + + return $log->close(); +} + +sub reopen_log ($) { + my $self = shift; + + my $log = $self->get('Log Stream'); + + if ($self->close_log()) { + $log = $self->open_log(); + } + + return $log; +} + +sub write_stats ($$$) { + my $self = shift; + my ($cat, $val) = @_; + + local( *F ); + + my $home = $self->get_conf('HOME'); + + lock_file( "$home/stats" ); + open( F, ">>$home/stats/$cat" ); + print F "$val\n"; + close( F ); + unlock_file( "$home/stats" ); +} + +sub get_db_handle ($$) { + my $self = shift; + my $dist_config = shift; + + my $db = Buildd::Client->new($dist_config); + $db->set('Log Stream', $self->get('Log Stream')); + return $db; +} + +sub get_dist_config_by_name ($$) { + my $self = shift; + my $dist_name = shift; + + my $dist_config; + for my $dist_config_entry (@{$self->get_conf('DISTRIBUTIONS')}) { + if ($dist_config_entry->get('DIST_NAME') eq $dist_name) { + $dist_config = $dist_config_entry; + } + } + + if (!$dist_config) { + $self->set('Mail Short Error', + $self->get('Mail Short Error') . + "No configuration found for dist $dist_name\n"); + $self->set('Mail Error', + $self->get('Mail Error') . + "Answer could not be processed, as dist=$dist_name does not match any of\n". + "the entries in the buildd configuration.\n"); + } + + return $dist_config; +} + +sub get_arch_dist_config_by_name ($$) { + my $self = shift; + my $arch_name = shift; + my $dist_name = shift; + + my $arch_config, my $dist_config; + for my $dist_config_entry (@{$self->get_conf('DISTRIBUTIONS')}) { + if ($dist_config_entry->get('BUILT_ARCHITECTURE') eq $arch_name && + $dist_config_entry->get('DIST_NAME') eq $dist_name) { + $dist_config = $dist_config_entry; + } + } + + if (!$dist_config) { + $self->set('Mail Short Error', + $self->get('Mail Short Error') . + "No configuration found for arch=$arch_name, dist=$dist_name\n"); + $self->set('Mail Error', + $self->get('Mail Error') . + "Answer could not be processed, as arch=$arch_name, dist=$dist_name". + "does not match any of the entries in the buildd configuration.\n"); + } + + return $dist_config; +} + +sub log { + my $self = shift; + + my $timestamp = localtime; + # omit weekday and year for brevity + $timestamp =~ s/^\w+\s(.*)\s\d+$/$1/; + my $prefix = "$timestamp $Buildd::progname\[" . + $self->get('PID') . "\]: "; + + for my $line (split(/\n/, join("", @_))) { + Sbuild::Base::log($self, $prefix, $line, "\n"); + } +} + +1; diff --git a/lib/Buildd/Client.pm b/lib/Buildd/Client.pm new file mode 100644 index 0000000..14a9104 --- /dev/null +++ b/lib/Buildd/Client.pm @@ -0,0 +1,135 @@ +# +# Client.pm: client library for wanna-build +# Copyright © 2005 Ryan Murray <rmurray@debian.org> +# Copyright © 2005-2009 Roger Leigh <rleigh@debian.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +####################################################################### + +package Buildd::Client; + +use strict; +use warnings; + +use Sbuild qw($devnull); +use Sbuild::ChrootRoot; +use Cwd; + +BEGIN { + use Exporter (); + our (@ISA, @EXPORT); + + @ISA = qw(Exporter Sbuild::Base); + + @EXPORT = qw(); +} + +sub new { + my $class = shift; + my $conf = shift; + + my $self = $class->SUPER::new($conf); + bless($self, $class); + + $self->set('SETUP', 0); + + return $self; +} + +sub setup { + my $self = shift; + + if (!$self->get('SETUP')) { + my $host = Sbuild::ChrootRoot->new($self->get('Config')); + $host->begin_session(); + $host->set('Log Stream', $self->get('Log Stream')); + $self->set('Host', $host); + $self->set('SETUP', 1); + } +} + +sub get_query { + my $self = shift; + + my @command = (@{$self->get_conf('WANNA_BUILD_SSH_CMD')}, 'wanna-build'); + if ($self->get_conf('WANNA_BUILD_DB_NAME')) { + push(@command, "--database=" . $self->get_conf('WANNA_BUILD_DB_NAME')); + } else { + if ($self->get_conf('BUILT_ARCHITECTURE')) { + push(@command, "--arch=" . $self->get_conf('BUILT_ARCHITECTURE')); + } + if ($self->get_conf('DIST_NAME')) { + push(@command, "--dist=" . $self->get_conf('DIST_NAME')); + } + } + push(@command, "--user=" . $self->get_conf('WANNA_BUILD_DB_USER')) + if $self->get_conf('WANNA_BUILD_DB_USER'); + push(@command, @_); + + return @command; +} + +sub run_query { + my $self = shift; + + my @command = $self->get_query(@_); + + $self->setup(); + + my $pipe = $self->get('Host')->run_command( + { COMMAND => [@command], + USER => $self->get_conf('USERNAME'), + PRIORITY => 0, + }); +} + +sub pipe_query { + my $self = shift; + + my @command = $self->get_query(@_); + + $self->setup(); + + my $pipe = $self->get('Host')->pipe_command( + { COMMAND => [@command], + USER => $self->get_conf('USERNAME'), + PRIORITY => 0, + DIR => getcwd(), + STREAMERR => \*STDOUT, + }); + + return $pipe; +} + +sub pipe_query_out { + my $self = shift; + + my @command = $self->get_query(@_); + + $self->setup(); + + my $pipe = $self->get('Host')->pipe_command( + { COMMAND => [@command], + USER => $self->get_conf('USERNAME'), + PIPE => 'out', + STREAMOUT => $devnull, + PRIORITY => 0, + }); + + return $pipe; +} + +1; diff --git a/lib/Buildd/ClientConf.pm b/lib/Buildd/ClientConf.pm new file mode 100644 index 0000000..e38eb7c --- /dev/null +++ b/lib/Buildd/ClientConf.pm @@ -0,0 +1,177 @@ +# +# ClientConf.pm: configuration library for wanna-build clients +# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de> +# Copyright © 2005 Ryan Murray <rmurray@debian.org> +# Copyright © 2006-2009 Roger Leigh <rleigh@debian.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +####################################################################### + +package Buildd::ClientConf; + +use strict; +use warnings; + +use Sbuild::Sysconfig; +use File::Spec; + +BEGIN { + use Exporter (); + our (@ISA, @EXPORT); + + @ISA = qw(Exporter); + + @EXPORT = qw(setup); +} + +sub setup ($) { + my $conf = shift; + + my $validate_program = sub { + my $conf = shift; + my $entry = shift; + my $key = $entry->{'NAME'}; + my $program = $conf->get($key); + + die "$key binary is not defined" + if !defined($program) || !$program; + + # Emulate execvp behaviour by searching the binary in the PATH. + my @paths = split(/:/, $ENV{'PATH'}); + # Also consider the empty path for absolute locations. + push (@paths, ''); + my $found = 0; + foreach my $path (@paths) { + $found = 1 if (-x File::Spec->catfile($path, $program)); + } + + die "$key binary '$program' does not exist or is not executable" + if !$found; + }; + + my $validate_ssh = sub { + my $conf = shift; + my $entry = shift; + +# TODO: Provide self, config and entry contexts, which functions to +# get at needed data. Provide generic configuration functions. +# + $validate_program->($conf, $conf->{'KEYS'}->{'SSH'}); + + my $ssh = $conf->get('SSH'); + my $sshuser = $conf->get('WANNA_BUILD_SSH_USER'); + my $sshhost = $conf->get('WANNA_BUILD_SSH_HOST'); + my @sshoptions = @{$conf->get('WANNA_BUILD_SSH_OPTIONS')}; + my $sshsocket = $conf->get('WANNA_BUILD_SSH_SOCKET'); + + my @command = (); + + if ($sshhost) { + push (@command, $ssh); + push (@command, '-l', $sshuser) if $sshuser; + push (@command, '-S', $sshsocket) if $sshsocket; + push (@command, @sshoptions) if @sshoptions; + push (@command, $sshhost); + } + + $conf->set('WANNA_BUILD_SSH_CMD', \@command); + }; + + our $HOME = $conf->get('HOME'); + my $arch = $conf->get('ARCH'); + + my %db_keys = ( + 'SSH' => { + TYPE => 'STRING', + VARNAME => 'ssh', + GROUP => 'Programs', + DEFAULT => 'ssh', + CHECK => $validate_ssh, + HELP => 'Path to ssh binary' + }, + 'WANNA_BUILD_SSH_CMD' => { + TYPE => 'STRING', + GROUP => '__INTERNAL', + DEFAULT => '', + HELP => 'Command to run wanna-build (set automatically from the other wanna-build options)' + }, + 'WANNA_BUILD_SSH_USER' => { + TYPE => 'STRING', + VARNAME => 'wanna_build_ssh_user', + GROUP => 'wanna-build client', + DEFAULT => '', + CHECK => $validate_ssh, + HELP => 'Username for SSH connection' + }, + 'WANNA_BUILD_SSH_HOST' => { + TYPE => 'STRING', + VARNAME => 'wanna_build_ssh_host', + GROUP => 'wanna-build client', + DEFAULT => '', + CHECK => $validate_ssh, + HELP => 'Host for SSH connection' + }, + 'WANNA_BUILD_SSH_SOCKET' => { + TYPE => 'STRING', + VARNAME => 'wanna_build_ssh_socket', + GROUP => 'wanna-build client', + DEFAULT => '', + CHECK => $validate_ssh, + HELP => 'Socket for SSH connection' + }, + 'WANNA_BUILD_SSH_OPTIONS' => { + TYPE => 'ARRAY:STRING', + VARNAME => 'wanna_build_ssh_options', + GROUP => 'wanna-build client', + DEFAULT => [], + CHECK => $validate_ssh, + HELP => 'SSH options. Note this is an array reference.' + }, + 'WANNA_BUILD_DB_NAME' => { + TYPE => 'STRING', + VARNAME => 'wanna_build_db_name', + GROUP => 'wanna-build client', + DEFAULT => undef, + HELP => 'Database name' + }, + 'WANNA_BUILD_DB_USER' => { + TYPE => 'STRING', + VARNAME => 'wanna_build_db_user', + GROUP => 'wanna-build client', + DEFAULT => $conf->get('USERNAME'), + # arch:all packages must not differ depending on which user is + # building the source package, so don't show the default for + # example config and man page generation + IGNORE_DEFAULT => 1, + HELP => 'Database user' + }, + 'BUILT_ARCHITECTURE' => { + TYPE => 'STRING', + VARNAME => 'wanna_build_built_architecture', + GROUP => 'wanna-build client', + DEFAULT => $arch, + # the $native_arch is different depending on the machine where + # sbuild is built but arch:all packages must not differ depending on + # the architecture they are built on, so don't show the default for + # example config and man page generation + IGNORE_DEFAULT => 1, + HELP => 'Architecture for database' + }); + + $conf->set_allowed_keys(\%db_keys); +} + +1; diff --git a/lib/Buildd/Conf.pm b/lib/Buildd/Conf.pm new file mode 100644 index 0000000..3dca902 --- /dev/null +++ b/lib/Buildd/Conf.pm @@ -0,0 +1,628 @@ +# +# Conf.pm: configuration library for buildd +# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de> +# Copyright © 2005 Ryan Murray <rmurray@debian.org> +# Copyright © 2006-2009 Roger Leigh <rleigh@debian.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +####################################################################### + +package Buildd::Conf; + +use strict; +use warnings; + +use Buildd::DistConf qw(); +use Buildd::UploadQueueConf qw(); +use Sbuild::ConfBase; +use Sbuild::Sysconfig; +use Buildd::ClientConf qw(); + +BEGIN { + use Exporter (); + our (@ISA, @EXPORT); + + @ISA = qw(Exporter); + + @EXPORT = qw($reread_config new setup read); +} + +our $reread_config = 0; + +sub setup ($); +sub read ($); + +sub new { + my $conf = Sbuild::ConfBase->new(@_); + Buildd::Conf::setup($conf); + Buildd::Conf::read($conf); + + return $conf; +} + +sub setup ($) { + my $conf = shift; + + my $validate_program = sub { + my $conf = shift; + my $entry = shift; + my $key = $entry->{'NAME'}; + my $program = $conf->get($key); + + die "$key binary is not defined" + if !defined($program) || !$program; + + # Emulate execvp behaviour by searching the binary in the PATH. + my @paths = split(/:/, $conf->get('PATH')); + # Also consider the empty path for absolute locations. + push (@paths, ''); + my $found = 0; + foreach my $path (@paths) { + $found = 1 if (-x File::Spec->catfile($path, $program)); + } + + die "$key binary '$program' does not exist or is not executable" + if !$found; + }; + + my $validate_directory = sub { + my $conf = shift; + my $entry = shift; + my $key = $entry->{'NAME'}; + my $directory = $conf->get($key); + + die "$key directory is not defined" + if !defined($directory) || !$directory; + + die "$key directory '$directory' does not exist" + if !-d $directory; + }; + + our $HOME = $conf->get('HOME'); + $main::HOME = $HOME; # TODO: Remove once Buildd.pm uses $conf + my $arch = $conf->get('ARCH'); + + my %buildd_keys = ( + 'ADMIN_MAIL' => { + TYPE => 'STRING', + VARNAME => 'admin_mail', + GROUP => 'Mail', + DEFAULT => 'root', + HELP => 'email address for admin' + }, + 'APT_GET' => { + TYPE => 'STRING', + VARNAME => 'apt_get', + GROUP => 'Programs', + CHECK => $validate_program, + DEFAULT => 'apt-get', + HELP => 'Path to apt-get binary' + }, + 'DPKG_FILE_SUFFIX' => { + TYPE => 'STRING', + VARNAME => 'dpkg_file_suffix', + GROUP => 'Programs', + DEFAULT => '', + HELP => 'Value for the sbuild dpkg-file-suffix option, to be passed on to sbuild', + }, + 'BUILD_LOG_KEEP' => { + TYPE => 'NUMERIC', + VARNAME => 'build_log_keep', + GROUP => 'Watcher', + DEFAULT => 2, + HELP => 'Number of days until build logs are archived' + }, + 'DAEMON_LOG_FILE' => { + TYPE => 'STRING', + VARNAME => 'daemon_log_file', + GROUP => 'Daemon', + IGNORE_DEFAULT => 1, # Don't dump the current home + DEFAULT => "$HOME/daemon.log", + HELP => 'Main buildd daemon log file' + }, + 'DAEMON_LOG_KEEP' => { + TYPE => 'NUMERIC', + VARNAME => 'daemon_log_keep', + GROUP => 'Watcher', + DEFAULT => 7, + HELP => 'Number of days until old daemon logs are archived in a .tar.gz file' + }, + 'DAEMON_LOG_ROTATE' => { + TYPE => 'NUMERIC', + VARNAME => 'daemon_log_rotate', + GROUP => 'Watcher', + DEFAULT => 1, + HELP => 'Number how many days until daemon logs are rotated (one is kept as daemon.log.old, others are moved to old-logs and gzipped)' + }, + 'DAEMON_LOG_SEND' => { + TYPE => 'BOOL', + VARNAME => 'daemon_log_send', + GROUP => 'Watcher', + DEFAULT => 1, + HELP => 'email rotated daemon logs to the admin?' + }, + 'DELAY_AFTER_GIVE_BACK' => { + TYPE => 'NUMERIC', + VARNAME => 'delay_after_give_back', + GROUP => 'Daemon', + DEFAULT => 8 * 60, # 8 hours + HELP => 'Time to avoid packages that have automatically been given back by sbuild (in minutes)' + }, + 'ERROR_MAIL_WINDOW' => { + TYPE => 'NUMERIC', + VARNAME => 'error_mail_window', + GROUP => 'Mail', + DEFAULT => 8*60*60, + HELP => 'If more than five error mails are received within the specified time (in seconds), do not forward (to avoid possible mail loops)' + }, + 'IDLE_SLEEP_TIME' => { + TYPE => 'NUMERIC', + VARNAME => 'idle_sleep_time', + GROUP => 'Daemon', + DEFAULT => 5*60, + HELP => 'Time to sleep when idle (in seconds) between wanna-build --list=needs-build calls)' + }, + 'LOG_QUEUED_MESSAGES' => { + TYPE => 'BOOL', + VARNAME => 'log_queued_messages', + GROUP => 'Mail', + DEFAULT => 0, + HELP => 'Log success messages from upload queue daemon?' + }, + 'MAX_SBUILD_FAILS' => { + TYPE => 'NUMERIC', + VARNAME => 'max_sbuild_fails', + GROUP => 'Daemon', + DEFAULT => 2, + HELP => 'Maximum number of times sbuild can fail before sleeping' + }, + 'MIN_FREE_SPACE' => { + TYPE => 'NUMERIC', + VARNAME => 'min_free_space', + GROUP => 'Daemon', + DEFAULT => 50*1024, + HELP => 'Minimum free space (in KiB) on build filesystem' + }, + 'NICE_LEVEL' => { + TYPE => 'NUMERIC', + VARNAME => 'nice_level', + GROUP => 'Build options', + DEFAULT => 10, + HELP => 'Nice level to run sbuild. Dedicated build daemons should not be niced.' + }, + 'NO_DETACH' => { + TYPE => 'BOOL', + VARNAME => 'no_detach', + GROUP => 'Daemon', + DEFAULT => 0, + HELP => 'Disable becoming a daemon, for debugging purposes. Set to 1 to stop daemonising, otherwise set to 0 to become a daemon.' + }, + 'NO_WARN_PATTERN' => { + TYPE => 'STRING', + VARNAME => 'no_warn_pattern', + GROUP => 'Watcher', + DEFAULT => '^build/(SKIP|REDO|SBUILD-GIVEN-BACK|buildd\.pid|[^/]*.ssh|chroot-[^/]*|current-[^/]*)$', + HELP => 'Don\'t complain about old files if they match the regexp.' + }, + 'PIDFILE' => { + TYPE => 'STRING', + VARNAME => 'pidfile', + GROUP => 'Daemon', +# Set once running as a system service. +# DEFAULT => "${Sbuild::Sysconfig::paths{'LOCALSTATEDIR'}/run/buildd.pid" + IGNORE_DEFAULT => 1, # Don't dump the current home + DEFAULT => "$HOME/build/buildd.pid", + HELP => 'PID file to identify running daemon.' + }, + 'PKG_LOG_KEEP' => { + TYPE => 'NUMERIC', + VARNAME => 'pkg_log_keep', + GROUP => 'Watcher', + DEFAULT => 7, + HELP => 'Number of days until to package logs are archived' + }, + 'SHOULD_BUILD_MSGS' => { + TYPE => 'BOOL', + VARNAME => 'should_build_msgs', + GROUP => 'Daemon', + DEFAULT => 1, + HELP => 'Should buildd send "Should I build" messages?' + }, + 'STATISTICS_MAIL' => { + TYPE => 'STRING', + VARNAME => 'statistics_mail', + GROUP => 'Watcher', + DEFAULT => 'root', + HELP => 'email address for statistics summaries' + }, + 'STATISTICS_PERIOD' => { + TYPE => 'NUMERIC', + VARNAME => 'statistics_period', + GROUP => 'Watcher', + DEFAULT => 7, + HELP => 'Period for statistic summaries (days)' + }, + 'SUDO' => { + TYPE => 'STRING', + VARNAME => 'sudo', + GROUP => 'Programs', + CHECK => $validate_program, + DEFAULT => 'sudo', + HELP => 'Path to sudo binary' + }, + 'WARNING_AGE' => { + TYPE => 'NUMERIC', + VARNAME => 'warning_age', + GROUP => 'Watcher', + DEFAULT => 7, + HELP => 'Age (in days) after which a warning is issued for files in upload and dirs in build' + }, + 'CONFIG_TIME' => { + TYPE => 'NUMERIC', + VARNAME => 'config_time', + GROUP => '__INTERNAL', + DEFAULT => {}, + HELP => 'Time configuration was last read' + }, + 'DISTRIBUTIONS' => { + TYPE => 'ARRAY:HASH:SCALAR', + VARNAME => 'distributions', + GROUP => 'Build options', + DEFAULT => [], + IGNORE_DEFAULT => 1, # Don't dump class to config + HELP => 'List of distributions that buildd should take packages from', + EXAMPLE => +'$distributions = [ + { + # name of the suite to build (also used to query wanna-build) + dist_name => ["unstable", "testing"], + + # architecture to be built (will be passed to sbuild and can be + # used to compute wanna_build_db_name) + built_architecture => undef, + + # host on which wanna-build is run + wanna_build_ssh_host => "buildd.debian.org", + + # user as who we are going to connect to the host running wanna-build + wanna_build_ssh_user => "buildd_arch", + + # SSH control socket path for ssh -S option + wanna_build_ssh_socket => "", + + # Additional SSH options used when connecting + wanna_build_ssh_options => [], + + # database used for wanna-build + wanna_build_db_name => "arch/build-db", + + # Username to use for wanna-build. + wanna_build_db_user => $Buildd::username, + + # Local queue directory where binaries are stored before uploaded + # by dupload. You need to configure this directory in + # @upload_queues to get packages uploaded from there. + dupload_local_queue_dir => "upload", + + # list of packages which shouldn\'t be picked up by buildd + no_auto_build => [], + + # list of packages which should only be taken if there absolutely + # nothing else to do (probably packages included in no_auto_build + # because they take too long) + weak_no_auto_build => [], + + # regex used to filter out unwanted packages: + #no_build_regex => "^(contrib/|non-free/)?non-US/", + + # regex used to filter packages to build: + #build_regex => "", + + # mail addr of buildd admin handling packages from this distribution + logs_mailed_to => $admin_mail, + + # schroot name (or alias) of the chrooted environment to use for + # building (will be passed to sbuild). sbuild\'s default is + # the first of $distribution-$arch-sbuild, $distribution-sbuild, + # $distribution-$arch and $distribution. + sbuild_chroot => undef, + + } +];' + }, + 'UPLOAD_QUEUES' => { + TYPE => 'ARRAY:HASH:SCALAR', + VARNAME => 'upload_queues', + GROUP => 'Uploader', + DEFAULT => [], + IGNORE_DEFAULT => 1, # Don't dump class to config + HELP => 'Package upload queues', + EXAMPLE => +'$upload_queues = [ + { + # Local queue directory where binaries are stored before uploaded + # by dupload. + dupload_local_queue_dir => "upload", + + # Upload site for buildd-upload to pass to dupload(1); see + # /etc/dupload.conf for possible values. + dupload_archive_name => "anonymous-ftp-master", + }, + + { + # Local queue directory where binaries are stored before uploaded + # by dupload. + dupload_local_queue_dir => "upload-security", + + # Upload site for buildd-upload to pass to dupload(1); see + # /etc/dupload.conf for possible values. + dupload_archive_name => "security", + } +];' + }); + + $conf->set_allowed_keys(\%buildd_keys); + Buildd::ClientConf::setup($conf); +} + +sub read ($) { + my $conf = shift; + + my $HOME = $conf->get('HOME'); + + my $global = $Sbuild::Sysconfig::paths{'BUILDD_CONF'}; + my $user = "$HOME/.builddrc"; + my %config_time = (); + my $user_time = 0; + + my $reread = 0; + + sub ST_MTIME () { 9 } + + my @config_files = ($global, $user); + + $reread = 1 if $reread_config; + + foreach (@config_files) { + if (-r $_) { + $config_time{$_} = 0; + my @stat = stat($_); + if (!defined($conf->get('CONFIG_TIME')->{$_}) || + $conf->get('CONFIG_TIME')->{$_} < $stat[ST_MTIME]) { + $config_time{$_} = $stat[ST_MTIME]; + $reread = 1; + } + } + } + + # For compatibility only. Non-scalars are deprecated. + my $deprecated_init = <<END; +# Variables are undefined, so config will default to DEFAULT if unset. +my \$defaults; +my \@distributions; +undef \@distributions; +my \@upload_queues; +undef \@upload_queues; + +#legacy fields: +my \@weak_no_auto_build; +undef \@weak_no_auto_build; +my \$build_regex = undef; # Should this be user settable? +my \@no_auto_build; +undef \@no_auto_build; +my \$no_build_regex = undef; +my \@take_from_dists; +undef \@take_from_dists; +my \$sshcmd = undef; +my \$sshsocket = undef; +my \$wanna_build_user = undef; +my \$wanna_build_dbbase = undef; +END + + my $deprecated_setup = ''; + + my $custom_setup = <<END; +if (\$sshcmd && \$sshcmd =~ /^\\s*(\\S+)\\s+(.+)/) { + my \$rest = \$2; + \$conf->set('SSH', \$1); + + #Try to pry the user out: + if (\$rest =~ /(-l\\s*(\\S+))\\s+/) { + \$wanna_build_ssh_user = \$2; + #purge this from the rest: + \$rest =~ s/\\Q\$1//; + } elsif (\$rest =~ /\\s+(\\S+)\@/) { + \$wanna_build_ssh_user = \$1; + \$rest =~ s/\\Q\$1\\E\@//; + } + + #Hope that the last argument is the host: + if (\$rest =~ /\\s+(\\S+)\\s*\$/) { + \$wanna_build_ssh_host = \$1; + \$rest =~ s/\\Q\$1//; + } + + #rest should be options: + if (\$rest !~ /\\s*/) { + \$wanna_build_ssh_options = [split \$rest]; + } +} + +if (\$sshsocket) { + \$wanna_build_ssh_socket = \$sshsocket; +} + +if (\$wanna_build_user) { + \$wanna_build_db_user = \$wanna_build_user; +} + +if (\$wanna_build_dbbase) { + \$wanna_build_db_name = \$wanna_build_dbbase; +} + +#Convert old config, if needed: +my \@distributions_info; +if (\@take_from_dists) { + for my \$dist (\@take_from_dists) { + my \%entry; + + \$entry{DIST_NAME} = \$dist; + \$entry{SSH} = \$ssh; + + if (\$dist =~ /security/) { + \$entry{DUPLOAD_LOCAL_QUEUE_DIR} = 'upload-security'; + } + if (\$build_regex) { + \$entry{BUILD_REGEX} = \$build_regex; + } + if (\$no_build_regex) { + \$entry{NO_BUILD_REGEX} = \$build_regex; + } + if (\@no_auto_build) { + \$entry{NO_AUTO_BUILD} = \\\@no_auto_build; + } + if (\@weak_no_auto_build) { + \$entry{WEAK_NO_AUTO_BUILD} = \\\@weak_no_auto_build; + } + + \$entry{WANNA_BUILD_DB_NAME} = \$wanna_build_db_name; + \$entry{WANNA_BUILD_DB_USER} = \$wanna_build_db_user; + \$entry{WANNA_BUILD_SSH_HOST} = \$wanna_build_ssh_host; + \$entry{WANNA_BUILD_SSH_USER} = \$wanna_build_ssh_user; + \$entry{WANNA_BUILD_SSH_SOCKET} = \$wanna_build_ssh_socket; + \$entry{WANNA_BUILD_SSH_OPTIONS} = \$wanna_build_ssh_options; + \$entry{WANNA_BUILD_API} = 0; + + my \$dist_config = Buildd::DistConf::new_hash(CHECK=>$conf->{'CHECK'}, + HASH=>\\\%entry); + + push \@distributions_info, \$dist_config; + } +} else { + my \@dists = (); + push \@dists, \@{\$distributions} if defined \$distributions; + + if (\@distributions) { + warn 'W: \@distributions is deprecated; please use the array reference \$distributions[]\n'; + push \@dists, \@distributions; + } + + for my \$raw_entry (\@dists) { + my \%entry; + my \@dist_names; + + #Find out for which distributions this entry is intended: + for my \$key (keys \%\$raw_entry) { + if (uc(\$key) eq "DIST_NAME") { + if (ref(\$raw_entry->{\$key}) eq "ARRAY") { + push \@dist_names, \@{\$raw_entry->{\$key}}; + } else { + push \@dist_names, \$raw_entry->{\$key}; + } + } + } + + for my \$key (keys \%\$raw_entry) { + if (uc(\$key) ne "DIST_NAME") { + \$entry{uc(\$key)} = \$raw_entry->{\$key}; + } + } + + for my \$key (keys \%\$defaults) { + if (uc(\$key) ne "DIST_NAME" && not defined \$entry{uc(\$key)}) { + \$entry{uc(\$key)} = \$defaults->{\$key}; + } + } + + \$entry{WANNA_BUILD_API} //= 1; + + + #We need this to pass this to Buildd::Client: + \$entry{SSH} = \$ssh; + + #Make one entry per distribution, it's easier later on: + for my \$dist (\@dist_names) { + \$entry{'DIST_NAME'} = \$dist; + my \$dist_config = Buildd::DistConf::new_hash(HASH=>\\\%entry); + push \@distributions_info, \$dist_config; + } + } +} + +\$conf->set('DISTRIBUTIONS', \\\@distributions_info); + +my \@queues = (); +push \@queues, \@{\$upload_queues} if defined \$upload_queues; + +if (\@upload_queues) { + warn 'W: \@upload_queues is deprecated; please use the array reference \$upload_queues[]\n'; + push \@queues, \@upload_queues; +} + +if (\@queues) { + my \@upload_queue_configs; + for my \$raw_entry (\@queues) { + my \%entry; + for my \$key (keys \%\$raw_entry) { + \$entry{uc(\$key)} = \$raw_entry->{\$key}; + } + + my \$queue_config = Buildd::UploadQueueConf::new_hash(CHECK=>$conf->{'CHECK'}, + HASH=>\\\%entry); + + push \@upload_queue_configs, \$queue_config; + } + \$conf->set('UPLOAD_QUEUES', \\\@upload_queue_configs); +} else { + push \@{\$conf->get('UPLOAD_QUEUES')}, + Buildd::UploadQueueConf::new_hash(CHECK=>$conf->{'CHECK'}, + HASH=> + { + DUPLOAD_LOCAL_QUEUE_DIR => 'upload', + DUPLOAD_ARCHIVE_NAME => 'anonymous-ftp-master' + } + ), + Buildd::UploadQueueConf::new_hash(CHECK=>$conf->{'CHECK'}, + HASH=> + { + DUPLOAD_LOCAL_QUEUE_DIR => 'upload-security', + DUPLOAD_ARCHIVE_NAME => 'security' + } + ); +} + +# Set here to allow user to override. +if (-t STDIN && -t STDOUT && \$conf->get('NO_DETACH')) { + \$conf->_set_default('VERBOSE', 1); +} else { + \$conf->_set_default('VERBOSE', 0); +} +END + + $conf->read(\@config_files, $deprecated_init, $deprecated_setup, + $custom_setup); + + # Update times + if ($reread) { + foreach (@config_files) { + if (-r $_) { + $conf->get('CONFIG_TIME')->{$_} = $config_time{$_}; + } + } + } +} + +1; diff --git a/lib/Buildd/Daemon.pm b/lib/Buildd/Daemon.pm new file mode 100644 index 0000000..dc07254 --- /dev/null +++ b/lib/Buildd/Daemon.pm @@ -0,0 +1,998 @@ +# buildd: daemon to automatically build packages +# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de> +# Copyright © 2009 Roger Leigh <rleigh@debian.org> +# Copyright © 2005 Ryan Murray <rmurray@debian.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +####################################################################### + +package Buildd::Daemon; + +use strict; +use warnings; + +use POSIX; +use Buildd qw(isin lock_file unlock_file send_mail exitstatus); +use Buildd::Conf qw(); +use Buildd::Base; +use Sbuild qw($devnull df); +use Sbuild::Sysconfig; +use Sbuild::ChrootRoot; +use Buildd::Client; +use Cwd; + +BEGIN { + use Exporter (); + our (@ISA, @EXPORT); + + @ISA = qw(Exporter Buildd::Base); + + @EXPORT = qw(); +} + +sub new { + my $class = shift; + my $conf = shift; + + my $self = $class->SUPER::new($conf); + bless($self, $class); + + $self->set('Daemon', 0); + + return $self; +} + +sub ST_MTIME () { 9 } + +sub run { + my $self = shift; + + my $host = Sbuild::ChrootRoot->new($self->get('Config')); + $host->set('Log Stream', $self->get('Log Stream')); + $self->set('Host', $host); + $host->begin_session() or die "Can't begin session\n"; + + my $my_binary = $0; + $my_binary = cwd . "/" . $my_binary if $my_binary !~ m,^/,; + $self->set('MY_BINARY', $my_binary); + + my @bin_stats = stat( $my_binary ); + die "Cannot stat $my_binary: $!\n" if !@bin_stats; + $self->set('MY_BINARY_TIME', $bin_stats[ST_MTIME]); + + chdir( $self->get_conf('HOME') . "/build" ) + or die "Can't cd to " . $self->get_conf('HOME') . "/build: $!\n"; + + open( STDIN, "</dev/null" ) + or die "$0: can't redirect stdin to /dev/null: $!\n"; + + if (open( PID, "<" . $self->get_conf('PIDFILE') )) { + my $pid = <PID>; + close( PID ); + $pid =~ /^[[:space:]]*(\d+)/; $pid = $1; + if (!$pid || (kill( 0, $pid ) == 0 && $! == ESRCH)) { + warn "Removing stale pid file (process $pid dead)\n"; + } + else { + die "Another buildd (pid $pid) is already running.\n"; + } + } + + if (!@{$self->get_conf('DISTRIBUTIONS')}) { + die "distribution list is empty, aborting."; + } + + if (!$self->get_conf('NO_DETACH')) { + defined(my $pid = fork) or die "can't fork: $!\n"; + exit if $pid; # parent exits + setsid or die "can't start a new session: $!\n"; + } + + $self->set('PID', $$); # Needed for cleanup + $self->set('Daemon', 1); + + open( PID, ">" . $self->get_conf('PIDFILE') ) + or die "can't create " . $self->get_conf('PIDFILE') . ": $!\n"; + printf PID "%5d\n", $self->get('PID'); + close( PID ); + + $self->log("Daemon started. (pid=$$)\n"); + + undef $ENV{'DISPLAY'}; + +# the main loop + MAINLOOP: + while( 1 ) { + $self->check_restart(); + + my ( $dist_config, $pkg_ver) = get_next_REDO($self); + $self->do_build( $dist_config, $pkg_ver) if $pkg_ver; + next MAINLOOP if $pkg_ver; + + ( $dist_config, $pkg_ver) = get_next_WANNABUILD($self); + $self->do_build( $dist_config, $pkg_ver) if $pkg_ver; + next MAINLOOP if $pkg_ver; + + # sleep a little bit if there was nothing to do this time + $self->log("Nothing to do -- sleeping " . + $self->get_conf('IDLE_SLEEP_TIME') . " seconds\n"); + my $idle_start_time = time; + sleep( $self->get_conf('IDLE_SLEEP_TIME') ); + my $idle_end_time = time; + $self->write_stats("idle-time", $idle_end_time - $idle_start_time); + } + + return 0; +} + +sub get_next_WANNABUILD { + my $self = shift; + foreach my $dist_config (@{$self->get_conf('DISTRIBUTIONS')}) { + $self->check_ssh_master($dist_config); + my $dist_name = $dist_config->get('DIST_NAME'); + my %givenback = $self->read_givenback(); + my $db = $self->get_db_handle($dist_config); + my $pipe = $db->pipe_query( + ($dist_config->get('WANNA_BUILD_API') ? '--api '.$dist_config->get('WANNA_BUILD_API') : ''), + '--list=needs-build', + ($dist_config->get('WANNA_BUILD_MIN_AGE') ? '--min-age '.$dist_config->get('WANNA_BUILD_MIN_AGE') : ''), + ); + if (!$pipe) { + $self->log("Can't spawn wanna-build --list=needs-build: $!\n"); + next MAINLOOP; + } + + my($pkg_ver, $total, $nonex, $lowprio_pkg_ver); + while( <$pipe> ) { + my $socket = $dist_config->get('WANNA_BUILD_SSH_SOCKET'); + if ($socket && + (/^Couldn't connect to $socket: Connection refused[\r]?$/ || + /^Control socket connect\($socket\): Connection refused[\r]?$/)) { + unlink($socket); + $self->check_ssh_master($dist_config); + next; + } + elsif (/^Total (\d+) package/) { + $total = $1; + next; + } + elsif (/^Database for \S+ doesn.t exist/) { + $nonex = 1; + } + next if $nonex; + next if defined($pkg_ver); #we only want one! + my @line = (split( /\s+/, $_)); + my $pv = $line[0]; + my $no_build_regex = $dist_config->get('NO_BUILD_REGEX'); + my $build_regex = $dist_config->get('BUILD_REGEX'); + next if $no_build_regex && $pv =~ m,$no_build_regex,; + next if $build_regex && $pv !~ m,$build_regex,; + $pv =~ s,^.*/,,; + my $p; + ($p = $pv) =~ s/_.*$//; + next if isin( $p, @{$dist_config->get('NO_AUTO_BUILD')} ); + next if $givenback{$pv}; + if (isin( $p, @{$dist_config->get('WEAK_NO_AUTO_BUILD')} )) { + # only consider the first lowprio item if there are + # multiple ones + next if defined($lowprio_pkg_ver); + $lowprio_pkg_ver = $pv; + next; + } + $pkg_ver = $pv; + } + close( $pipe ); + next if $nonex; + if ($?) { + $self->log("wanna-build --list=needs-build --dist=${dist_name} failed; status ", + exitstatus($?), "\n"); + next; + } + $self->log("${dist_name}: total $total packages to build.\n") if defined($total); + + # Build weak_no_auto packages before the next dist + if (!defined($pkg_ver) && defined($lowprio_pkg_ver)) { + $pkg_ver = $lowprio_pkg_ver; + } + + next if !defined($pkg_ver); + my $todo = $self->do_wanna_build( $dist_config, $pkg_ver ); + last if !$todo; + return ( $dist_config, $todo ); + } +} + +sub get_next_REDO { + my $self = shift; + my ( $dist_config, $pkg_ver); + foreach my $current_dist_config (@{$self->get_conf('DISTRIBUTIONS')}) { + $pkg_ver = $self->get_from_REDO( $current_dist_config ); + $dist_config = $current_dist_config; + last if defined($pkg_ver); + } + return ( $dist_config, $pkg_ver); +} + + +sub get_from_REDO { + my $self = shift; + my $wanted_dist_config = shift; + my $ret = undef; + local( *F ); + + lock_file( "REDO" ); + goto end if ! -f "REDO"; + if (!open( F, "<REDO" )) { + $self->log("File REDO exists, but can't open it: $!\n"); + goto end; + } + my @lines = <F>; + close( F ); + + $self->block_signals(); + if (!open( F, ">REDO" )) { + $self->log("Can't open REDO for writing: $!\n", + "Raw contents:\n@lines\n"); + goto end; + } + foreach (@lines) { + if (!/^(\S+)\s+(\S+)(?:\s*|\s+(\d+)\s+(\S.*))?$/) { + $self->log("Ignoring/deleting bad line in REDO: $_"); + next; + } + my($pkg, $dist, $binNMUver, $changelog) = ($1, $2, $3, $4); + if ($dist eq $wanted_dist_config->get('DIST_NAME') && !defined($ret)) { + $ret = {'pv' => $pkg }; + if (defined $binNMUver) { + $ret->{'changelog'} = $changelog; + $ret->{'binNMU'} = $binNMUver; + } + } else { + print F $_; + } + } + close( F ); + + end: + unlock_file( "REDO" ); + $self->unblock_signals(); + return $ret; +} + +sub add_given_back ($$) { + my $self = shift; + my $pkg_ver = shift; + + local( *F ); + lock_file("SBUILD-GIVEN-BACK", 0); + + if (open( F, ">>SBUILD-GIVEN-BACK" )) { + print F $pkg_ver . " " . time() . "\n"; + close( F ); + } else { + $self->log("Can't open SBUILD-GIVEN-BACK: $!\n"); + } + + unlock_file("SBUILD-GIVEN-BACK"); +} + +sub read_givenback { + my $self = shift; + + my %gb; + my $now = time; + local( *F ); + + lock_file( "SBUILD-GIVEN-BACK" ); + + if (open( F, "<SBUILD-GIVEN-BACK" )) { + %gb = map { split } <F>; + close( F ); + } + + if (open( F, ">SBUILD-GIVEN-BACK" )) { + foreach (keys %gb) { + if ($now - $gb{$_} > $self->get_conf('DELAY_AFTER_GIVE_BACK') *60) { + delete $gb{$_}; + } + else { + print F "$_ $gb{$_}\n"; + } + } + close( F ); + } + else { + $self->log("Can't open SBUILD-GIVEN-BACK: $!\n"); + } + + unlock: + unlock_file( "SBUILD-GIVEN-BACK" ); + return %gb; +} + +sub do_wanna_build { + my $self = shift; + + my $dist_config = shift; + my $pkgver = shift; + my @output = (); + my $ret = undef; + my $n = 0; + + $self->block_signals(); + + my $db = $self->get_db_handle($dist_config); + if ($dist_config->get('WANNA_BUILD_API') >= 1) { + use YAML::Tiny; + my $pipe = $db->pipe_query( + '--api '.$dist_config->get('WANNA_BUILD_API'), + $pkgver); + unless ($pipe) { + $self->unblock_signals(); + $self->log("Can't spawn wanna-build: $!\n"); + return undef; + } + local $/ = undef; + my $yaml = <$pipe>; + $yaml =~ s,^update transactions:.*$,,m; # get rid of simulate output in case simulate is specified above + $self->log($yaml); + $yaml = YAML::Tiny->read_string($yaml); + $yaml = $yaml->[0]; + foreach my $pkgv (@$yaml) { + my $pkg = (keys %$pkgv)[0]; + my $pkgd; + foreach my $k (@{$pkgv->{$pkg}}) { + foreach my $l (keys %$k) { + $pkgd->{$l} = $k->{$l}; + } + }; + if ($pkgd->{'status'} ne 'ok') { + $self->log("Can't take $pkg: $pkgd->{'status'}\n"); + next; + } + $ret = { 'pv' => $pkgver }; + # fix SHOULD_BUILD_MSGS +# if ($self->get_conf('SHOULD_BUILD_MSGS')) { +# $self->handle_prevfailed( $dist_config, grep( /^\Q$pkg\E_/, @_ ) ); +# } else { +# push( @output, grep( /^\Q$pkg\E_/, @_ ) ); + my $fields = { 'changelog' => 'extra-changelog', + 'binNMU' => 'binNMU', + 'extra-depends' => 'extra-depends', + 'extra-conflicts' => 'extra-conflicts', + 'build_dep_resolver' => 'build_dep_resolver', + 'arch_all' => 'arch_all', + 'mail_logs' => 'mail_logs', + }; + for my $f (keys %$fields) { + $ret->{$f} = $pkgd->{$fields->{$f}} if $pkgd->{$fields->{$f}}; + } + last; + } + close( $pipe ); + $self->unblock_signals(); + $self->write_stats("taken", $n) if $n; + return $ret; + } + my $pipe = $db->pipe_query( + '-v', + $pkgver); + if ($pipe) { + while( <$pipe> ) { + next if /^wanna-build Revision/; + if (/^(\S+):\s*ok/) { + $ret = { 'pv' => $pkgver }; + ++$n; + } + elsif (/^(\S+):.*NOT OK/) { + my $pkg = $1; + my $nextline = <$pipe>; + chomp( $nextline ); + $nextline =~ s/^\s+//; + $self->log("Can't take $pkg: $nextline\n"); + } + elsif (/^(\S+):.*previous version failed/i) { + my $pkg = $1; + ++$n; + if ($self->get_conf('SHOULD_BUILD_MSGS')) { + $self->handle_prevfailed( $dist_config, $pkgver ); + } else { + $ret = { 'pv' => $pkgver }; + } + # skip until ok line + while( <$pipe> ) { + last if /^\Q$pkg\E:\s*ok/; + } + } + elsif (/^(\S+):.*needs binary NMU (\d+)/) { + my $pkg = $1; + my $binNMUver = $2; + chop (my $changelog = <$pipe>); + my $newpkg; + ++$n; + + push( @output, grep( /^\Q$pkg\E_/, @_ ) ); + $ret = { 'pv' => $pkgver }; + $ret->{'changelog'} = $changelog; + $ret->{'binNMU'} = $binNMUver; + # skip until ok line + while( <$pipe> ) { + last if /^\Q$pkg\E:\s*aok/; + } + } + } + close( $pipe ); + $self->unblock_signals(); + $self->write_stats("taken", $n) if $n; + return $ret; + } + else { + $self->unblock_signals(); + $self->log("Can't spawn wanna-build: $!\n"); + return undef; + } +} + +sub should_skip { + my $self = shift; + my $pkgv = shift; + + my $found = 0; + + $self->lock_file("SKIP", 0); + goto unlock if !open( F, "SKIP" ); + my @pkgs = <F>; + close(F); + + if (!open( F, ">SKIP" )) { + $self->log("Can't open SKIP for writing: $!\n", + "Would write: @pkgs\nminus $pkgv\n"); + goto unlock; + } + foreach (@pkgs) { + if (/^\Q$pkgv\E$/) { + ++$found; + $self->log("$pkgv found in SKIP file -- skipping building it\n"); + } + else { + print F $_; + } + } + close( F ); + unlock: + $self->unlock_file("SKIP"); + return $found; +} + +sub do_build { + my $self = shift; + my $dist_config = shift; + my $todo = shift; + # $todo = { 'pv' => $pkg_ver, 'changelog' => $binNMUlog->{$pkg_ver}, 'binNMU' => $binNMUver; }; + + # If the package to build is in SKIP, then skip. + if ($self->should_skip($todo->{'pv'})) { + return; + } + + my $free_space; + + while (($free_space = df(".")) < $self->get_conf('MIN_FREE_SPACE')) { + $self->log("Delaying build, because free space is low ($free_space KB)\n"); + my $idle_start_time = time; + sleep( 10*60 ); + my $idle_end_time = time; + $self->write_stats("idle-time", $idle_end_time - $idle_start_time); + } + + $self->log("Starting build (dist=" . $dist_config->get('DIST_NAME') . ") of " + .($todo->{'binNMU'} ? "!".$todo->{'binNMU'}."!" : "") + ."$todo->{'pv'}\n"); + $self->write_stats("builds", 1); + + my @sbuild_args = (); + if ($self->get_conf('NICE_LEVEL') != 0) { + @sbuild_args = ( 'nice', '-n', $self->get_conf('NICE_LEVEL') ); + } + + push @sbuild_args, 'sbuild', + '--apt-update', + '--no-apt-upgrade', + '--no-apt-distupgrade', + '--no-run-lintian', + '--batch', + "--stats-dir=" . $self->get_conf('HOME') . "/stats", + "--dist=" . $dist_config->get('DIST_NAME'); + + push @sbuild_args, "--sbuild-mode=buildd"; + push @sbuild_args, "--mailfrom=".$dist_config->get('MAILFROM') if $dist_config->get('MAILFROM'); + push @sbuild_args, "--maintainer=".$dist_config->get('MAINTAINER_NAME') if $dist_config->get('MAINTAINER_NAME'); + push @sbuild_args, "--dpkg-file-suffix=".$self->get_conf('DPKG_FILE_SUFFIX') if $self->get_conf('DPKG_FILE_SUFFIX'); + + if ($dist_config->get('SIGN_WITH')) { + push @sbuild_args, '--keyid=' . $dist_config->get('SIGN_WITH'); + } + + #multi-archive-buildd keeps the mailto configuration in the builddrc, so + #this needs to be passed over to sbuild. If the buildd config doesn't have + #it, we hope that the address is configured in .sbuildrc and the right one: + if ($dist_config->get('LOGS_MAILED_TO')) { + push @sbuild_args, '--mail-log-to=' . $dist_config->get('LOGS_MAILED_TO'); + } elsif ($dist_config->get('LOGS_MAIL_ALSO') || $todo->{'mail_logs'}) { + push @sbuild_args, '--mail-log-to=' . join (',', grep { $_ } ($dist_config->get('LOGS_MAIL_ALSO'), $todo->{'mail_logs'})); + } + #Some distributions (bpo, experimental) require a more complex dep resolver. + #Ask sbuild to use another build-dep resolver if the config says so: + if ($dist_config->get('BUILD_DEP_RESOLVER') || $todo->{'build_dep_resolver'}) { + push @sbuild_args, '--build-dep-resolver=' . ($dist_config->get('BUILD_DEP_RESOLVER') || $todo->{'build_dep_resolver'}); + } + if ($dist_config->get('BUILT_ARCHITECTURE')) { + if ($dist_config->get('BUILT_ARCHITECTURE') eq 'all') { + push ( @sbuild_args, "--arch-all", "--no-arch-any" ); + } else { + push ( @sbuild_args, "--no-arch-all", "--arch-any", "--arch=" . $dist_config->get('BUILT_ARCHITECTURE') ); + } + } + push ( @sbuild_args, "--chroot=" . $dist_config->get('SBUILD_CHROOT') ) + if $dist_config->get('SBUILD_CHROOT'); + + + push ( @sbuild_args, "--binNMU=$todo->{'binNMU'}") if $todo->{'binNMU'}; + push ( @sbuild_args, "--make-binNMU=$todo->{'changelog'}") if $todo->{'changelog'}; + push ( @sbuild_args, "--add-conflicts=$todo->{'extra-conflicts'}") if $todo->{'extra-conflicts'}; + push ( @sbuild_args, "--add-depends=$todo->{'extra-depends'}") if $todo->{'extra-depends'}; + push @sbuild_args, $todo->{'pv'}; + $self->log("command line: @sbuild_args\n"); + + $main::sbuild_pid = open(SBUILD_OUT, "-|"); + + #We're childish, so call sbuild: + if ($main::sbuild_pid == 0) { + { exec (@sbuild_args) }; + $self->log("Cannot execute sbuild: $!\n"); + exit(64); + } + + if (!defined $main::sbuild_pid) { + $self->log("Cannot fork for sbuild: $!\n"); + goto failed; + } + + #We want to collect the first few lines of sbuild output: + my ($sbuild_output_line_count, @sbuild_output_buffer) = (0, ()); + while (<SBUILD_OUT>) { + #5 lines are enough: + if (++$sbuild_output_line_count < 5) { + push @sbuild_output_buffer, $_; + } + } + + #We got enough output, now just wait for sbuild to die: + my $rc; + while (($rc = wait) != $main::sbuild_pid) { + if ($rc == -1) { + last if $! == ECHILD; + next if $! == EINTR; + $self->log("wait for sbuild: $!; continuing to wait\n"); + } elsif ($rc != $main::sbuild_pid) { + $self->log("wait for sbuild: returned unexpected pid $rc\n"); + } + } + my $sbuild_exit_code = $?; + undef $main::sbuild_pid; + close(SBUILD_OUT); + + #Process sbuild's results: + my $db = $self->get_db_handle($dist_config); + my $failed = 1; + my $giveback = 1; + + if (WIFEXITED($sbuild_exit_code)) { + my $status = WEXITSTATUS($sbuild_exit_code); + + if ($status == 0) { + $failed = 0; + $giveback = 0; + $self->log("sbuild of $todo->{'pv'} succeeded -- marking as built in wanna-build\n"); + $db->run_query('--built', '--dist=' . $dist_config->get('DIST_NAME'), $todo->{'pv'}); + + if ($dist_config->get('SIGN_WITH') && $dist_config->get('BUILT_ARCHITECTURE')) { + # XXX: Check if signature is present. + $self->move_to_upload($dist_config, $todo->{'pv'}, $todo->{'binNMU'}); + } + } elsif ($status == 2) { + $giveback = 0; + $self->log("sbuild of $todo->{'pv'} failed with status $status (build failed) -- marking as attempted in wanna-build\n"); + $db->run_query('--attempted', '--dist=' . $dist_config->get('DIST_NAME'), $todo->{'pv'}); + $self->write_stats("failed", 1); + } else { + $self->log("sbuild of $todo->{'pv'} failed with status $status (local problem) -- giving back\n"); + } + } elsif (WIFSIGNALED($sbuild_exit_code)) { + my $sig = WTERMSIG($sbuild_exit_code); + $self->log("sbuild of $todo->{'pv'} failed with signal $sig (local problem) -- giving back\n"); + } else { + $self->log("sbuild of $todo->{'pv'} failed with unknown reason (local problem) -- giving back\n"); + } + + if ($giveback) { + $db->run_query('--give-back', '--dist=' . $dist_config->get('DIST_NAME'), $todo->{'pv'}); + $self->add_given_back($todo->{'pv'}); + $self->write_stats("give-back", 1); + } + + # Check if we encountered some local error to stop further building + if ($giveback) { + if (!defined $main::sbuild_fails) { + $main::sbuild_fails = 0; + } + + $main::sbuild_fails++; + + if ($main::sbuild_fails > $self->get_conf('MAX_SBUILD_FAILS')) { + $self->log("sbuild now failed $main::sbuild_fails times in ". + "a row; going to sleep\n"); + send_mail( $self->get_conf('ADMIN_MAIL'), + "Repeated mess with sbuild", + <<EOF ); +The execution of sbuild now failed for $main::sbuild_fails times. +These are the first $sbuild_output_line_count lines of the last failed sbuild call: +@sbuild_output_buffer + +The daemon is going to sleep for 1 hour, or can be restarted with SIGUSR2. +EOF + my $oldsig; + eval <<'EOF'; +$oldsig = $SIG{'USR2'}; +$SIG{'USR2'} = sub ($) { die "signal\n" }; +my $idle_start_time = time; +sleep( 60*60 ); +my $idle_end_time = time; +$SIG{'USR2'} = $oldsig; +$self->write_stats("idle-time", $idle_end_time - $idle_start_time); +EOF + $main::sbuild_fails = 0; + } + } + else { + # Either a build success or an attempted build will cause the + # counter to reset. + $main::sbuild_fails = 0; + } + $self->log("Build finished.\n"); +} + +sub move_to_upload { + my $self = shift; + my $dist_config = shift; + my $pv = shift; + my $binNMUver = shift; + + my $arch = $dist_config->get('BUILT_ARCHITECTURE'); + my $upload_dir = $dist_config->get('DUPLOAD_LOCAL_QUEUE_DIR'); + my $file_suffix = $self->get_conf('DPKG_FILE_SUFFIX'); + + if ($binNMUver) { + $pv .= '+b' . $binNMUver; + } + + my $pkg_noepoch = $pv; + $pkg_noepoch =~ s/_\d*:/_/; + + my $changes_name = $pkg_noepoch . '_' . $arch . $file_suffix . '.changes'; + my $upload_path = $self->get_conf('HOME') . '/' . $dist_config->get('DUPLOAD_LOCAL_QUEUE_DIR') . '/' . $pkg_noepoch . '_' . $arch . '.upload'; + + $self->log("$pv is autosigned, moving to '$upload_dir'\n"); + if ( -f $upload_path ) { + unlink( $upload_path ); + $self->log("'$upload_path' removed.\n"); + } + system(qw(dcmd mv --), + sprintf('%s/build/%s', $self->get_conf('HOME'), $changes_name), + sprintf('%s/%s/', $self->get_conf('HOME'), $dist_config->get('DUPLOAD_LOCAL_QUEUE_DIR')) + ); + $self->log("$pv moved to '$upload_dir'\n"); +} + +sub handle_prevfailed { + my $self = shift; + my $dist_config = shift; + my $pkgv = shift; + + my $dist_name = $dist_config->get('DIST_NAME'); + my( $pkg, $fail_msg, $changelog); + + $self->log("$pkgv previously failed -- asking admin first\n"); + ($pkg = $pkgv) =~ s/_.*$//; + + my $db = $self->get_db_handle($dist_config); + my $pipe = $db->pipe_query( + '--info', + $pkg); + if (!$pipe) { + $self->log("Can't run wanna-build: $!\n"); + return; + } + + $fail_msg = ""; + while (<$pipe>) { + $fail_msg .= $_; + } + + close($pipe); + if ($?) { + $self->log("wanna-build exited with error $?\n"); + return; + } + + send_mail( $self->get_conf('ADMIN_MAIL'), + "Should I build $pkgv (dist=${dist_name})?", + "The package $pkg failed to build in a previous version. ". + "The fail\n". + "messages are:\n\n$fail_msg\n". + "Should buildd try to build the new version, or should it ". + "fail with the\n". + "same messages again.? Please answer with 'build' (or 'ok'), ". + "or 'fail'.\n" ); +} + +sub get_changelog { + # This method is currently broken. It makes some assumptions about source + # layout that are no longer true. Furthermore it tries fetching through + # the host instead of creating a session (which is necessary for snapshot- + # based chroots) and work in the chroot. + + my $self = shift; + my $dist_config = shift; + my $pkg = shift; + + my $dist_name = $dist_config->get('DIST_NAME'); + my $changelog = ""; + my $analyze = ""; + my $chroot_apt_options; + my $file; + my $retried = 0; + + $pkg =~ /^([\w\d.+-]+)_([\w\d:.~+-]+)/; + my ($n, $v) = ($1, $2); + (my $v_ne = $v) =~ s/^\d+://; + my $pkg_ne = "${n}_${v_ne}"; + +retry: + my @schroot = ($self->get_conf('SCHROOT'), '-c', + $dist_name . '-' . $self->get_conf('ARCH') . '-sbuild', '--'); + my @schroot_root = ($self->get_conf('SCHROOT'), '-c', + $dist_name . '-' . $self->get_conf('ARCH') . '-sbuild', + '-u', 'root', '--'); + my $apt_get = $self->get_conf('APT_GET'); + + my $pipe = $self->get('Host')->pipe_command( + { COMMAND => [@schroot, + "$apt_get", '-q', '-d', + '--diff-only', 'source', "$n=$v"], + USER => $self->get_conf('USERNAME'), + PRIORITY => 0, + }); + if (!$pipe) { + $self->log("Can't run schroot: $!\n"); + return; + } + + my $msg = ""; + while (<$pipe>) { + $msg .= $_; + } + + close($pipe); + + if ($? == 0 && $msg !~ /get 0B/) { + $analyze = "diff"; + $file = "${n}_${v_ne}.diff.gz"; + } + + if (!$analyze) { + my $pipe2 = $self->get('Host')->pipe_command( + { COMMAND => [@schroot, + "$apt_get", '-q', '-d', + '--tar-only', 'source', "$n=$v"], + USER => $self->get_conf('USERNAME'), + PRIORITY => 0, + }); + if (!$pipe2) { + $self->log("Can't run schroot: $!\n"); + return; + } + + my $msg = <$pipe2>; + + close($pipe2); + + if ($? == 0 && $msg !~ /get 0B/) { + $analyze = "tar"; + $file = "${n}_${v_ne}.tar.gz"; + } + } + + if (!$analyze && !$retried) { + $self->get('Host')->run_command( + { COMMAND => [@schroot_root, + $apt_get, '-qq', + 'update'], + USER => $self->get_conf('USERNAME'), + PRIORITY => 0, + STREAMOUT => $devnull + }); + + $retried = 1; + goto retry; + } + + return "ERROR: cannot find any source" if !$analyze; + + if ($analyze eq "diff") { + if (!open( F, "gzip -dc '$file' 2>/dev/null |" )) { + return "ERROR: Cannot spawn gzip to zcat $file: $!"; + } + while( <F> ) { + # look for header line of a file */debian/changelog + last if m,^\+\+\+\s+[^/]+/debian/changelog(\s+|$),; + } + while( <F> ) { + last if /^---/; # end of control changelog patch + next if /^\@\@/; + $changelog .= "$1\n" if /^\+(.*)$/; + last if /^\+\s+--\s+/; + } + while( <F> ) { } # read to end of file to avoid broken pipe + close( F ); + if ($?) { + return "ERROR: error status ".exitstatus($?)." from gzip on $file"; + } + unlink( $file ); + } + elsif ($analyze eq "tar") { + if (!open( F, "tar -xzOf '$file' '*/debian/changelog' ". + "2>/dev/null |" )) { + return "ERROR: Cannot spawn tar for $file: $!"; + } + while( <F> ) { + $changelog .= $_; + last if /^\s+--\s+/; + } + while( <F> ) { } # read to end of file to avoid broken pipe + close( F ); + if ($?) { + return "ERROR: error status ".exitstatus($?)." from tar on $file"; + } + unlink( $file ); + } + + return $changelog; +} + +sub check_restart { + my $self = shift; + my @stats = stat( $self->get('MY_BINARY') ); + + if (@stats && $self->get('MY_BINARY_TIME') != $stats[ST_MTIME]) { + $self->log("My binary has been updated -- restarting myself (pid=$$)\n"); + unlink( $self->get_conf('PIDFILE') ); + kill ( 15, $main::ssh_pid ) if $main::ssh_pid; + exec $self->get('MY_BINARY'); + } + + if ( -f $self->get_conf('HOME') . "/EXIT-DAEMON-PLEASE" ) { + unlink($self->get_conf('HOME') . "/EXIT-DAEMON-PLEASE"); + $self->shutdown("NONE (flag file exit)"); + } +} + +sub block_signals { + my $self = shift; + + POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset ); +} + +sub unblock_signals { + my $self = shift; + + POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset ); +} + +sub check_ssh_master { + my $self = shift; + my $dist_config = shift; + + my $ssh_socket = $dist_config->get('WANNA_BUILD_SSH_SOCKET'); + + return 1 if (!$ssh_socket); + return 1 if ( -S $ssh_socket ); + + my $ssh_master_pids = {}; + if ($self->get('SSH_MASTER_PIDS')) { + $ssh_master_pids = $self->get('SSH_MASTER_PIDS'); + } else { + $self->set('SSH_MASTER_PIDS', $ssh_master_pids); + } + + if ($ssh_master_pids->{$ssh_socket}) + { + my $wpid = waitpid ( $ssh_master_pids->{$ssh_socket}, WNOHANG ); + return 1 if ($wpid != -1 and $wpid != $ssh_master_pids->{$ssh_socket}); + } + + my $new_master_pid = fork; + + #We are in the newly forked child: + if (defined($new_master_pid) && $new_master_pid == 0) { + exec (@{$dist_config->get('WANNA_BUILD_SSH_CMD')}, "-MN"); + } + + #We are the parent: + if (!defined $new_master_pid) { + $self->log("Cannot fork for ssh master: $!\n"); + return 0; + } + + $ssh_master_pids->{$ssh_socket} = $new_master_pid; + + while ( ! -S $ssh_socket ) + { + sleep 1; + my $wpid = waitpid ( $new_master_pid, WNOHANG ); + return 0 if ($wpid == -1 or $wpid == $new_master_pid); + } + return 1; +} + +sub shutdown { + my $self = shift; + my $signame = shift; + + $self->log("buildd ($$) received SIG$signame -- shutting down\n"); + + if ($self->get('SSH_MASTER_PIDS')) { + my $ssh_master_pids = $self->get('SSH_MASTER_PIDS'); + for my $ssh_socket (keys %{$ssh_master_pids}) { + my $master_pid = $ssh_master_pids->{$ssh_socket}; + kill ( 15, $master_pid ); + delete ( $ssh_master_pids->{$ssh_socket} ); + } + } + + if (defined $main::sbuild_pid) { + $self->log("Killing sbuild (pid=$main::sbuild_pid)\n"); + kill( 15, $main::sbuild_pid ); + $self->log("Waiting max. 2 minutes for sbuild to finish\n"); + $SIG{'ALRM'} = sub ($) { die "timeout\n"; }; + alarm( 120 ); + eval "waitpid( $main::sbuild_pid, 0 )"; + alarm( 0 ); + if ($@) { + $self->log("sbuild did not die!"); + } + else { + $self->log("sbuild died normally"); + } + unlink( "SBUILD-REDO-DUMPED" ); + } + unlink( $self->get('Config')->get('PIDFILE') ); + $self->log("exiting now\n"); + $self->close_log(); + exit 1; +} + +1; diff --git a/lib/Buildd/DistConf.pm b/lib/Buildd/DistConf.pm new file mode 100644 index 0000000..6edffba --- /dev/null +++ b/lib/Buildd/DistConf.pm @@ -0,0 +1,159 @@ +# +# Conf.pm: configuration library for buildd +# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de> +# Copyright © 2005 Ryan Murray <rmurray@debian.org> +# Copyright © 2006-2009 Roger Leigh <rleigh@debian.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +####################################################################### + +package Buildd::DistConf; + +use strict; +use warnings; + +use Sbuild::ConfBase; +use Sbuild::Sysconfig; +use Buildd::ClientConf qw(); + +BEGIN { + use Exporter (); + our (@ISA, @EXPORT); + + @ISA = qw(Exporter); + + @EXPORT = qw(new_hash setup read_hash); +} + +sub new_hash (@); +sub setup ($); +sub read_hash ($$); + +sub new_hash (@) { + my %opts = @_; + + my $queue_config = Sbuild::ConfBase->new(%opts); + + Buildd::DistConf::setup($queue_config); + Buildd::DistConf::read_hash($queue_config, $opts{'HASH'}); + + return $queue_config; +} + +sub setup ($) { + my $conf = shift; + + my $validate_directory_in_home = sub { + my $conf = shift; + my $entry = shift; + my $key = $entry->{'NAME'}; + my $directory = $conf->get($key); + my $home_directory = $conf->get('HOME'); + + die "$key directory is not defined" + if !defined($directory) || !$directory; + + die "$key directory '$home_directory/$directory' does not exist" + if !-d $home_directory . "/" . $directory; + }; + + my $arch = $conf->get('ARCH'); + + my %buildd_dist_keys = ( + 'DIST_NAME' => { + DEFAULT => 'unstable' + }, + 'BUILT_ARCHITECTURE' => { + DEFAULT => undef, + }, + 'SBUILD_CHROOT' => { + DEFAULT => undef, + }, + 'WANNA_BUILD_SSH_HOST' => { + DEFAULT => 'buildd.debian.org' + }, + 'WANNA_BUILD_SSH_USER' => { + DEFAULT => 'buildd_' . $arch + }, + 'WANNA_BUILD_SSH_SOCKET' => { + DEFAULT => undef + }, + 'WANNA_BUILD_SSH_OPTIONS' => { + DEFAULT => [] + }, + 'WANNA_BUILD_DB_NAME' => { + DEFAULT => undef, + }, + 'WANNA_BUILD_DB_USER' => { + DEFAULT => $Buildd::username + }, + 'WANNA_BUILD_API' => { + DEFAULT => undef, + }, + 'WANNA_BUILD_MIN_AGE' => { + DEFAULT => undef, + }, + 'DUPLOAD_LOCAL_QUEUE_DIR' => { + CHECK => $validate_directory_in_home, + DEFAULT => 'upload' + }, + 'NO_AUTO_BUILD' => { + DEFAULT => [] + }, + 'WEAK_NO_AUTO_BUILD' => { + DEFAULT => [] + }, + 'NO_BUILD_REGEX' => { + DEFAULT => undef + }, + 'BUILD_REGEX' => { + DEFAULT => undef + }, + 'LOGS_MAILED_TO' => { + DEFAULT => undef + }, + 'LOGS_MAIL_ALSO' => { + DEFAULT => undef + }, + 'BUILD_DEP_RESOLVER' => { + DEFAULT => undef + }, + 'SIGN_WITH' => { + DEFAULT => undef + }, + 'MAINTAINER_NAME' => { + DEFAULT => undef + }, + 'MAILFROM' => { + DEFAULT => undef + }, + ); + + $conf->set_allowed_keys(\%buildd_dist_keys); + + Buildd::ClientConf::setup($conf); +} + +sub read_hash($$) { + my $conf = shift; + my $data = shift; + + for my $key (keys %$data) { + $conf->set($key, $data->{$key}); + } +} + +1; diff --git a/lib/Buildd/Mail.pm b/lib/Buildd/Mail.pm new file mode 100644 index 0000000..09f43ec --- /dev/null +++ b/lib/Buildd/Mail.pm @@ -0,0 +1,1354 @@ +# buildd-mail: mail answer processor for buildd +# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de> +# Copyright © 2009 Roger Leigh <rleigh@debian.org> +# Copyright © 2005 Ryan Murray <rmurray@debian.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +####################################################################### + +package Buildd::Mail; + +use strict; +use warnings; + +use Buildd qw(ll_send_mail lock_file unlock_file send_mail exitstatus); +use Buildd::Conf qw(); +use Buildd::Base; +use Sbuild qw(binNMU_version $devnull); +use Sbuild::ChrootRoot; +use Buildd::Client; +use POSIX; +use File::Basename; +use MIME::QuotedPrint; +use MIME::Base64; +use Encode; + +BEGIN { + use Exporter (); + our (@ISA, @EXPORT); + + @ISA = qw(Exporter Buildd::Base); + + @EXPORT = qw(); +} + +sub new { + my $class = shift; + my $conf = shift; + + my $self = $class->SUPER::new($conf); + bless($self, $class); + + $self->set('Mail Error', undef); + $self->set('Mail Short Error', undef); + $self->set('Mail Header', {}); + $self->set('Mail Body Text', ''); + + $self->open_log(); + + return $self; +} + +sub run { + my $self = shift; + + chdir($self->get_conf('HOME')); + + $self->set('Mail Error', undef); + $self->set('Mail Short Error', undef); + $self->set('Mail Header', {}); + $self->set('Mail Body Text', ''); + + $self->process_mail(); + + return 0; +} + + +sub process_mail () { + my $self = shift; + +# Note: Mail Header (to|from|subject|message-id|date) are mandatory. +# Check for these and bail out if not present. + my $header_text = ""; + my $lastheader = ""; + + $self->set('Mail Header', {}); + + $self->set('Mail Error', ''); + $self->set('Mail Short Error', ''); + $self->set('Mail Header', {}); + $self->set('Mail Body Text', ''); + + while( <STDIN> ) { + $header_text .= $_; + last if /^$/; + + if (/^\s/ && $lastheader) { + $_ =~ s/^\s+//; + $_ = "$lastheader $_"; + } + + if (/^From (\S+)/) { + ; + } + if (/^([\w\d-]+):\s*(.*)\s*$/) { + my $hname; + ($hname = $1) =~ y/A-Z/a-z/; + $self->get('Mail Header')->{$hname} = $2; + $lastheader = $_; + chomp( $lastheader ); + } + else { + $lastheader = ""; + } + } + while( <STDIN> ) { + last if !/^\s*$/; + } + + $self->set('Mail Body Text', + $self->get('Mail Body Text') . $_) + if defined($_); + + if (!eof) + { + local($/); + undef $/; + $self->set('Mail Body Text', + $self->get('Mail Body Text') . <STDIN>); + } + + if ($self->get('Mail Header')->{'from'} =~ /mail\s+delivery\s+(sub)?system|mailer.\s*daemon/i) { + # is an error mail from a mailer daemon + # To avoid mail loops if this error resulted from a mail we sent + # outselves, we break the loop by not forwarding this mail after the 5th + # error mail within 8 hours or so. + my $n = $self->add_error_mail(); + if ($n > 5) { + $self->log("Too much error mails ($n) within ", + int($self->get_conf('ERROR_MAIL_WINDOW')/(60*60)), " hours\n", + "Not forwarding mail from ".$self->get('Mail Header')->{'from'}."\n", + "Subject: " . $self->get('Mail Header')->{'subject'} . "\n"); + return; + } + } + + goto forward_mail if !$self->get('Mail Header')->{'subject'}; + my $subject = $self->get('Mail Header')->{'subject'}; + Encode::from_to($subject, "MIME-Header", "utf-8"); + + if ($subject =~ /^Re: Log for \S+ build of (\S+)(?: on [\w-]+)? \(dist=(\S+)\)/i) { + # reply to a build log + my( $package, $dist_name ) = ( $1, $2 ); + + my $dist_config = $self->get_dist_config_by_name($dist_name); + return if (!$dist_config); #get_dist_config sets the error mail + + my $text = $self->get('Mail Body Text'); + $text =~ /^(\S+)/; + $self->set('Mail Body Text', $text); + if (defined($self->get('Mail Header')->{'content-transfer-encoding'})) { + # Decode the mail if necessary. + if ($self->get('Mail Header')->{'content-transfer-encoding'} =~ /quoted-printable/) { + $self->set('Mail Body Text', + decode_qp($self->get('Mail Body Text'))); + } elsif ($self->get('Mail Header')->{'content-transfer-encoding'} =~ /base64/) { + $self->set('Mail Body Text', + decode_base64($self->get('Mail Body Text'))); + } + } + my $keyword = $1; + my $from = $self->get('Mail Header')->{'from'}; + $from = $1 if $from =~ /<(.+)>/; + $self->log("Log reply from $from\n"); + my %newv; + + if ($keyword =~ /^not-for-us/) { + $self->no_build( $package, $dist_config ); + $self->purge_pkg( $package, $dist_config ); + } + elsif ($keyword =~ /^up(l(oad)?)?-rem/) { + $self->remove_from_upload( $package, $dist_config ); + } + elsif ($self->check_is_outdated( $dist_config, $package )) { + # Error has been set already -> no action here + } + elsif ($keyword =~ /^fail/) { + my $text = $self->get('Mail Body Text'); + $text =~ s/^fail.*\n(\s*\n)*//; + $text =~ s/\n+$/\n/; + $self->set_to_failed( $package, $dist_config, $text ); + $self->purge_pkg( $package, $dist_config ); + } + elsif ($keyword =~ /^ret/) { + if (!$self->check_state( $package, $dist_config, qw(Built Building Build-Attempted) )) { + # Error already set + } + else { + $self->append_to_REDO( $package, $dist_config ); + } + } + elsif ($keyword =~ /^d(ep(endency)?)?-(ret|w)/) { + if (!$self->check_state( $package, $dist_config, qw(Built Building Build-Attempted) )) { + # Error already set + } + else { + $self->get('Mail Body Text') =~ /^\S+\s+(.*)$/m; + my $deps = $1; + $self->set_to_depwait( $package, $dist_config, $deps ); + $self->purge_pkg( $package, $dist_config ); + } + } + elsif ($keyword =~ /^man/) { + if (!$self->check_state( $package, $dist_config, qw(Built Building Build-Attempted) )) { + # Error already set + } + else { + # no action + $self->log("$package($dist_name) will be finished manually\n"); + } + } + elsif ($keyword =~ /^newv/) { + # build a newer version instead + $self->get('Mail Body Text') =~ /^newv\S*\s+(\S+)/; + my $newv = $1; + if ($newv =~ /_/) { + $self->log("Removing unneeded package name from $newv\n"); + $newv =~ s/^.*_//; + $self->log("Result: $newv\n"); + } + my $pkgname; + ($pkgname = $package) =~ s/_.*$//; + $self->redo_new_version( $dist_config, $package, "${pkgname}_${newv}" ); + $self->purge_pkg( $package, $dist_config ); + } + elsif ($keyword =~ /^(give|back)/) { + $self->get('Mail Body Text') =~ /^(give|back) ([-0-9]+)/; + my $pri = $1; + if (!$self->check_state( $package, $dist_config, qw(Built Building Build-Attempted) )) { + # Error already set + } + else { + $self->give_back( $package, $dist_config ); + $self->purge_pkg( $package, $dist_config ); + } + } + elsif ($keyword =~ /^purge/) { + $self->purge_pkg( $package, $dist_config ); + } + elsif ($self->get('Mail Body Text') =~ /^---+\s*BEGIN PGP SIGNED MESSAGE/) { + if ($self->prepare_for_upload( $package, + $self->get('Mail Body Text') )) { + $self->purge_pkg( $package, $dist_config ); + } + } + elsif ($self->get('Mail Body Text') =~ /^--/ && + $self->get('Mail Header')->{'content-type'} =~ m,multipart/signed,) { + my ($prot) = ($self->get('Mail Header')->{'content-type'} =~ m,protocol="([^"]*)",); + my ($bound) = ($self->get('Mail Header')->{'content-type'} =~ m,boundary="([^"]*)",); + my $text = $self->get('Mail Body Text'); + $text =~ s,^--\Q$bound\E\nContent-Type: text/plain; charset=us-ascii\n\n,-----BEGIN PGP SIGNED MESSAGE-----\n\n,; + $text =~ s,--\Q$bound\E\nContent-Type: application/pgp-signature\n\n,,; + $text =~ s,\n\n--\Q$bound\E--\n,,; + $self->set('Mail Body Text', $text); + if ($self->prepare_for_upload($package, + $self->get('Mail Body Text'))) { + $self->purge_pkg( $package, $dist_config ); + } + } + else { + $self->set('Mail Short Error', + $self->get('Mail Short Error') . + "Bad keyword in answer $keyword\n"); + $self->set('Mail Error', + $self->get('Mail Error') . + "Answer not understood (expected retry, failed, manual,\n". + "dep-wait, giveback, not-for-us, purge, upload-rem,\n". + "newvers, or a signed changes file)\n"); + } + } + elsif ($subject =~ /^Re: Should I build (\S+) \(dist=(\S+)\)/i) { + # reply whether a prev-failed package should be built + my( $package, $dist_name ) = ( $1, $2 ); + + my $dist_config = $self->get_dist_config_by_name($dist_name); + return if (!$dist_config); #get_dist_config sets the error mail + + $self->get('Mail Body Text') =~ /^(\S+)/; + my $keyword = $1; + $self->log("Should-build reply for $package($dist_name)\n"); + if ($self->check_is_outdated( $dist_config, $package )) { + # Error has been set already -> no action here + } + elsif (!$self->check_state( $package, $dist_config, qw(Built Building Build-Attempted) )) { + # Error already set + } + elsif ($keyword =~ /^(build|ok)/) { + $self->append_to_REDO( $package, $dist_config ); + } + elsif ($keyword =~ /^fail/) { + my $text = $self->get_fail_msg( $package, $dist_config ); + $self->set_to_failed( $package, $dist_config, $text ); + } + elsif ($keyword =~ /^(not|no-b)/) { + $self->no_build( $package, $dist_config ); + } + elsif ($keyword =~ /^(give|back)/) { + $self->give_back( $package, $dist_config ); + } + else { + $self->set('Mail Short Error', + $self->get('Mail Short Error') . + "Bad keyword in answer $keyword\n"); + $self->set('Mail Error', + $self->get('Mail Error') . + "Answer not understood (expected build, ok, fail, ". + "give-back, or no-build)\n"); + } + } + elsif ($subject =~ /^Processing of (\S+)/) { + my $job = $1; + # mail from Erlangen queue daemon: forward all non-success messages + my $text = $self->get('Mail Body Text'); + goto forward_mail if $text !~ /uploaded successfully/mi; + $self->log("$job processed by upload queue\n") + if $self->get_conf('LOG_QUEUED_MESSAGES'); + } + elsif ($subject =~ /^([-+~\.\w]+\.changes) (INSTALL|ACCEPT)ED/) { + # success mail from dinstall + my $changes_f = $1; + my( @to_remove, $upload_f, $pkgv ); + my @upload_dirs = $self->find_upload_dirs_for_changes_file($changes_f); + + if ((scalar @upload_dirs) < 1) { + $self->log("Can't identify upload directory for $changes_f!\n"); + return 0; + } elsif ((scalar @upload_dirs) > 1) { + $self->log("Found more than one upload directory for $changes_f - not deleting binaries!\n"); + return 0; + } + my $upload_dir = $upload_dirs[0]; + + if (-f "$upload_dir/$changes_f" && open( F, "<$upload_dir/$changes_f" )) { + local($/); undef $/; + my $changetext = <F>; + close( F ); + push( @to_remove, $self->get_files_from_changes( $changetext ) ); + } else { + foreach (split( "\n", $self->get('Mail Body Text'))) { + if (/^(\[-+~\.\w]+\.(u?deb))$/) { + my $f = $1; + push( @to_remove, $f ) if !grep { $_ eq $f } @to_remove; + } + } + } + ($upload_f = $changes_f) =~ s/\.changes$/\.upload/; + push( @to_remove, $changes_f, $upload_f ); + ($pkgv = $changes_f) =~ s/_(\S+)\.changes//; + $self->log("$pkgv has been installed; removing from upload dir:\n", + "@to_remove\n"); + + my @dists; + if (open( F, "<$upload_dir/$changes_f" )) { + my $changes_text; + { local($/); undef $/; $changes_text = <F>; } + close( F ); + @dists = $self->get_dists_from_changes( $changes_text ); + } else { + $self->log("Cannot get dists from $upload_dir/$changes_f: $! (assuming unstable)\n"); + @dists = ( "unstable" ); + } + +FILE: foreach (@to_remove) { + if (/\.deb$/) { + # first listed wins + foreach my $dist (@dists) { + if ( -d $self->get_conf('HOME') . "/build/chroot-$dist" && + -w $self->get_conf('HOME') . "/build/chroot-$dist/var/cache/apt/archives/") { + # TODO: send all of to_remove to perl-apt if it's available, setting a try_mv list + # that only has build-depends in it. + # if that's too much cpu, have buildd use perl-apt if avail to export the + # build-depends list, which could then be read in at this point + if (system (qw(mv --), "$upload_dir/$_", + $self->get_conf('HOME') . + "/build/chroot-$dist/var/cache/apt/archives/")) { + $self->log("Cannot move $upload_dir/$_ to cache dir\n"); + } else { + next FILE; + } + } + } + } + unlink "$upload_dir/$_" + or $self->log("Can't remove $upload_dir/$_: $!\n"); +} + } + elsif ($subject =~ /^(\S+\.changes) is NEW$/) { + # "is new" mail from dinstall + my $changes_f = $1; + my $pkgv; + ($pkgv = $changes_f) =~ s/_(\S+)\.changes//; + $self->log("$pkgv must be manually dinstall-ed -- delayed\n"); + } + elsif ($subject =~ /^new version of (\S+) \(dist=(\S+)\)$/) { + # notice from wanna-build + my ($pkg, $dist_name) = ($1, $2); + my $dist_config = $self->get_dist_config_by_name($dist_name); + goto forward if $self->get('Mail Body Text') !~ /^in version (\S+)\.$/m; + my $pkgv = $pkg."_".$1; + $self->get('Mail Body Text') =~ /new source version (\S+)\./m; + my $newv = $1; + $self->log("Build of $pkgv ($dist_name) obsolete -- new version $newv\n"); + $self->register_outdated( $dist_name, $pkgv, $pkg."_".$newv ); + + my @ds; + if (!(@ds = $self->check_building_any_dist( $pkgv ))) { + if (!$self->remove_from_REDO( $pkgv )) { + $self->append_to_SKIP( $pkgv ); + } + $self->purge_pkg( $pkgv, $dist_config ); + } + else { + $self->log("Not deleting, still building for @ds\n"); + } + } + elsif ($self->get('Mail Body Text') =~ /^blacklist (\S+)\n$/) { + my $pattern = "\Q$1\E"; + if (open( F, ">>mail-blacklist" )) { + print F "$pattern\n"; + close( F ); + $self->log("Added $pattern to blacklist.\n"); + } + else { + $self->log("Can't open mail-blacklist for appending: $!\n"); + } + } + else { + goto forward_mail; + } + + + if ($self->get('Mail Error')) { + $self->log("Error: ", + $self->get('Mail Short Error') || $self->get('Mail Error')); + $self->reply("Your mail could not be processed:\n" . + $self->get('Mail Error')); + } + return; + +forward_mail: + my $header = $self->get('Mail Header'); + $self->log("Mail from $header->{'from'}\nSubject: $subject\n"); + if ($self->is_blacklisted( $self->get('Mail Header')->{'from'} )) { + $self->log("Address is blacklisted, deleting mail.\n"); + } + else { + $self->log("Not for me, forwarding to admin\n"); + ll_send_mail( $self->get_conf('ADMIN_MAIL'), + "To: $header->{'to'}\n". + ($header->{'cc'} ? "Cc: $header->{'cc'}\n" : ""). + "From: $header->{'from'}\n". + "Subject: $header->{'subject'}\n". + "Date: $header->{'date'}\n". + "Message-Id: $header->{'message-id'}\n". + ($header->{'reply-to'} ? "Reply-To: $header->{'reply-to'}\n" : ""). + ($header->{'in-reply-to'} ? "In-Reply-To: $header->{'in-reply-to'}\n" : ""). + ($header->{'references'} ? "References: $header->{'references'}\n" : ""). + ($header->{'content-type'} ? "Content-Type: $header->{'content-type'}\n": ""). + "Resent-From: $Buildd::gecos <$Buildd::username\@$Buildd::hostname>\n". + "Resent-To: " . $self->get_conf('ADMIN_MAIL') . "\n\n". + $self->get('Mail Body Text') ); + } +} + + +sub prepare_for_upload ($$) { + my $self = shift; + my $pkg = shift; + my $changes = shift; + + $changes =~ s/\n+$/\n/; + + my( @files, @md5, @missing, @md5fail, $i ); + + my @to_dists = $self->get_dists_from_changes( $changes ); + if (!@to_dists) { # probably not a valid changes + + $self->set('Mail Short Error', + $self->get('Mail Error')); + $self->set('Mail Error', + $self->get('Mail Error') . + "Couldn't find a valid Distribution: line.\n"); + return 0; + } + + my $changes_filename_arch = $self->get_conf('ARCH'); + #Try to extract the arch from the actual changes file (see #566398) + if ($changes =~ /^Architecture:\s*(.+)/m) { + my @arches = grep { $_ ne "all" } split /\s+/, $1; + if (@arches > 1) { + $changes_filename_arch = "multi"; + } else { + $changes_filename_arch = $arches[0]; + } + } + + $changes =~ /^Files:\s*\n((^[ ]+.*\n)*)/m; + foreach (split( "\n", $1 )) { + push( @md5, (split( /\s+/, $_ ))[1] ); + push( @files, (split( /\s+/, $_ ))[5] ); + } + if (!@files) { # probably not a valid changes + $self->set('Mail Short Error', + $self->get('Mail Error')); + $self->set('Mail Error', + $self->get('Mail Error') . + "No files listed in changes.\n"); + return 0; + } + my @wrong_dists = (); + foreach my $d (@to_dists) { + push( @wrong_dists, $d ) + if !$self->check_state( + $pkg, + $self->get_dist_config_by_name($d), + qw(Building Built Install-Wait Reupload-Wait Build-Attempted)); + } + if (@wrong_dists) { + $self->set('Mail Short Error', + $self->get('Mail Error')); + $self->set('Mail Error', + $self->get('Mail Error') . + "Package $pkg has target distributions @wrong_dists\n". + "for which it isn't registered as Building.\n". + "Please fix this by either modifying the Distribution: ". + "header or\n". + "taking the package in those distributions, too.\n"); + return 0; + } + + for( $i = 0; $i < @files; ++$i ) { + if (! -f $self->get_conf('HOME') . "/build/$files[$i]") { + push( @missing, $files[$i] ) ; + } + else { + my $home = $self->get_conf('HOME'); + chomp( my $sum = `md5sum $home/build/$files[$i]` ); + push( @md5fail, $files[$i] ) if (split(/\s+/,$sum))[0] ne $md5[$i]; + } + } + if (@missing) { + $self->set('Mail Short Error', + $self->get('Mail Short Error') . + "Missing files for move: @missing\n"); + $self->set('Mail Error', + $self->get('Mail Error') . + "While trying to move the built package $pkg to upload,\n". + "the following files mentioned in the .changes were not found:\n". + "@missing\n"); + return 0; + } + if (@md5fail) { + $self->set('Mail Short Error', + $self->get('Mail Short Error') . + "md5 failure during move: @md5fail\n"); + $self->set('Mail Error', + $self->get('Mail Error') . + "While trying to move the built package $pkg to upload,\n". + "the following files had bad md5 checksums:\n". + "@md5fail\n"); + return 0; + } + + my @upload_dirs = $self->get_upload_queue_dirs ( $changes ); + + my $pkg_noep = $pkg; + $pkg_noep =~ s/_\d*:/_/; + my $changes_name = $pkg_noep . "_" . $changes_filename_arch . ".changes"; + + for my $upload_dir (@upload_dirs) { + if (! -d $upload_dir &&!mkdir( $upload_dir, 0750 )) { + $self->set('Mail Error', + $self->get('Mail Error') . + "Cannot create directory $upload_dir"); + $self->log("Cannot create dir $upload_dir\n"); + return 0; + } + } + + my $errs = 0; + for my $upload_dir (@upload_dirs) { + lock_file( $upload_dir ); + foreach (@files) { + if (system('cp', '--', $self->get_conf('HOME')."/build/$_", "$upload_dir/$_")) { + $self->log("Cannot copy $_ to $upload_dir/\n"); + ++$errs; + } + } + + open( F, ">$upload_dir/$changes_name" ); + print F $changes; + close( F ); + unlock_file( $upload_dir ); + $self->log("Moved $pkg to ", basename($upload_dir), "\n"); + } + + foreach (@files) { + if (!unlink($self->get_conf('HOME') . "/build/$_")) { + $self->log("Cannot remove build/$_\n"); + ++$errs; + } + } + + if ($errs) { + $self->set('Mail Error', + $self->get('Mail Error') . + "Could not move all files to upload dir."); + return 0; + } + + unlink( $self->get_conf('HOME') . "/build/$changes_name" ) + or $self->log("Cannot remove " . $self->get_conf('HOME') . "/$changes_name: $!\n"); +} + +sub redo_new_version ($$$) { + my $self = shift; + my $dist_config = shift; + my $oldv = shift; + my $newv = shift; + + my $err = 0; + + my $db = $self->get_db_handle($dist_config); + my $pipe = $db->pipe_query('-v', $newv); + if ($pipe) { + while(<$pipe>) { + next if /^wanna-build Revision/ || + /^\S+: Warning: Older version / || + /^\S+: ok$/; + $self->set('Mail Error', + $self->get('Mail Error') . $_); + $err = 1; + } + close($pipe); + } else { + $self->log("Can't spawn wanna-build: $!\n"); + $self->set('Mail Error', + $self->get('Mail Error') . + "Can't spawn wanna-build: $!\n"); + return; + } + if ($err) { + $self->log("Can't take newer version $newv due to wanna-build errors\n"); + return; + } + $self->log("Going to build $newv instead of $oldv\n"); + + $self->append_to_REDO( $newv, $dist_config ); +} + +sub purge_pkg ($$) { + my $self = shift; + my $pkg = shift; + my $dist_config = shift; + my $dist_name = $dist_config->get('DIST_NAME'); + + my $dir; + local( *F ); + + $self->remove_from_REDO( $pkg ); + + # remove .changes and .deb in build dir (if existing) + my $pkg_noep = $pkg; + $pkg_noep =~ s/_\d*:/_/; + my $changes = "${pkg_noep}_" . $self->get_conf('ARCH') . ".changes"; + if (-f "build/$changes" && open( F, "<build/$changes" )) { + local($/); undef $/; + my $changetext = <F>; + close( F ); + my @files = $self->get_files_from_changes( $changetext ); + push( @files, $changes ); + $self->log("Purging files: $changes\n"); + unlink( map { "build/$_" } @files ); + } + + # schedule dir for purging + ($dir = $pkg_noep) =~ s/-[^-]*$//; # remove Debian revision + $dir =~ s/_/-/; # change _ to - + if (-d "build/chroot-$dist_name/build/$Buildd::username/$dir") { + $dir = "build/chroot-$dist_name/build/$Buildd::username/$dir"; + } + else { + $dir = "build/$dir"; + } + return if ! -d $dir; + + lock_file( "build/PURGE" ); + if (open( F, ">>build/PURGE" )) { + print F "$dir\n"; + close( F ); + $self->log("Scheduled $dir for purging\n"); + } + else { + $self->set('Mail Error', + $self->get('Mail Error') . + "Can't open build/PURGE: $!\n"); + $self->log("Can't open build/PURGE: $!\n"); + } + unlock_file( "build/PURGE" ); +} + +sub remove_from_upload ($) { + my $self = shift; + my $pkg = shift; + my $dist_config = shift; + + my($changes_f, $upload_f, $changes_text, @to_remove); + local( *F ); + + $self->log("Remove $pkg from upload dir\n"); + my $pkg_noep = $pkg; + $pkg_noep =~ s/_\d*:/_/; + $changes_f = "${pkg_noep}_" . $self->get_conf('ARCH') . ".changes"; + + my $upload_dir = $self->get_conf('HOME') . '/' . $dist_config->get('DUPLOAD_LOCAL_QUEUE_DIR'); + + if (!-f "$upload_dir/$changes_f") { + $self->log("$changes_f does not exist\n"); + return; + } + if (!open( F, "<$upload_dir/$changes_f" )) { + $self->log("Cannot open $upload_dir/$changes_f: $!\n"); + return; + } + { local($/); undef $/; $changes_text = <F>; } + close( F ); + @to_remove = $self->get_files_from_changes( $changes_text ); + + ($upload_f = $changes_f) =~ s/\.changes$/\.upload/; + push( @to_remove, $changes_f, $upload_f ); + + $self->log("Removing files:\n", "@to_remove\n"); + foreach (@to_remove) { + unlink "$upload_dir/$_" + or $self->log("Can't remove $upload_dir/$_: $!\n"); + } +} + +sub append_to_REDO ($$) { + my $self = shift; + my $pkg = shift; + my $dist_config = shift; + my $dist_name = $dist_config->get('DIST_NAME'); + + local( *F ); + + lock_file( "build/REDO" ); + + if (open( F, "build/REDO" )) { + my @pkgs = <F>; + close( F ); + if (grep( /^\Q$pkg\E\s/, @pkgs )) { + $self->log("$pkg is already in REDO -- not rescheduled\n"); + goto unlock; + } + } + + if (open( F, ">>build/REDO" )) { + print F "$pkg $dist_name\n"; + close( F ); + $self->log("Scheduled $pkg for rebuild\n"); + } + else { + $self->set('Mail Error', + $self->get('Mail Error') . + "Can't open build/REDO: $!\n"); + $self->log("Can't open build/REDO: $!\n"); + } + + unlock: + unlock_file( "build/REDO" ); +} + +sub remove_from_REDO ($) { + my $self = shift; + my $pkg = shift; + + local( *F ); + + lock_file( "build/REDO" ); + goto unlock if !open( F, "<build/REDO" ); + my @pkgs = <F>; + close( F ); + if (!open( F, ">build/REDO" )) { + $self->log("Can't open REDO for writing: $!\n", + "Would write: @pkgs\nminus $pkg\n"); + goto unlock; + } + my $done = 0; + foreach (@pkgs) { + if (/^\Q$pkg\E\s/) { + ++$done; + } + else { + print F $_; + } + } + close( F ); + $self->log("Deleted $pkg from REDO list.\n") if $done; + unlock: + unlock_file( "build/REDO" ); + return $done; +} + +sub append_to_SKIP ($) { + my $self = shift; + my $pkg = shift; + + local( *F ); + + return if !open( F, "<build/build-progress" ); + my @lines = <F>; + close( F ); + + if (grep( /^\s*\Q$pkg\E$/, @lines )) { + # pkg is in build-progress, but without a suffix (failed, + # successful, currently building), so it can be skipped + lock_file( "build/SKIP" ); + if (open( F, ">>build/SKIP" )) { + print F "$pkg\n"; + close( F ); + $self->log("Told sbuild to skip $pkg\n"); + } + unlock_file( "build/SKIP" ); + } +} + +sub check_is_outdated ($$) { + my $self = shift; + my $dist_config = shift; + my $package = shift; + my $dist_name = $dist_config->get('DIST_NAME'); + + my %newv; + return 0 if !(%newv = $self->is_outdated( $dist_name, $package )); + + my $have_changes = 1 if $self->get('Mail Body Text') =~ /^---+\s*BEGIN PGP SIGNED MESSAGE/; + + # If we have a changes file, we can see which distributions that + # package is aimed to. Otherwise, we're out of luck because we can't see + # reliably anymore for which distribs the package was for. Let the user + # find out this... + # + # If the package is outdated in all dists we have to consider, + # send a plain error message. If only outdated in some of them, send a + # modified error that tells to send a restricted changes (with + # Distribution: only for those dists where it isn't outdated), or to do + # the action manually, because it would be (wrongly) propagated. + goto all_outdated if !$have_changes; + + my @check_dists = (); + @check_dists = $self->get_dists_from_changes($self->get('Mail Body Text')); + + my @not_outdated = (); + my @outdated = (); + foreach (@check_dists) { + if (!exists $newv{$_}) { + push( @not_outdated, $_ ); + } + else { + push( @outdated, $_ ); + } + } + return 0 if !@outdated; + if (@not_outdated) { + $self->set('Mail Short Error', + $self->get('Mail Short Error') . + "$package ($dist_name) partially outdated ". + "(ok for @not_outdated)\n"); + $self->set('Mail Error', + $self->get('Mail Error') . + "Package $package ($dist_name) is partially outdated.\n". + "The following new versions have appeared in the meantime:\n ". + join( "\n ", map { "$_: $newv{$_}" } keys %newv )."\n\n". + "Please send a .changes for the following distributions only:\n". + " Distribution: ".join( " ", @not_outdated )."\n"); + } + else { + all_outdated: + $self->set('Mail Short Error', + $self->get('Mail Short Error') . + "$package ($dist_name) outdated; new versions ". + join( ", ", map { "$_:$newv{$_}" } keys %newv )."\n"); + $self->set('Mail Error', + $self->get('Mail Error') . + "Package $package ($dist_name) is outdated.\n". + "The following new versions have appeared in the meantime:\n ". + join( "\n ", map { "$_: $newv{$_}" } keys %newv )."\n"); + } + return 1; +} + +sub is_outdated ($$) { + my $self = shift; + my $dist_name = shift; + my $pkg = shift; + + my %result = (); + local( *F ); + + lock_file( "outdated-packages" ); + goto unlock if !open( F, "<outdated-packages" ); + while( <F> ) { + my($oldpkg, $newpkg, $t, $d) = split( /\s+/, $_ ); + $d ||= "unstable"; + if ($oldpkg eq $pkg && $d eq $dist_name) { + $result{$d} = $newpkg; + } + } + close( F ); + unlock: + unlock_file( "outdated-packages" ); + return %result; +} + +sub register_outdated ($$$) { + my $self = shift; + my $dist = shift; + my $oldv = shift; + my $newv = shift; + + my(@pkgs); + local( *F ); + + lock_file( "outdated-packages" ); + + if (open( F, "<outdated-packages" )) { + @pkgs = <F>; + close( F ); + } + + if (!open( F, ">outdated-packages" )) { + $self->log("Cannot open outdated-packages for writing: $!\n"); + goto unlock; + } + my $now = time; + my @d = (); + foreach (@pkgs) { + my($oldpkg, $newpkg, $t, $d) = split( /\s+/, $_ ); + $d ||= "unstable"; + next if ($oldpkg eq $oldv && $d eq $dist) || ($now - $t) > 21*24*60*60; + print F $_; + } + print F "$oldv $newv $now $dist\n"; + close( F ); + unlock: + unlock_file( "outdated-packages" ); +} + +sub set_to_failed ($$$) { + my $self = shift; + my $pkg = shift; + my $dist_config = shift; + my $text = shift; + my $dist_name = $dist_config->get('DIST_NAME'); + + my $is_bugno = 0; + + $text =~ s/^\.$/../mg; + $is_bugno = 1 if $text =~ /^\(see #\d+\)$/; + return if !$self->check_state( $pkg, $dist_config, $is_bugno ? "Failed" : qw(Built Building Build-Attempted BD-Uninstallable) ); + + my $db = $self->get_db_handle($dist_config); + my $pipe = $db->pipe_query_out('--failed', $pkg); + if ($pipe) { + print $pipe "${text}.\n"; + close($pipe); + } + if ($?) { + my $t = "wanna-build --failed failed with status ".exitstatus($?)."\n"; + $self->log($t); + $self->set('Mail Error', + $self->get('Mail Error') . $t); + } elsif ($is_bugno) { + $self->log("Bug# appended to fail message of $pkg ($dist_name)\n"); + } + else { + $self->log("Set package $pkg ($dist_name) to Failed\n"); + $self->write_stats("failed", 1); + } +} + +sub set_to_depwait ($$$) { + my $self = shift; + my $pkg = shift; + my $dist_config = shift; + my $deps = shift; + my $dist_name = $dist_config->get('DIST_NAME'); + + my $db = $self->get_db_handle($dist_config); + my $pipe = $db->pipe_query_out('--dep-wait', $pkg); + if ($pipe) { + print $pipe "$deps\n"; + close($pipe); + } + if ($?) { + my $t = "wanna-build --dep-wait failed with status ".exitstatus($?)."\n"; + $self->log($t); + $self->set('Mail Error', + $self->get('Mail Error') . $t); + } + else { + $self->log("Set package $pkg ($dist_name) to Dep-Wait\nDependencies: $deps\n"); + } + $self->write_stats("dep-wait", 1); +} + +sub give_back ($$) { + my $self = shift; + my $pkg = shift; + my $dist_config = shift; + my $dist_name = $dist_config->get('DIST_NAME'); + + my $answer; + + my $db = $self->get_db_handle($dist_config); + my $pipe = $db->pipe_query('--give-back', $pkg); + if ($pipe) { + $answer = <$pipe>; + close($pipe); + } + if ($?) { + $self->set('Mail Error', + $self->get('Mail Error') . + "wanna-build --give-back failed:\n$answer"); + } + else { + $self->log("Given back package $pkg ($dist_name)\n"); + } +} + +sub no_build ($$) { + my $self = shift; + my $pkg = shift; + my $dist_config = shift; + my $dist_name = $dist_config->get('DIST_NAME'); + my $answer_cmd; + + my $answer; + + my $db = $self->get_db_handle($dist_config); + my $pipe = $db->pipe_query('--no-build', $pkg); + if ($pipe) { + $answer = <$pipe>; + close($pipe); + } + if ($?) { + $self->set('Mail Error', + $self->get('Mail Error') . + "no-build failed:\n$answer"); + } + else { + $self->log("Package $pkg ($dist_name) to set Not-For-Us\n"); + } + $self->write_stats("no-build", 1); +} + +sub get_fail_msg ($$) { + my $self = shift; + my $pkg = shift; + my $dist_config = shift; + my $dist_name = $dist_config->get('DIST_NAME'); + + $pkg =~ s/_.*//; + + my $db = $self->get_db_handle($dist_config); + my $pipe = $db->pipe_query('--info', $pkg); + if ($pipe) { + my $msg = ""; + while(<$pipe>) { + if (/^\s*Old-Failed\s*:/) { + while(<$pipe>) { + last if /^ \S+\s*/; + $_ =~ s/^\s+//; + if (/^----+\s+\S+\s+----+$/) { + last if $msg; + } + else { + $msg .= $_; + } + } + last; + } + } + close($pipe); + return $msg if $msg; + $self->set('Mail Error', + $self->get('Mail Error') . + "Couldn't find Old-Failed in info for $pkg\n"); + return "Same as previous version (couldn't extract the text)\n"; + } else { + $self->set('Mail Error', + $self->get('Mail Error') . + "Couldn't start wanna-build --info: $!\n"); + return "Same as previous version (couldn't extract the text)\n"; + } +} + +sub check_state ($@) { + my $self = shift; + my $mail_error = $self->get('Mail Error'); + my $retval = $self->check_state_internal(@_); + # check if we should retry the call + if ($retval == -1) { + my $interval = int(rand(120)); + $self->log("Retrying --info in $interval seconds...\n"); + # reset error to old value + $self->set('Mail Error', $mail_error); + # 0..120s of sleep ought to be enough for retrying; + # for mail bursts, this should get us out of the + # crticial mass + sleep $interval; + $retval = $self->check_state_internal(@_); + # remap the -1 retry code to failure + if ($retval == -1) { + return 0; + } else { + return $retval; + } + } + return $retval; +} + +sub check_state_internal ($$@) { + my $self = shift; + my $pkgv = shift; + my $dist_config = shift; + my @wanted_states = @_; + my $dist_name = $dist_config->get('DIST_NAME'); + + $pkgv =~ /^([^_]+)_(.+)/; + my ($pkg, $vers) = ($1, $2); + + my $db = $self->get_db_handle($dist_config); + my $pipe = $db->pipe_query('--info', $pkg); + if (!$pipe) { + $self->set('Mail Error', + $self->get('Mail Error') . + "Couldn't start wanna-build --info: $!\n"); + $self->log("Couldn't start wanna-build --info: $!\n"); + # let check_state() retry if needed + return -1; + } + + my ($av, $as, $ab, $an); + while(<$pipe>) { + $av = $1 if /^\s*Version\s*:\s*(\S+)/; + $as = $1 if /^\s*State\s*:\s*(\S+)/; + $ab = $1 if /^\s*Builder\s*:\s*(\S+)/; + $an = $1 if /^\s*Binary-NMU-Version\s*:\s*(\d+)/; + } + close($pipe); + + if ($?) { + my $t = "wanna-build --info failed with status ".exitstatus($?)."\n"; + $self->log($t); + $self->set('Mail Error', + $self->get('Mail Error') . $t); + return 0; + } + + my $msg = "$pkgv($dist_name) check_state(@wanted_states): "; + $av = binNMU_version($av,$an,undef) if (defined $an); + if ($av ne $vers) { + $self->set('Mail Error', + $self->get('Mail Error') . + $msg."version $av registered as $as\n"); + return 0; + } + if (!Buildd::isin( $as, @wanted_states)) { + $self->set('Mail Error', + $self->get('Mail Error') . + $msg."state is $as\n"); + return 0; + } + if ($as eq "Building" && $ab ne $dist_config->get('WANNA_BUILD_DB_USER')) { + $self->set('Mail Error', + $self->get('Mail Error') . + $msg."is building by $ab\n"); + return 0; + } + return 1; +} + +sub check_building_any_dist ($) { + my $self = shift; + my $pkgv = shift; + + my @dists; + + $pkgv =~ /^([^_]+)_(.+)/; + my ($pkg, $vers) = ($1, $2); + + for my $dist_config (@{$self->get_conf('DISTRIBUTIONS')}) { + my $dist_name = $dist_config->get('DIST_NAME'); + + my $db = $self->get_db_handle($dist_config); + my $pipe = $db->pipe_query('--info', $pkg); + if (!$pipe) { + $self->set('Mail Error', + $self->get('Mail Error') . + "Couldn't start wanna-build --info: $!\n"); + return 0; + } + + my $text; + { local ($/); $text = <$pipe>; } + close($pipe); + + while( $text =~ /^\Q$pkg\E\((\w+)\):(.*)\n((\s.*\n)*)/mg ) { + my ($dist, $rest, $info) = ($1, $2, $3); + next if $rest =~ /not registered/; + my ($av, $as, $ab); + $av = $1 if $info =~ /^\s*Version\s*:\s*(\S+)/mi; + $as = $1 if $info =~ /^\s*State\s*:\s*(\S+)/mi; + $ab = $1 if $info =~ /^\s*Builder\s*:\s*(\S+)/mi; + push( @dists, $dist ) + if $av eq $vers && $as eq "Building" && + $ab eq $self->get_conf('WANNA_BUILD_DB_USER'); + } + } + return @dists; +} + +sub get_files_from_changes ($) { + my $self = shift; + my $changes_text = shift; + + my(@filelines, @files); + + $changes_text =~ /^Files:\s*\n((^[ ]+.*\n)*)/m; + @filelines = split( "\n", $1 ); + foreach (@filelines) { + push( @files, (split( /\s+/, $_ ))[5] ); + } + return @files; +} + +sub get_dists_from_changes ($) { + my $self = shift; + my $changes_text = shift; + + $changes_text =~ /^Distribution:\s*(.*)\s*$/mi; + return split( /\s+/, $1 ); +} + +sub get_upload_queue_dirs ($) { + my $self = shift; + my $changes_text = shift; + + my %upload_dirs; + my @dists = $self->get_dists_from_changes( $changes_text ); + for my $dist_config (@{$self->get_conf('DISTRIBUTIONS')}) { + my $upload_dir = $self->get_conf('HOME') . '/' . $dist_config->get('DUPLOAD_LOCAL_QUEUE_DIR'); + + if (grep { $dist_config->get('DIST_NAME') eq $_ } @dists) { + $upload_dirs{$upload_dir} = 1; + } + } + return keys %upload_dirs; +} + +sub find_upload_dirs_for_changes_file ($) { + my $self = shift; + my $changes_file_name = shift; + + my %dirs; + + for my $dist_config (@{$self->get_conf('DISTRIBUTIONS')}) { + my $upload_dir = $self->get_conf('HOME') . '/' . $dist_config->get('DUPLOAD_LOCAL_QUEUE_DIR'); + if (-f "$upload_dir/$changes_file_name") { + $dirs{$upload_dir} = 1; + } + } + + return keys %dirs; +} + +sub reply ($) { + my $self = shift; + my $text = shift; + + my( $to, $subj, $quoting ); + + $to = $self->get('Mail Header')->{'reply-to'} || + $self->get('Mail Header')->{'from'}; + $subj = $self->get('Mail Header')->{'subject'}; + $subj = "Re: $subj" if $subj !~ /^Re\S{0,2}:/; + ($quoting = $self->get('Mail Body Text')) =~ s/\n+$/\n/; + $quoting =~ s/^/> /mg; + + send_mail( $to, $subj, "$text\n$quoting", + "In-Reply-To: ". $self->get('Mail Header')->{'message-id'}. "\n" ); +} + +sub is_blacklisted ($) { + my $self = shift; + my $addr = shift; + + local( *BL ); + + $addr = $1 if $addr =~ /<(.*)>/; + return 0 if !open( BL, "<mail-blacklist" ); + while( <BL> ) { + chomp; + if ($addr =~ /$_$/) { + close( BL ); + return 1; + } + } + close( BL ); + return 0; +} + +sub add_error_mail () { + my $self = shift; + + local( *F ); + my $now = time; + my @em = (); + + if (open( F, "<mail-errormails" )) { + chomp( @em = <F> ); + close( F ); + } + push( @em, $now ); + shift @em while @em && ($now - $em[0]) > $self->get_conf('ERROR_MAIL_WINDOW'); + + if (@em) { + open( F, ">mail-errormails" ); + print F join( "\n", @em ), "\n"; + close( F ); + } + else { + unlink( "mail-errormails" ); + } + + return scalar(@em); +} + +1; diff --git a/lib/Buildd/Makefile.am b/lib/Buildd/Makefile.am new file mode 100644 index 0000000..5b5b930 --- /dev/null +++ b/lib/Buildd/Makefile.am @@ -0,0 +1,42 @@ +# sbuild Makefile template +# +# +# Copyright © 2004-2009 Roger Leigh <rleigh@debian.org> +# +# sbuild is free software: you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# sbuild is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +##################################################################### + +include $(top_srcdir)/scripts/global.mk + +perlmodbuildddir = $(perlmoddir)/Buildd + +MODULES = \ + Base.pm \ + Client.pm \ + ClientConf.pm \ + Conf.pm \ + DistConf.pm \ + UploadQueueConf.pm \ + Daemon.pm \ + Mail.pm \ + Uploader.pm \ + Watcher.pm + +perlmodbuildd_DATA = \ + $(MODULES) + +EXTRA_DIST = \ + $(MODULES) diff --git a/lib/Buildd/UploadQueueConf.pm b/lib/Buildd/UploadQueueConf.pm new file mode 100644 index 0000000..d0fb1e0 --- /dev/null +++ b/lib/Buildd/UploadQueueConf.pm @@ -0,0 +1,96 @@ +# +# Conf.pm: configuration library for buildd +# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de> +# Copyright © 2005 Ryan Murray <rmurray@debian.org> +# Copyright © 2006-2009 Roger Leigh <rleigh@debian.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +####################################################################### + +package Buildd::UploadQueueConf; + +use strict; +use warnings; + +use Sbuild::ConfBase; +use Sbuild::Sysconfig; + +BEGIN { + use Exporter (); + our (@ISA, @EXPORT); + + @ISA = qw(Exporter); + + @EXPORT = qw(new_hash setup read_hash); +} + +sub new_hash (@); +sub setup ($); +sub read_hash ($$); + +sub new_hash (@) { + my %opts = @_; + + my $queue_config = Sbuild::ConfBase->new(%opts); + + Buildd::UploadQueueConf::setup($queue_config); + Buildd::UploadQueueConf::read_hash($queue_config, $opts{'HASH'}); + + return $queue_config; +} + +sub setup ($) { + my $conf = shift; + + my $validate_directory_in_home = sub { + my $conf = shift; + my $entry = shift; + my $key = $entry->{'NAME'}; + my $directory = $conf->get($key); + my $home_directory = $conf->get('HOME'); + + die "$key directory is not defined" + if !defined($directory) || !$directory; + + die "$key directory '$home_directory/$directory' does not exist" + if !-d $home_directory . "/" . $directory; + }; + + my %dupload_queue_keys = ( + 'DUPLOAD_LOCAL_QUEUE_DIR' => { + CHECK => $validate_directory_in_home, + DEFAULT => 'upload' + }, + 'DUPLOAD_ARCHIVE_NAME' => { + DEFAULT => 'anonymous-ftp-master' + }, + ); + + $conf->set_allowed_keys(\%dupload_queue_keys); + + Buildd::ClientConf::setup($conf); +} + +sub read_hash ($$) { + my $conf = shift; + my $data = shift; + + for my $key (keys %$data) { + $conf->set($key, $data->{$key}); + } +} + +1; diff --git a/lib/Buildd/Uploader.pm b/lib/Buildd/Uploader.pm new file mode 100644 index 0000000..302f5da --- /dev/null +++ b/lib/Buildd/Uploader.pm @@ -0,0 +1,274 @@ +# buildd-uploader: upload finished packages for buildd +# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de> +# Copyright © 2009 Roger Leigh <rleigh@debian.org> +# Copyright © 2005 Ryan Murray <rmurray@debian.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +####################################################################### + +package Buildd::Uploader; + +use strict; +use warnings; + +use Buildd qw(lock_file unlock_file unset_env exitstatus send_mail); +use Buildd::Base; +use Buildd::Conf qw(); + +BEGIN { + use Exporter (); + our (@ISA, @EXPORT); + + @ISA = qw(Exporter Buildd::Base); + + @EXPORT = qw(); +} + +sub new { + my $class = shift; + my $conf = shift; + + my $self = $class->SUPER::new($conf); + bless($self, $class); + + $self->set('Uploader Lock', undef); + $self->set('Uploaded Pkgs', {}); + + $self->open_log(); + + return $self; +} + +sub run { + my $self = shift; + + unset_env(); + + $self->set('Uploader Lock', + lock_file("$main::HOME/buildd-uploader", 1)); + + if (!$self->get('Uploader Lock')) { + $self->log("exiting; another buildd-uploader is still running"); + return 1; + } + + for my $queue_config (@{$self->get_conf('UPLOAD_QUEUES')}) { + $self->upload( + $queue_config->get('DUPLOAD_LOCAL_QUEUE_DIR'), + $queue_config->get('DUPLOAD_ARCHIVE_NAME')); + } + + my $uploaded_pkgs = $self->get('Uploaded Pkgs'); + + foreach my $archdist (keys %{$uploaded_pkgs}) { + $self->log("Set to Uploaded($archdist):$uploaded_pkgs->{$archdist}"); + } + + return 0; +} + +sub uploaded ($@) { + my $self = shift; + my $pkg = shift; + my $arch_name = shift; + my $dist_name = shift; + + my $msgs = ""; + + my $dist_config = $self->get_arch_dist_config_by_name($arch_name, $dist_name); + my $db = $self->get_db_handle($dist_config); + + my $pipe = $db->pipe_query('--uploaded', $pkg); + + if ($pipe) { + while(<$pipe>) { + if (!/^(\S+): Propagating new state /) { + $msgs .= $_; + } + } + close($pipe); + if ($msgs or $?) { + $self->log($msgs) if $msgs; + $self->log("wanna-build --uploaded failed with status ", + exitstatus($?), "\n" ) + if $?; + } else { + my $archdist_name = "$arch_name/$dist_name"; + $self->get('Uploaded Pkgs')->{$archdist_name} .= " $pkg"; + } + } else { + $self->log("Can't spawn wanna-build --uploaded: $!\n"); + } +} + +sub upload ($$) { + my $self = shift; + my $udir = shift; + my $upload_to = shift; + + chdir( "$main::HOME/$udir" ) || return; + lock_file( "$main::HOME/$udir" ); + + my( $f, $g, @before, @after ); + + foreach $f (<*.changes>) { + ($g = $f) =~ s/\.changes$/\.upload/; + push( @before, $f ) if ! -f $g; + } + + unlock_file( "$main::HOME/$udir" ); + + if (!@before) { + $self->log("Nothing to do for $udir\n"); + return; + } + + $self->log(scalar(@before), " jobs to upload in $udir: @before\n"); + + foreach $f (@before) { + ($g = $f) =~ s/\.changes$/\.upload/; + my $logref = $self->do_dupload( $upload_to, $f ); + + if (defined $logref and scalar(@$logref) > 0) { + my $line; + + foreach $line (@$logref) { + $self->log($line); + } + } + + if ( -f $g ) { + if (!open( F, "<$f" )) { + $self->log("Cannot open $f: $!\n"); + next; + } + my $text; + { local($/); undef $/; $text = <F>; } + close( F ); + if ($text !~ /^Architecture:\s*(.*)\s*$/m) { + $self->log("$f doesn't have a Architecture: field\n"); + next; + } + my @archs = split( /\s+/, $1 ); + if ($text !~ /^Distribution:\s*(.*)\s*$/m) { + $self->log("$f doesn't have a Distribution: field\n"); + next; + } + my @dists = split( /\s+/, $1 ); + my ($version,$source,$pkg); + if ($text =~ /^Version:\s*(\S+)\s*$/m) { + $version = $1; + } + if ($text =~ /^Source:\s*(\S+)(?:\s+\(\S+\))?\s*$/m) { + $source = $1; + } + if (defined($version) and defined($source)) { + $pkg = "${source}_$version"; + } else { + ($pkg = $f) =~ s/_\S+\.changes$//; + } + $self->uploaded($pkg, @archs, @dists); + } else { + push (@after, $f); + } + } + + if (@after) { + $self->log("The following jobs were not processed (successfully):\n" . + "@after\n"); + } + else { + $self->log("dupload successful.\n"); + } + $self->write_stats("uploads", scalar(@before) - scalar(@after)); +} + +sub do_dupload ($@) { + my $self = shift; + my $upload_to = shift; + + my @jobs = @_; + my @log; + local( *PIPE ); + my( $current_job, $current_file, @failed, $errs ); + + if (!open( PIPE, "dupload -k --to $upload_to @jobs </dev/null 2>&1 |" )) { + return "Cannot spawn dupload: $!"; + } + + my $dup_log = ""; + while( <PIPE> ) { + $dup_log .= $_; + chomp; + if (/^\[ job \S+ from (\S+\.changes)$/) { + $current_job = $1; + } + elsif (/^warning: MD5sum mismatch for (\S+), skipping/i) { + my $f = $1; + push( @log, "dupload error: md5sum mismatch for $f\n" ); + $errs .= "md5sum mismatch on file $f ($current_job)\n"; + push( @failed, $current_job ); + } + elsif (/^\[ Uploading job (\S+)$/) { + $current_job = "$1.changes"; + } + elsif (/dupload fatal error: Can't upload (\S+)/i || + /^\s(\S+).*scp: (.*)$/) { + my($f, $e) = ($1, $2); + push( @log, "dupload error: upload error for $f\n" ); + push( @log, "($e)\n" ) if $e; + $errs .= "upload error on file $f ($current_job)\n"; + push( @failed, $current_job ); + } + elsif (/Timeout at [\S]+ line [\d]+$/) { + $errs .= "upload timeout on file $current_job\n"; + push( @failed, $current_job ); + } + elsif (/^\s(\S+)\s+[\d.]+ kB /) { + $current_file = $1; + } + } + close( PIPE ); + if ($?) { + if (($? >> 8) == 141) { + push( @log, "dupload error: SIGPIPE (broken connection)\n" ); + $errs .= "upload error (broken connection) during ". + "file $current_file ($current_job)\n"; + push( @failed, $current_job ); + } + else { + push( @log, "dupload exit status ". exitstatus($?) ); + $errs .= "dupload exit status ".exitstatus($?)."\n"; + push( @failed, $current_job ); + } + } + + foreach (@failed) { + my $u = $_; + $u =~ s/\.changes$/\.upload/; + unlink( $u ); + push( @log, "Removed $u due to upload errors.\n" ); + $errs .= "Removed $u to reupload later.\n"; + } + + if ($errs) { + $errs .= "\nComplete output from dupload:\n\n$dup_log"; + send_mail($self->get_conf('ADMIN_MAIL'), "dupload errors", $errs); + } + return \@log; +} + +1; diff --git a/lib/Buildd/Watcher.pm b/lib/Buildd/Watcher.pm new file mode 100644 index 0000000..fd83d4e --- /dev/null +++ b/lib/Buildd/Watcher.pm @@ -0,0 +1,528 @@ +# buildd-watcher: +# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de> +# Copyright © 2009 Roger Leigh <rleigh@debian.org> +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see +# <http://www.gnu.org/licenses/>. +# +####################################################################### + +package Buildd::Watcher; + +use strict; +use warnings; +use Buildd qw(send_mail lock_file unlock_file unset_env); +use Buildd::Conf qw(); +use Buildd::Base; + +use POSIX qw(ESRCH LONG_MAX); +use Cwd; + +sub ST_MTIME () { 9 } + +BEGIN { + use Exporter (); + our (@ISA, @EXPORT); + + @ISA = qw(Exporter Buildd::Base); + + @EXPORT = qw(); +} + +sub new { + my $class = shift; + my $conf = shift; + + my $self = $class->SUPER::new($conf); + bless($self, $class); + + $self->set('Fudge', 1/24/6); # 10 minutes in units of a day + $self->set('Graph Maxval', { + 'builds-per-day' => 100, + 'uploads-per-day' => 100, + 'failed-per-day' => 50, + 'dep-wait-per-day' => 50, + 'give-back-per-day' => 50, + 'time-per-build' => 10*60*60, + 'build-time-percent' => 1, + 'idle-time-percent' => 1}); + + $self->open_log(); + + return $self; +} + +sub run { + my $self = shift; + + unset_env(); + chdir($self->get_conf('HOME')); + +# check if another watcher is still running + my $watcher_pid; + if (open( PID, "<watcher-running")) { + $watcher_pid = <PID>; + close( PID ); + $watcher_pid =~ /^\s*(\d+)/; $watcher_pid = $1; + if (!$watcher_pid || (kill( 0, $watcher_pid ) == 0 && $! == ESRCH)) { + $self->log("Ignoring stale watcher-running file (pid $watcher_pid).\n"); + } + else { + $self->log("Another buildd-watcher is still running ". + "(pid $watcher_pid) -- exiting.\n"); + return 0; + } + } + open( F, ">watcher-running.new" ) + or die "Can't create watcher-running.new: $!\n"; + printf F "%5d\n", $$; + close( F ); + rename( "watcher-running.new", "watcher-running" ) + or die "Can't rename watcher-running.new: $!\n"; + +# check if buildd is still running, restart it if needed. + my $restart = 0; + my $daemon_pid; + if (open( PID, "<" . $self->get_conf('PIDFILE') )) { + $daemon_pid = <PID>; + close( PID ); + $daemon_pid =~ /^\s*(\d+)/; $daemon_pid = $1; + if (!$daemon_pid || (kill( 0, $daemon_pid ) == 0 && $! == ESRCH)) { + $self->log("pid file exists, but process $daemon_pid doesn't exist.\n"); + $restart = 1; + } + } + else { + $self->log("daemon not running (no pid file).\n"); + $restart = 1; + } + +# do dir-purges that buildd-mail can't do (is running as nobody, so no sudo) + lock_file( "build/PURGE" ); + my @to_purge = (); + if (open( F, "<build/PURGE" )) { + @to_purge = <F>; + close( F ); + unlink( "build/PURGE" ); + chomp( @to_purge ); + } + unlock_file( "build/PURGE" ); + + foreach (@to_purge) { + next if ! -d $_; + system(qw(sudo rm -rf --), $_); + $self->log("Purged $_\n"); + } + +# cut down mail-errormails file + my $now = time; + my @em = (); + if (open( F, "<mail-errormails" )) { + chomp( @em = <F> ); + close( F ); + } + shift @em while @em && ($now - $em[0]) > $self->get_conf('ERROR_MAIL_WINDOW'); + if (@em) { + open( F, ">mail-errormails" ); + print F join( "\n", @em ), "\n"; + close( F ); + } + else { + unlink( "mail-errormails" ); + } + +# check for old stuff in build and upload dirs + my %warnfile; + my $file; + my $dev; + my $ino; + foreach $file (<upload/*>) { + ($dev,$ino) = lstat $file; + $warnfile{"$dev:$ino"} = $file if -M $file >= $self->get_conf('WARNING_AGE'); + } + # TODO: Glob is incompatible with modern sbuild, which doesn't use + # separate user directories. + my $username = $self->get_conf('USERNAME'); + foreach $file (<build/chroot-*/build/$username/*>) { + ($dev,$ino) = lstat $file; + if (! -d _ && ! -l _) { + $warnfile{"$dev:$ino"} = $file if -C _ >= $self->get_conf('WARNING_AGE'); + } + else { + my $warnage = $self->get_conf('WARNING_AGE'); + my $changed_files = + `find $file -ctime -$warnage -print 2>/dev/null`; + $warnfile{"$dev:$ino"} = $file if !$changed_files; + } + } + foreach $file (<build/*>) { + next if $file =~ m#^build/chroot-[^/]+$#; + ($dev,$ino) = lstat $file; + if (! -d _ && ! -l _) { + $warnfile{"$dev:$ino"} = $file if -C _ >= $self->get_conf('WARNING_AGE'); + } + else { + my $warnage = $self->get_conf('WARNING_AGE'); + my $changed_files = + `find $file -ctime -$warnage -print 2>/dev/null`; + $warnfile{"$dev:$ino"} = $file if !$changed_files; + } + } + my $nowarnpattern = $self->get_conf('NO_WARN_PATTERN'); + my @warnings = grep( !/$nowarnpattern/, sort values %warnfile ); + if (@warnings) { + my %reported; + my @do_warn; + if (open( W, "<reported-old-files" )) { + while( <W> ) { + next if !/^(\S+)\s+(\d+)$/; + $reported{$1} = $2; + } + close( W ); + } + + foreach (@warnings) { + if (!exists($reported{$_}) || + ($now - $reported{$_}) >= $self->get_conf('WARNING_AGE')*24*60*60) { + push( @do_warn, $_ ); + $reported{$_} = $now; + } + } + + my $old_umask = umask 007; + open( W, ">reported-old-files" ) + or die "Can't create/write reported-old-files: $!\n"; + foreach (keys %reported) { + print W "$_ $reported{$_}\n" if -e $_ || -l $_; + } + close( W ); + umask $old_umask; + + send_mail( $self->get_conf('ADMIN_MAIL'), "buildd-watcher found some old files", + "buildd-watcher has found some old files or directories in\n". + "~buildd/upload and/or ~buildd/build. Those are:\n\n ". + join( "\n ", @do_warn ). "\n\n". + "Please have a look at them and remove them if ". + "they're obsolete.\n" ) + if @do_warn; + } + +# archive old package/build log files + $self->archive_logs( "logs", "*", "old-logs/plog", $self->get_conf('PKG_LOG_KEEP') ); + $self->archive_logs( "build", "build-*.log", "old-logs/blog", $self->get_conf('BUILD_LOG_KEEP') ); + +# rotate daemon's log file + if (!-f "old-logs/daemon-stamp" || + -M "old-logs/daemon-stamp" > $self->get_conf('DAEMON_LOG_ROTATE')-$self->get('Fudge')) { + + $self->log("Rotating daemon log file\n"); + system(qw(touch old-logs/daemon-stamp)); + + my $d = $self->format_time(time); + if (-f $self->get_conf('DAEMON_LOG_FILE') . ".old") { + system(qw(mv --), $self->get_conf('DAEMON_LOG_FILE') . '.old', "old-logs/daemon-$d.log"); + system(qw(gzip -9), "old-logs/daemon-$d.log"); + } + + rename( $self->get_conf('DAEMON_LOG_FILE'), + $self->get_conf('DAEMON_LOG_FILE') . ".old" ); + my $old_umask = umask 0007; + system(qw(touch --), $self->get_conf('DAEMON_LOG_FILE')); + umask $old_umask; + kill( 1, $daemon_pid ) if $daemon_pid; + $self->reopen_log(); + + if ($self->get_conf('DAEMON_LOG_SEND')) { + my $text; + open( F, "<" . $self->get_conf('DAEMON_LOG_FILE') . ".old" ); + { local($/); undef $/; $text = <F>; } + close( F ); + send_mail( $self->get_conf('ADMIN_MAIL'), "Build Daemon Log $d", $text ); + } + } + $self->archive_logs( "old-logs", "daemon-*.log.gz", "old-logs/dlog", $self->get_conf('DAEMON_LOG_KEEP') ); + +# make buildd statistics + if (!-f "stats/Stamp" || + -M "stats/Stamp" > $self->get_conf('STATISTICS_PERIOD')-$self->get('Fudge')) { + + $self->log("Making buildd statistics\n"); + lock_file( "stats" ); + my $lasttime = 0; + if (open( F, "<stats/Stamp" )) { + chomp( $lasttime = <F> ); + close( F ); + } + my $now = time; + + $self->make_statistics( $lasttime, $now ); + + open( F, ">stats/Stamp" ); + print F "$now\n"; + close( F ); + unlock_file( "stats" ); + + my $text; + open( F, "<stats/Summary" ); + { local($/); undef $/; $text = <F>; } + close( F ); + send_mail( $self->get_conf('STATISTICS_MAIL'), "Build Daemon Statistics", $text ); + } + + if ($restart) { + if (-f "NO-DAEMON-PLEASE") { + $self->log("NO-DAEMON-PLEASE exists, not starting daemon\n"); + } + else { + $self->close_log(); + unlink ("watcher-running"); + exec "buildd"; + } + } + + unlink ("watcher-running"); + return 0; +} + +sub archive_logs ($$$$) { + my $self = shift; + my $dir = shift; + my $pattern = shift; + my $destpat = shift; + my $minage = shift; + + my( $olddir, $file, @todo, $oldest, $newest, $oldt, $newt ); + + return if -f "$destpat-stamp" && -M "$destpat-stamp" < $minage-$self->get('Fudge'); + $self->log("Archiving logs in $dir:\n"); + system(qw(touch --), "$destpat-stamp"); + + $olddir = cwd; + chdir( $dir ); + + $oldest = LONG_MAX; + $newest = 0; + foreach $file (glob($pattern)) { + if (-M $file >= $minage) { + push( @todo, $file ); + my $modtime = (stat(_))[ST_MTIME]; + $oldest = $modtime if $oldest > $modtime; + $newest = $modtime if $newest < $modtime; + } + } + if (@todo) { + $oldt = $self->format_time($oldest); + $newt = $self->format_time($newest); + $file = $self->get_conf('HOME') . "/$destpat-$oldt-$newt.tar"; + + system(qw(tar cf), $file, '--', @todo); + system(qw(gzip -9 --), $file); + + if ($dir eq "logs") { + local (*F); + my $index = $self->get_conf('HOME') . "/$destpat-$oldt-$newt.index"; + if (open( F, ">$index" )) { + print F join( "\n", @todo ), "\n"; + close( F ); + } + } + + unlink( @todo ); + $self->log("Archived ", scalar(@todo), " files from $oldt to $newt\n"); + } + else { + $self->log("No files to archive\n"); + } + + chdir( $olddir ); +} + +sub make_statistics ($$) { + my $self = shift; + my $start_time = shift; + my $end_time = shift; + + my @svars = qw(taken builds uploads failed dep-wait no-build + give-back idle-time build-time remove-time + install-download-time); + my ($s_taken, $s_builds, $s_uploads, $s_failed, $s_dep_wait, + $s_no_build, $s_give_back, $s_idle_time, $s_build_time, + $s_remove_time, $s_install_download_time); + local( *F, *G, *OUT ); + + my $var; + foreach $var (@svars) { + my $svar = "s_$var"; + $svar =~ s/-/_/g; + eval "\$$svar = 0;"; + if (-f "stats/$var") { + if (!open( F, "<stats/$var" )) { + $self->log("can't open stats/$var: $!\n"); + next; + } + my $n = 0; + while( <F> ) { + chomp; + $n += $_; + } + close( F ); + eval "\$$svar = $n;"; + unlink( "stats/$var" ); + } + } + + my $total_time = $end_time - $start_time; + my $days = $total_time / (24*60*60); + + if (!open( OUT, ">stats/Summary" )) { + $self->log("Can't create stats/Summary: $!\n"); + return; + } + + printf OUT "Build daemon statistics from %s to %s (%3.2f days):\n\n", + $self->format_time($start_time), $self->format_time($end_time), $days; + + print OUT " #packages % of taken pkgs/day\n"; + print OUT "-------------------------------------------\n"; + printf OUT "taken : %5d %7.2f\n", + $s_taken, $s_taken/$days; + printf OUT "builds : %5d %7.2f%% %7.2f\n", + $s_builds, $s_taken ? $s_builds*100/$s_taken : 0, $s_builds/$days; + printf OUT "uploaded : %5d %7.2f%% %7.2f\n", + $s_uploads, $s_taken ? $s_uploads*100/$s_taken : 0, $s_uploads/$days; + printf OUT "failed : %5d %7.2f%% %7.2f\n", + $s_failed, $s_taken ? $s_failed*100/$s_taken : 0, $s_failed/$days; + printf OUT "dep-wait : %5d %7.2f%% %7.2f\n", + $s_dep_wait, $s_taken ? $s_dep_wait*100/$s_taken : 0, $s_dep_wait/$days; + printf OUT "give-back: %5d %7.2f%% %7.2f\n", + $s_give_back, $s_taken ? $s_give_back*100/$s_taken : 0, $s_give_back/$days; + printf OUT "no-build : %5d %7.2f%% %7.2f\n", + $s_no_build, $s_taken ? $s_no_build*100/$s_taken : 0, $s_no_build/$days; + print OUT "\n"; + + print OUT " time % of total\n"; + print OUT "----------------------------------\n"; + printf OUT "building: %s %7.2f%%\n", + $self->print_time($s_build_time), $s_build_time*100/$total_time; + printf OUT "install : %s %7.2f%%\n", + $self->print_time($s_install_download_time), $s_install_download_time*100/$total_time; + printf OUT "removing: %s %7.2f%%\n", + $self->print_time($s_remove_time), $s_remove_time*100/$total_time; + printf OUT "idle : %s %7.2f%%\n", + $self->print_time($s_idle_time), $s_idle_time*100/$total_time; + printf OUT "total : %s\n", $self->print_time($total_time); + print OUT "\n"; + + my $proc = $s_uploads+$s_failed+$s_dep_wait+$s_no_build+$s_give_back; + printf OUT "processed package (upl+fail+dep+nob): %7d\n", $proc; + printf OUT "slipped (proc-taken) : %7d\n", $proc-$s_taken; + printf OUT "builds/taken package : %7.2f\n", + $s_builds/$s_taken + if $s_taken; + printf OUT "avg. time/taken package : %s\n", + $self->print_time($s_build_time/$s_taken) + if $s_taken; + printf OUT "avg. time/processed package : %s\n", + $self->print_time($s_build_time/$proc) + if $proc; + printf OUT "avg. time/build : %s\n", + $self->print_time($s_build_time/$s_builds) + if $s_builds; + print OUT "\n"; + + my $date = $self->format_date(time); + $self->print_graph( $s_builds/$days, $date, "builds-per-day" ); + $self->print_graph( $s_uploads/$days, $date, "uploads-per-day" ); + $self->print_graph( $s_failed/$days, $date, "failed-per-day" ); + $self->print_graph( $s_dep_wait/$days, $date, "dep-wait-per-day" ); + $self->print_graph( $s_give_back/$days, $date, "give-back-per-day" ); + $self->print_graph( $s_build_time/$s_builds, $date, "time-per-build" ) + if $s_builds; + $self->print_graph( $s_build_time/$total_time, $date, "build-time-percent" ); + $self->print_graph( $s_idle_time/$total_time, $date, "idle-time-percent" ); + + my $g; + my $graph_maxval = $self->get('Graph Maxval'); + + foreach $g (keys %{$graph_maxval}) { + next if !open( G, "<stats/graphs/$g" ); + + print OUT "$g (max. $graph_maxval->{$g}):\n\n"; + while( <G> ) { + print OUT $_; + } + close( G ); + print OUT "\n"; + } + + close( OUT ); +} + +sub print_time ($) { + my $self = shift; + my $t = shift; + + my $str = sprintf "%02d:%02d:%02d", int($t/3600), int(($t%3600)/60), + int($t%60); + $str = " "x(10-length($str)) . $str; + + return $str; +} + +sub print_graph ($$$) { + my $self = shift; + my $val = shift; + my $date = shift; + my $graph = shift; + + my $width = 72; + local( *G ); + + my $graph_maxval = $self->get('Graph Maxval'); + if (!exists $graph_maxval->{$graph}) { + $self->log("Unknown graph $graph\n"); + return; + } + if (!open( G, ">>stats/graphs/$graph" )) { + $self->log("Can't create stats/graphs/$graph: $!\n"); + return; + } + $val = int( $val*$width/$graph_maxval->{$graph} + 0.5 ); + my $str = $val > $width ? "*"x($width-1)."+" : "*"x$val; + $date = substr( $date, 0, 6 ); + $date .= " " x (6-length($date)); + print G "$date $str\n"; + close( G ); +} + +sub format_time ($) { + my $self = shift; + my $t = shift; + + my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = localtime($t); + + return sprintf "%04d%02d%02d-%02d%02d", + $year+1900, $mon+1, $mday, $hour, $min; +} + +sub format_date ($) { + my $self = shift; + my $t = shift; + + my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = localtime($t); + + return sprintf "%02d%02d%02d", $year%100, $mon+1, $mday; +} + +1; |