path: root/lib/Iurt/Urpmi.pm

package Iurt::Urpmi;

use strict;
use RPM4::Header;
use File::Basename;
use File::NCopy qw(copy);
use MDV::Distribconf::Build;
use MDK::Common qw(cat_);
use Iurt::Chroot qw(add_local_user create_temp_chroot);
use Iurt::Process qw(perform_command clean_process sudo);
use Iurt::Config qw(get_package_prefix);
use Iurt::Util qw(plog);
use urpm;

sub new {
    my ($class, %opt) = @_;
    my $self = bless {
        config  => $opt{config},
        run => $opt{run},
	urpmi_options => $opt{urpmi_options},
    }, $class;
    my $config = $self->{config};
    my $run = $self->{run};

    $self->{distrib_url} = "$config->{repository}/$run->{distro}/$run->{my_arch}";

    $self;
}

sub set_command {
    my ($self, $chroot_tmp) = @_;
    $self->{urpmi_command} = "urpmi $self->{urpmi_options} --urpmi-root $chroot_tmp";
}

sub set_local_media {
    my ($self, $local_media) = @_;
    $self->{local_media} = $local_media;
}

sub add_to_local_media {
    my ($self, $chroot_tmp, $srpm, $luser) = @_;
    my $local_media = $self->{local_media};

    system("cp $chroot_tmp/home/$luser/rpmbuild/RPMS/*/*.rpm $local_media &>/dev/null") and plog("ERROR: could not copy rpm files from $chroot_tmp/home/$luser/rpmbuild/RPMS/ to $local_media ($!)");
    system("cp $chroot_tmp/home/$luser/rpmbuild/SRPMS/$srpm $local_media &>/dev/null") and plog("ERROR: could not copy $srpm from $chroot_tmp/home/$luser/rpmbuild/SRPMS/ to $local_media ($!)");
}

sub urpmi_command {
    my ($self, $chroot_tmp) = @_;
    my $run = $self->{run};
    my $local_media = $self->{local_media};

    &set_command;
	# Here should be added only the needed media for the given package
	#  main/release -> main/release
	#  main/testing -> main/release main/testing
	#  contrib/release -> contrib/release main/release
	#  contrib/testing -> contrib/testing contrib/release main/testing main/release
	#  non-free/release ...
	# This is now done with an option in iurt --chrooted-urpmi -m media1 media2 -- media_url

	if ($run->{chrooted_urpmi}{media}) {
	    foreach my $m (@{$run->{chrooted_urpmi}{media}}) {
		my $m_name = $m;
		$m_name =~ s,/,_,g;
		if (!add_media($self, $chroot_tmp, $m_name,
			"$m_name $self->{distrib_url}/media/$m")) {
		    $run->{chrooted_urpmi} = 0;
		    plog('ERROR', "Failed to add media $m_name.");
		    return;
		}
	    }
	} else {
            # FIXME Do not hardcode Core
	    if (!add_media($self, $chroot_tmp, 'Core', "--distrib $self->{distrib_url}")) {
		if (!add_media($self, $chroot_tmp, 'Core', "--wget --distrib $self->{distrib_url}")) {
		    plog('ERROR', "Failed to add media $self->{distrib_url}.");
		    return;
		}
	    }
	}

	foreach my $m (@{$run->{additional_media}{media}}) {
	    my $name = "$run->{additional_media}{repository}_$m";
	    $name =~ s![/:]!_!g;

	    my $url;
	    if (!urpm::is_local_url($run->{additional_media}{repository})) {
		$url = $run->{additional_media}{repository};
	    }
	    else {
		$url = "/urpmi_medias/$run->{distro}/$m";
	    }

	    # Check if the media is not empty, as add_media will abort if it fails
	    my $DP;
	    if (!opendir($DP, "$chroot_tmp/$url")) {
		plog('ERROR', "Failed to add additional media at $url: $!");
		next;
	    }
	    my @contents = readdir $DP;
	    close($DP);
	    if (@contents <= 2) {
		# Just entries: . ..
		plog('DEBUG', "$url has no packages, skipping it.");
		next;
	    }

	    if (!add_media($self, $chroot_tmp, $name, "$name $url")) {
		plog("ERROR: Unable to add media $m");
	    }
	}

	if (-d $local_media) {
	    mkdir("$chroot_tmp/iurt_media/");
	    opendir(my $dir, $local_media);
	    my $next;
	    foreach my $f (readdir $dir) {
		$f =~ /(\.rpm|^hdlist.cz)$/ or next;
		if (!link "$local_media/$f", "$chroot_tmp/iurt_media") {
		    if (!copy "$local_media/$f", "$chroot_tmp/iurt_media") {
			plog('ERROR', "could not copy file $local_media/$f to $chroot_tmp/iurt_media");
			$next = 1;
			last;
		    }
		}
	    }
	    next if $next;
	    add_media($self, $chroot_tmp, 'iurt_group', "iurt_group file:///iurt_media") or next;
	}

	return 1;
}

sub check_media_added {
    my ($chroot, $media) = @_;
    my $medias = `urpmq --urpmi-root $chroot --list-media 2>&1`;
    print "MEDIA $medias ($media)\n";
    $medias =~ /$media/m;
}

sub add_media__urpmi_root {
    my ($self, $chroot, $media) = @_;
    my $run = $self->{run};
    my $config = $self->{config};

    foreach my $m (@{$media || []}) {
        my $url = $self->{distrib_url} . "/media/" . $m;
        my $name = $m;
        $name =~ s![/:]!_!g;
        plog("adding media $name from $url with option --urpmi-root in chroot $chroot");
        perform_command("urpmi-addmedia -v --urpmi-root $chroot $name $url --probe-synthesis", 
		$run, $config,
		mail => $config->{admin},
		use_iurt_root_command => 1,
		retry => 2,
		debug_mail => $run->{debug})
          or return;
    }

    1;
}

sub add_media {
    my ($self, $chroot, $regexp, $media) = @_;
    my $run = $self->{run};
    my $config = $self->{config};

    plog("add chroot media: $self->{distrib_url}");

    my $cmd = "urpmi-addmedia -v --urpmi-root $chroot $media";
    perform_command($cmd,
		$run, $config,
		mail => $config->{admin},
		retry => 2,
		use_iurt_root_command => 1,
		debug_mail => $run->{debug})
	or return;
    if (!check_media_added($chroot, $regexp)) { 
	plog('ERROR', "ERROR iurt could not add media into the chroot");
	return;
    } 
    1;
}

sub update {
    my ($self, $chroot) = @_;
    my $run = $self->{run};
    my $config = $self->{config};

    plog('INFO', "updating packages in $chroot");

    my $cmd = "urpmi --urpmi-root $chroot --auto-update --auto";
    perform_command($cmd,
		$run, $config,
		mail => $config->{admin},
		retry => 2,
		use_iurt_root_command => 1,
		debug_mail => $run->{debug})
	or return;
    1;
}

sub get_local_provides {
    my ($self) = @_;
    my $run = $self->{run};
    my $program_name = $run->{program_name};
    my $local_media = $self->{local_media};

    opendir(my $dir, $local_media);
    plog(1, "get local provides ($local_media)");
    require URPM;
    my $urpm = URPM->new;
    foreach my $d (readdir $dir) {
	$d =~ /\.src\.rpm$/ and next;
	$d =~ /\.rpm$/ or next;
	my $id = $urpm->parse_rpm("$local_media/$d");
	my $pkg = $urpm->{depslist}[$id];
	plog(3, "$program_name: checking $d provides");
        foreach ($pkg->provides, $pkg->files) {
	    plog(3, "$program_name: adding $_ as provides of $d");
	    $run->{local_provides}{$_} = $d;
	}
    }
    1;
}

sub get_build_requires {
    my ($self, $luser) = @_;
    my $run = $self->{run};
    my $config = $self->{config};

    $run->{todo_requires} = {};
    plog("get_build_requires");

    my (undef, $chroot_tmp) = create_temp_chroot($run, $config, $run->{chroot_tmp}, $run->{chroot_tar}) or return;
    add_local_user($chroot_tmp, $config, $luser, $run->{uid}) or return;
    
    my $urpm = URPM->new;
    foreach my $p (@{$run->{todo}}) {
	my ($dir, $srpm, $s) = @$p;
	$self->recreate_srpm($run, $config, $chroot_tmp, $dir, $srpm, $run->{user}) or return;
	$s or next;
	my $id = $urpm->parse_rpm("$dir/$srpm");
	my $pkg = $urpm->{depslist}[$id];
        foreach ($pkg->requires) {
	    plog(3, "adding $_ as requires of $srpm");
	    $run->{todo_requires}{$_} = $srpm;
	}
    }
    1;
}

sub order_packages {
    my ($self, $provides, $luser) = @_;
    my $run = $self->{run};
    my @packages = @{$run->{todo}};
    my $move;

    plog(1, "order_packages");
    get_local_provides($self) or return;
    if (!$run->{todo_requires}) {
	get_build_requires($self, $luser) or return;
    }
    my %visit;
    my %status;
    do { 
	$move = 0;
	foreach my $p (@packages) {
	    my ($_dir, $rpm, $status) = @$p;
	    defined $status{$rpm} && $status{$rpm} == 0 and next;
	    plog("checking packages $rpm");
	    foreach my $r (@{$run->{todo_requires}{$rpm}}) {
		plog("checking requires $r");
		if (!$run->{local_provides}{$r}) { 
		    if ($provides->{$r}) {
			$status = 1;
		    } else {
			$status = 0;
		    }
		} elsif ($visit{$rpm}{$r}) {
		    # to evit loops
		    $status = 0;
		} elsif ($run->{done}{$rpm} && $run->{done}{$provides->{$r}}) {
		    if ($run->{done}{$rpm} < $run->{done}{$provides->{$r}}) {
			$move = 1;
			$status = $status{$provides->{$r}} + 1;
		    } else {
			$status = 0;
		    }
		} elsif ($status < $status{$provides->{$r}}) {
		    $move = 1;
		    $status = $status{$provides->{$r}} + 1;
		}
		$visit{$rpm}{$r} = 1;
	    }
	    $status{$rpm} = $status;
	    $p->[2] = $status;
	}
    } while $move;    
    $run->{todo} = [ sort { $a->[2] <=> $b->[2] } @packages ];
    if ($run->{verbose}) {
	foreach (@packages) {
	    plog("order_packages $_->[1]");
	}
    }
    @packages;
}
	
sub wait_urpmi { 
    my ($self) = @_;
    my $run = $self->{run};

    plog("WARNING: urpmi database locked, waiting...") if $run->{debug};
    sleep 30; 
    $self->{wait_limit}++; 
    if ($self->{wait_limit} > 8) {
	return 0;
    } 
}

sub are_installed {
    my ($chroot, @pkgs) = @_;
    @pkgs = map { -f "$chroot$_" && `rpm -qp --qf %{name} $chroot$_` || $_ } @pkgs;
    system("rpm -q --root $chroot @pkgs") == 0;
}


sub _install_callback {
    my ($run, $admin, $opt, $output, $title) = @_;
    plog('DEBUG', "calling callback for $opt->{hash}");

    # 20060614
    # it seems the is needed urpmi error is due to something else (likely a
    # database corruption error).	    
    # my @missing_deps = $output =~ /(?:(\S+) is needed by )|(?:\(due to unsatisfied ([^[ ]*)(?: (.*)|\[(.*)\])?\))/g;
    #

    my @missing_deps = $output =~ /([^ \n]+) \(due to unsatisfied ([^[ \n]*)(?: ([^\n]*)|\[([^\n]*)\])?\)/g;

    # <mrl> 20071106 FIXME: This should not be needed anymore
    # as it seems that rpm db corruption is making urpmi
    # returning false problem on deps installation, try
    # to compile anyway

    if (!@missing_deps) {
        plog('DEBUG', 'missing_deps is empty, aborting.');
        plog('DEBUG', "output had: __ $output __");
        return 1;
    }

    while (my $missing_package = shift @missing_deps) {
        my $missing_deps = shift @missing_deps;
        my $version = shift @missing_deps;
        my $version2 = shift @missing_deps;
        $version ||= $version2 || 0;

        plog('FAIL', "missing dep: $missing_deps missing_package $missing_package");
        $run->{status}{$title} = 'missing_dep';

        my $maintainer = $opt->{maintainer};
        $opt->{mail} = $maintainer || $admin;

        if ($missing_package) {
            $opt->{error} = "[MISSING] $missing_deps, needed by $missing_package to build $title, is not available on $run->{my_arch} (rebuild $missing_package?)";
        } else {
            $opt->{error} = "[MISSING] $missing_deps, needed to build $title, is not available on $run->{my_arch}";
        }
    } 
    0;
}

sub install_packages {
    my ($self, $title, $chroot_tmp, $local_spool, $log, $error, $opt, @packages) = @_;

    my $run = $self->{run};
    my $config = $self->{config};
    my $program_name = $run->{program_name};
    my $ok = 1;
    my @to_install;

    plog('DEBUG', "installing @packages");

    push @to_install, @packages;

    @to_install or return 1;

    (my $log_dirname = $title) =~ s/.*:(.*)\.src.rpm/$1/;

    my $log_spool = "$local_spool/log/$log_dirname/";

    mkdir $log_spool;

    my @rpm = grep { !/\.src\.rpm$/ } @to_install;

    if ($opt->{check}
		&& -f "$chroot_tmp/bin/rpm"
		&& @rpm
		&& are_installed($chroot_tmp, @to_install)) {
	return 1;
    }

    plog('INFO', "install dependencies using urpmi");

    my @options;
    push @options, '--buildrequires' unless @rpm;

    if (!perform_command(
	    join(' ', $self->{urpmi_command}, @options, @to_install),
	    $run, $config,
	    use_iurt_root_command => 1,
	    error => $error,
	    logname => $log,
	    hash => "${log}_$title", 
	    timeout => 3600, # [pixel] 10 minutes was not enough, 1 hour should be better
	    srpm => $title,
	    #cc => $cc, 
	    retry => 2,
	    debug_mail => $run->{debug},
	    error_regexp => 'cannot be installed',
	    wait_regexp => { 
		'database locked' => \&wait_urpmi, 
	    }, 
	    log => $log_spool,
	    callback => sub {
                my ($opt, $output) = @_;
                _install_callback($run, $config->{admin}, $opt, $output, $title);
            },
	)) {
	plog('DEBUG', "urpmi command failed.");
	if (!clean_process("$self->{urpmi_command} @to_install")) {
	    die "FATAL $program_name: Could not have urpmi working !";
	}
	$ok = 0;
    }

    if ($ok && (!@rpm || are_installed($chroot_tmp, @rpm))) {
	plog("installation successful");
	$ok = 1;
    } else {
	plog(1, "ERROR: Failed to install initial packages");
	$ok = 0;
    }

    $ok;
}

# return ("exit_code", srpm, spec)
sub recreate_srpm {
    my ($_self, $run, $config, $chroot_tmp, $dir, $srpm, $luser, $b_retry) = @_;
# recreate a new srpm for buildarch condition in the spec file
    my $program_name = $run->{program_name};
    my $with_flags = $run->{with_flags};

    plog('NOTIFY', "recreate srpm: $srpm");

    perform_command([ 
	sub { 
	    my ($s, $d) = @_; 
	    sudo($config, '--cp', $s, $d) } , [ "$dir/$srpm", "$chroot_tmp/home/$luser/rpmbuild/SRPMS/" ] ], 
	$run, $config,
	type => 'perl',
	mail => $config->{admin},
	error => "[REBUILD] cannot copy $srpm to $chroot_tmp", 
	debug_mail => $run->{debug},
	hash => "copy_$srpm") or return;

    my %opt = (mail => $config->{admin}, 
	error => "[REBUILD] cannot install $srpm in $chroot_tmp", 
 	use_iurt_root_command => 1,
	debug_mail => $run->{debug},
	hash => "install_$srpm",
	retry => $b_retry,
	callback => sub { 
	    my ($opt, $output) = @_;
	    plog('DEBUG', "calling callback for $opt->{hash}");
	    if ($output =~ /warning: (group|user) .* does not exist - using root|Header V3 DSA signature/i) {
		return 1;
	    } elsif ($output =~ /user $luser does not exist|cannot write to \%sourcedir/) {
		plog('WARN', "WARNING: chroot seems corrupted!");
		$opt->{error} = "[CHROOT] chroot is corrupted";
		$opt->{retry} ||= 1;
		return;
	    }
	    1;
	});
    plog('DEBUG', "recreating src.rpm...");
    if (!perform_command(qq(chroot $chroot_tmp su $luser -c "rpm -i /home/$luser/rpmbuild/SRPMS/$srpm"), 
	    $run, $config, %opt)) {
	plog("ERROR: chrooting failed (retry $opt{retry}") if $run->{debug};
	if ($opt{retry}) {
	    return -1;
	}
	return;
    }
    
    my $spec;
    my $oldsrpm = "$chroot_tmp/home/$luser/rpmbuild/SRPMS/$srpm";
    my $filelist = `rpm -qlp $oldsrpm`;
    my ($name) = $srpm =~ /(?:.*:)?(.*)-[^-]+-[^-]+\.src\.rpm$/;
    foreach my $file (split "\n", $filelist) {
	if ($file =~ /(.*)\.spec/) {
	    if (!$spec) {
		$spec = $file;
	    } elsif ($1 eq $name) {
		$spec = $file;
	    }
	}
    }

    # Delete old src.rpm, we will create it again
    sudo($config, '--rm', $oldsrpm) or die "$program_name: could not delete $oldsrpm ($!)";

    # 20060515 This should not be necessairy any more if urpmi *.spec works, but it doesn't
    #
    my $ret = perform_command(qq(chroot $chroot_tmp su $luser -c "rpmbuild --nodeps -bs $with_flags /home/$luser/rpmbuild/SPECS/$spec"), 
	$run, $config,
	use_iurt_root_command => 1,
	mail => $config->{admin}, 
	error => "[REBUILD] cannot create $srpm in $chroot_tmp", 
	debug_mail => $run->{debug},
	hash => "create_$srpm"
    );

    # Return if we can't regenerate srpm
    #
    return 0 unless $ret;

    if (!perform_command(qq(chroot $chroot_tmp su $luser -c "rpmspec -q --srpm /home/$luser/rpmbuild/SPECS/$spec > /home/$luser/rpmbuild/SPECS/$spec.srpm_name"), 
	    $run, $config,
	    use_iurt_root_command => 1,
	    hash => "identify_$srpm")) {
	plog("ERROR: failed to get the name of the generated src.rpm");
	return;
    }
    my $generated_srpm_name = cat_("$chroot_tmp/home/$luser/rpmbuild/SPECS/$spec.srpm_name");
    $generated_srpm_name =~ s/\s+$//;
    if (!$generated_srpm_name) {
	plog("ERROR: failed to get the name of the generated src.rpm");
	return;
    }
    my $file = "$chroot_tmp/home/$luser/rpmbuild/SRPMS/$generated_srpm_name.src.rpm";
    my ($new_srpm) = basename($file);
    my $prefix = get_package_prefix($srpm);
    my $newfile = "$chroot_tmp/home/$luser/rpmbuild/SRPMS/$prefix$new_srpm";
    if (-f $file && $newfile ne $file) {
	if (-f $newfile) {
	    sudo($config, '--rm', $newfile) or die "$program_name: could not delete $newfile ($!)";
	}
	sudo($config, '--ln', $file, $newfile) or die "$program_name: linking $file to $newfile failed ($!)";
	unlink $file;
	unlink $oldsrpm if $oldsrpm ne $newfile;
    }
    plog('NOTIFY', "new srpm: $prefix$new_srpm");
    ($ret, "$prefix$new_srpm", $spec);
}

1;