path: root/iurt2

#!/usr/bin/perl
#
# Copyright (C) 2005 Mandrakesoft
# Copyright (C) 2005 Mandriva
# 
# Author: Florent Villard <warly@mandraesoft.com>
#
# 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, 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, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#
# compare and rebuild packages on different architecture
#
use strict;
use Hdlist;
use Data::Dumper;
use URPM;
use File::NCopy qw(copy);
use MIME::Words qw(encode_mimewords);
use Fcntl ':flock';
my $home = '/home/mandrake/';
my $cache_home = "$home/.bugs/";
my @supported_arch = ('i586', 'x86_64');
my $upload = "$home/uploads/";
my $local_home = '/export/home/mandrake';
my $base_dir = $upload;
my $check_queue = 0;
if (@ARGV[0] eq '--check_queue') { 
	$check_queue = 1;
	shift @ARGV;
	$base_dir = shift @ARGV;
}

my $distro_version = shift @ARGV;
my $distro_tag = $distro_version;
$distro_tag =~ s,/,-,g;
my $my_arch = shift @ARGV;
my $media = shift @ARGV;
my @special_srpm_dir = @ARGV;

my $unwanted_packages = '^monotone-';

$my_arch or usage();
if ($check_queue) {
	-d $base_dir or usage("$base_dir does not exist");
} else {
    $base_dir .= $distro_version;
    $base_dir =~ s/community//g;
    if ($distro_version ne 'cooker') {
        if ($media ne 'main') {
	    $base_dir .= "/$media"
        }
    } elsif ($media eq 'contrib') {
	$base_dir = "$upload/contrib"
    }
    -d $base_dir or usage("$base_dir does not exist")
}

my $pidfile = "$cache_home/iurt.$distro_tag.$my_arch.pid";
open my $lock, "$pidfile.lock";
flock($lock,LOCK_EX);
if (-f $pidfile)  {
    my (@stat) = stat $pidfile;
    open my $test_PID, $pidfile;
    my $pid = <$test_PID>;
    close $test_PID;
    if ($pid && getpgrp $pid != -1) {
	my $time = $stat[9];
	if ($time < time - 36000) {
	    print "iurt: an other iurt pid $pid is running for a very long time, killing it\n";
	    my $i;
	    while ($i < 5 && getpgrp $pid != -1) {
		kill_for_good($pid);
		$i++;
		sleep 1
	    }
	} else  {
	    print "iurt: an other iurt is running for $my_arch, pid $pid, since ",time - $time," seconds\n";
	    exit
	}
    } else {
	print "iurt: a previous iurt for $my_arch seems dead, cleaning.\n";
	unlink $pidfile
    }
}
open my $PID, ">$pidfile" or die "FATAL iurt: could not open pidfile $pidfile for writing";
print $PID $$;
close $PID;

flock($lock,LOCK_UN);
close $lock;

my $cache = "$cache_home/iurt.$distro_tag.cache";
print "iurt: loading cache file $cache\n";
eval { require $cache };
$::rpm_srpm ||= {};
$::failure ||= {};
$::queue ||= {};
$::warning ||= {};
$::run ||= {};

my %big;
my %srpm_version;
my @wrong_rpm;
foreach my $arch (@supported_arch) {
	my $rpms_dir = "/mnt/BIG/dis/$distro_version/$arch/media/$media/";
	print "iurt: checking current packages in $rpms_dir\n";
	opendir my $rpmdir, $rpms_dir or next; 
	foreach my $rpm (readdir $rpmdir) {
		my ($rarch, $srpm) = update_srpm($rpms_dir, $rpm);
		$rarch or next;
		$big{$rpm} = 1;
		$::queue->{$srpm}{$arch} = 1;
		$::queue->{$srpm}{$rarch} = 1;
		check_version($srpm)
	}
	closedir $rpmdir
}

if ($check_queue) {
	my $dir = "$base_dir/build/RPMS/";
	opendir my $rpmdir, $dir or next;

	print "iurt: checking upload queue in $dir\n";
	foreach my $rpm (readdir $rpmdir) {
		$rpm =~ /\.rpm$/ or next;
		if ($big{$rpm}) {
			print "iurt: cleaning $rpm\n";
			unlink "$dir/$rpm";
			next
		}
		my ($arch, $srpm) = update_srpm($dir, $rpm);
		$arch or next;
		$::queue->{$srpm}{$arch} = 1;
		check_version($srpm)
	}
	closedir $rpmdir;

}

my %maint;

my @todo;
-d "$base_dir/build/$my_arch" or mkdir "$base_dir/build/$my_arch";
push @special_srpm_dir, "$base_dir/build/SRPMS/" if $check_queue;
my $clean;
my %rep;
my %done_rpm;
#
# FIXME all the rep but the first one are cleaned
#
foreach my $dir ("/mnt/BIG/dis/$distro_version/SRPMS/$media/", @special_srpm_dir) {
	print "iurt: checking SRPMS dir $dir\n";
	opendir my $rpmdir, $dir or next;
	foreach my $srpm (readdir $rpmdir) {
	        # this is for the output of the new svn system
		if ($srpm =~ /^\@\d+:(.*)/) {
			link "$dir/$srpm", "$dir/$1";
			# unlink "$dir/$srpm";
			$srpm = $1
		}
		$srpm =~ /(.*)-[^-]+-[^-]+\.src\.rpm$/ or next;
		if ($srpm =~ /$unwanted_packages/) { next }
		my $ok = 1;
		if (check_version($srpm)) { 
			defined $::failure->{$srpm} && defined $::failure->{$srpm}{$my_arch} and next;
			if (!$::queue->{$srpm}{$my_arch} && !$::queue->{$srpm}{noarch}) {
				my $hdr = rpm2header("$dir/$srpm");
				check_arch($hdr) and next;
				my $changelog = $hdr->queryformat("%{CHANGELOGNAME}");
				my ($mail) = $changelog =~ /<(.*@.*)>/;
				$maint{$srpm} = $mail;
				print "iurt: will try to compile $srpm\n";
				push @todo, [ $dir , $srpm ]
			}
			foreach my $arch (@supported_arch) {
				$ok &&= $::queue->{$srpm}{$arch} || $::queue->{$srpm}{noarch}
			}
		}
		if ($clean && ($rep{$srpm} || $ok)) {
			print "iurt: cleaning $dir/$srpm\n";
			unlink "$dir/build/$srpm";
			unlink "$dir/$srpm"
		}
		$rep{$srpm} = 1
	}
	$clean = 1;
	closedir $rpmdir
}

my $run = $::run->{$distro_tag}{$my_arch}++;

dump_cache();

if (!@todo) {
    print "iurt: nothing to do\n";
    exit
}

print "iurt: checking basesystem tar\n";

my $chroot = "$local_home/chroot";
my $chroot_tar = "$chroot-$distro_tag.$my_arch.tar.gz";
perform_command("sudo ~warly/files/cvs//mdk/soft/rpm-rebuilder/install-chroot-tar.sh cooker /mnt/BIG/distrib/$distro_version/$my_arch/media/main/ $chroot_tar $chroot 501 basesystem rpm-build", 
	mail => 'maintainers@mandriva.com', 
	error => "[REBUILD] Creating the inital chroot for $distro_tag on $my_arch failed", 
	hash => 'chroot_inititialization', 
	die => 1);

my $local_spool = "$local_home/iurt/$distro_tag/$my_arch";
if (!-d "$local_home/iurt/$distro_tag/") {
	mkdir "$local_home/iurt/$distro_tag";
	if (!-d $local_spool) {
		mkdir $local_spool;
		mkdir "$local_spool/log"
	}
}

my %done;
foreach my $t (@todo) {
	my ($dir, $srpm) = @$t;
	$done{$srpm} and next;
	$done{$srpm} = 1;
	check_version($srpm) or next;
	print "iurt: installing a new chroot for $srpm in $chroot\n";
	-d $chroot and perform_command("sudo rm -rf $chroot", 
		mail => 'warly@mandriva.com', 
		error => "[REBUILD] Deleting of old chroot $chroot failed", 
		hash => 'chroot_deletion', 
		die => 1);
	mkdir $chroot;
	perform_command("pushd $chroot && sudo tar xvf $chroot_tar", 
		mail => 'warly@mandriva.com', 
		error => "[REBUILD] creating the initial chroot $chroot failed", 
		hash => 'chroot_init', 
		die => 1);

	dump_rpmmacros("$chroot/home/builder/.rpmmacros") or next;

	my ($srpm_name) = $srpm =~ /(.*)-[^-]+-[^-]+\.src\.rpm$/ or next;
	my $maintainer = `rpmmon -s -p $srpm_name`;
	my $cc = "$maint{$srpm}, maintainers\@mandriva.com";
	chomp $maintainer;
	if (!$maintainer) {
		$maintainer = $cc;
		$cc = 'maintainers@mandriva.com'
	}
	#($maintainer, $cc) = ('warly@mandriva.com','');
	print "Installing build dependencies of $srpm...\n";
	# FIXME unfortunately urpmi stalls quite often
	system(qq{sudo pkill -9 -u root -f "urpmi --root $chroot"});
	perform_command("sudo urpmi -v --root $chroot --no-verify-rpm -s --auto $dir/$srpm", 
		mail => $maintainer, 
		error => "[REBUILD] install of build dependencies of $srpm failed on $my_arch",  
		hash => "install_deps_$srpm", 
		timeout => 600, 
		cc => $cc, 
		error_regexp => 'cannot be installed',
		log => "$local_spool/log/") or next;
	perform_command("sudo chroot $chroot rpm -qa", 
		hash => "rpm_qa_$srpm", 
		timeout => 60, 
		log => "$local_spool/log/") or next;
	print "Copying $srpm to $chroot\n";
	perform_command("sudo cp $dir/$srpm $chroot/home/builder/rpm/SRPMS/", 
		mail => 'warly@mandriva.com', 
		error => "[REBUILD] cannot copy $srpm to $chroot", 
		hash => "copy_$srpm") or next;
	print "Compiling $srpm\n";
	#system(qq{sudo chroot $chroot /bin/su builder -c "mkdir rpm/RPMS/x86_64 rpm/RPMS/noarch"});
	if (!perform_command(qq{TMP=/home/builder/tmp/ sudo chroot $chroot /bin/su builder -c "rpm --rebuild /home/builder/rpm/SRPMS/$srpm"}, 
			mail => $maintainer, 
			error => "[REBUILD] $srpm from $distro_tag does not build correctly on $my_arch", 
			hash => "build_$srpm", 
			timeout => 18000, 
			cc => $cc, 
			log => "$local_spool/log/", 
			error_regexp => 'rror.*ailed|Bad exit status|RPM build error',
			freq => 1) && !glob "$chroot/home/builder/rpm/RPMS/*/*.rpm") {
		$::failure->{$srpm}{$my_arch} = 1;
		next
	}
	if (!perform_command("sudo urpmi --root $chroot --no-verify-rpm --auto $chroot/home/builder/rpm/RPMS/*/*.rpm", 
			mail => $maintainer, 
			error => "[REBUILD] binaries packages generated from $srpm do not install correctly", 
			hash => "binary_test_$srpm", 
			timeout => 300, 
			freq => 1, 
			error_regexp => 'unable to access',
			log => "$local_spool/log/")) {
		$::failure->{$srpm}{$my_arch} = 1;
		next
	}
	system("cp $chroot/home/builder/rpm/RPMS/*/*.rpm $local_spool") and print "ERROR: could not copy rpm files from $chroot/home/builder/rpm/RPMS/ to $local_spool ($!)\n";
	process_queue();
}

print "iurt: reprocess generated packages queue\n";
process_queue();

dump_cache();

print "ERROR iurt: RPM with a wrong SRPM name\n" if @wrong_rpm;
if (open my $file, ">$local_spool/log/wrong_srpm_names.log") {
    foreach (@wrong_rpm) {
	print $file "$_->[1] -> $_->[0] (", $::rpm_srpm{$_->[1]},")\n";
    }
}

system("rsync -alHPe 'ssh -c arcfour' $local_spool/log/ mandrake\@qa:/var/www/html/build/iurt/$distro_tag/$my_arch/log/");

unlink $pidfile;

exit;

sub usage {
	my ($error) = @_;
	print "
	ERROR iurt: $error" if $error;
	print "
	
	usage:
	
		iurt [options] <distro version> <arch> <media>
			e.g. iurt community/2006.0 x86_64 main

	options:
		--check_queue <queue base dir>
			e.g iurt --check_queue $home/uploads/contrib/build/ cooker x86_64 contrib


";
	exit
}

sub process_queue {
	my $dir = "$local_home/iurt/$distro_tag/$my_arch";
	#my $dir = "$base_dir/RPMS/";
	opendir my $rpmdir, $dir or next;
	foreach my $rpm (readdir $rpmdir) {
		my ($rarch, $srpm) = update_srpm($dir, $rpm);
		$rarch or next;
		# try to keep the opportunity to prevent disk full
		my $ok = copy "$dir/$rpm", "$base_dir/RPMS/";
		if (!$ok){
			print "ERROR process_queue: cannot copy $dir/$rpm to $base_dir/RPMS/ ($!)\n";
			next
		}
		unlink "$dir/$rpm";
		$::queue->{$srpm}{$rarch} = 1
	}
	closedir $rpmdir;
}

sub update_srpm {
	my ($dir, $rpm) = @_;
	my ($arch) = $rpm =~ /([^\.]+)\.rpm$/ or return 0;
	my $srpm = $::rpm_srpm->{$rpm};
	if (!$srpm) {
		my $hdr = rpm2header("$dir/$rpm");
		$hdr or return 0;
		$srpm = $hdr->queryformat("%{SOURCERPM}");
		$::rpm_srpm->{$rpm} = $srpm
	}
	$srpm = fix_srpm_name($srpm, $rpm);
	$arch, $srpm
}

sub dump_cache {
	my $filename = $cache;
	open my $file, ">$filename.tmp" or die "FATAL iurt dump_cache: cannot open $filename.tmp";
	flock($file,LOCK_EX);
	seek($file, 0, 2);
	$Data::Dumper::Indent = 1;
	print $file Data::Dumper->Dump([ $::rpm_srpm, $::failure, $::queue, $::warning, $::run ], [ "::rpm_srpm", "::failure", "::queue", "::warning", "::run" ]);
	print $file "1";
	unlink $filename;
	link "$filename.tmp", $filename;
	flock($file,LOCK_UN)
}

sub sendmail {
	my ($to, $cc, $subject, $text, $from, $debug) = @_;
	do { print "Cannot find sender-email-address [$to]\n"; return } unless defined($to);
	$from ||= "Iurt the rebuild bot <warly\@mandriva.com>";
	my $MAIL;
	if (!$debug) { open $MAIL,  "| /usr/sbin/sendmail -t" or return } else { open $MAIL,  ">&STDOUT" or return }
	my $sender = encode_mimewords($to);
	my $subject = encode_mimewords($subject);
	print $MAIL "To: $sender\n";
	if ($cc) { $cc = endcode_mimewords($cc); print $MAIL "Cc: $cc\n" }
	print $MAIL "From: $from\n";
	print $MAIL "Subject: $subject\n";
	print $MAIL "\n";
	print $MAIL $text; 
	close($MAIL)
}

sub check_arch {
	my ($hdr) = @_;
	my (@exclusive_arch) = $hdr->queryformat('%{EXCLUSIVEARCH}');
	grep { $_ eq $my_arch || $_ eq '(none)' } @exclusive_arch or return 1; 
	my (@exclude_arch) = $hdr->queryformat('%{EXCLUDEARCH}');
	grep { $_ eq $my_arch } @exclusive_arch and return 1 
}

sub check_version {
	my ($srpm) = @_;
	my ($srpm_name) = $srpm =~ /(.*)-[^-]+-[^-]+\.src\.rpm/;
	if (URPM::ranges_overlap("= $srpm",">= $srpm_version{$srpm_name}")) {
		$srpm_version{$srpm_name} = $srpm;
		return 1
	}
	0
}

sub fix_srpm_name {
	my ($srpm, $rpm) = @_;
	my $old_srpm = $srpm;
	if ($srpm =~ s/^lib64/lib/){
		push @wrong_rpm, [ $old_srpm, $rpm ];
		$::rpm_srpm->{$rpm} = $srpm
	}
	$srpm
}

sub perform_command {
	my ($command, %opt) = @_;
	$opt{timeout} ||= 300;
	$opt{freq} ||= 24;
	print "Timeout $opt{timeout}\n";
	my $p_pid = $$;
	my $pid = fork;
	my $stat;
	if ($pid) {
		print "$command\n";
		my $output;
		if ($opt{log}) {
			$output = `$command 2>&1 | tee $opt{log}/$opt{hash}.$run.log`;
		} else {
			$output = `$command 2>&1`;
		}
		# FIXME process goes in defunct always, kill -14 should unsleep it, but not
		kill 9, $pid;
		if ($? || $opt{error_regexp} && $output =~ /$opt{error_regexp}/) {
			if ($opt{mail}) {
				if ($::warning->{$opt{hash}}{$my_arch}{$opt{mail}} % $opt{freq}) {
					sendmail($opt{mail}, $opt{cc} , $opt{error} , $output, 0, 0);
				} else {
					sendmail('warly@mandriva.com', '' , $opt{error}, $output, 0, 0);
				}
			}
			$::warning->{$opt{hash}}{$my_arch}{$opt{mail}}++;
			print "\n$output\n";
			die "FATAL iurt: $opt{error}." if $opt{die};
			return 0
		}
	} else {
		my $t = sleep $opt{timeout};
		my ($cmd) = $command =~ s/^sudo //;
		my $pgrep=`pgrep -f "$cmd"`;
		print "iurt: PGREP $pgrep timeout $t\n";
		if ($t == $opt{timeout} && $pgrep) {
			print "\niurt: killing -9 $cmd\n\n";
			system(qq{sudo pkill -9 -u root -f "$cmd"});
		}
		exit
	}
	1
}

sub kill_for_good {
	my ($pid) = @_;
	kill 14, $pid;
	sleep 2;
	if (getpgrp $pid != -1) {
		kill 15, $pid;
		sleep 2;
		if (getpgrp $pid  != -1) {
			kill 9, $pid
		}
	}
}

sub dump_rpmmacros {
	my ($file) = @_;
	open my $f, qq{| sudo sh -c "cat > $file"} or return 0;
	print $f qq{\%_topdir                \%(echo \$HOME)/rpm
\%_tmppath               \%(echo \$HOME)/rpm/tmp/
\%distribution           Mandriva Linux
\%vendor                 Mandriva
\%packager               Iurt <warly\@mandriva.com>}
}