path: root/mdkupdate

#!/usr/bin/perl
################################################################################
# Mdkupdate                                                                    # 
#                                                                              #
# Copyright (C) 2002-2006 Mandriva                                             #
#                                                                              #
# Daouda Lo                                                                    #
# Thierry Vignaud <tvignaud at mandriva dot com>                               #
#                                                                              #
# This program is free software; you can redistribute it and/or modify         #
# it under the terms of the GNU General Public License Version 2 as            #
# published by the Free Software Foundation.                                   #
#                                                                              #
# 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.   #
################################################################################

# workaround standalone.pm eating "--auto" from @ARGV:
BEGIN { $::no_global_argv_parsing = 1 };

use strict;
use POSIX;
use lib qw(/usr/lib/libDrakX /usr/lib/libDrakX/drakfirsttime);
use standalone; # for explanations
use common;
use interactive;
use URI::Escape;
use run_program;

use mdkonline;
use urpm;

use Getopt::Long;

# for debug 
use Data::Dumper;

BEGIN { unshift @::textdomains, 'mdkupdate' }

require_root_capability();

my $confdir = '/root/.MdkOnline';
my $conffile = "$confdir/mdkupdate";

my $difflog = '/var/tmp/diff.log';
my $logfile = '/var/tmp/mdkupdate.log';


my $currentrpm = "$confdir/rpm_qa_installed_current";
my $afterrpm =  "$confdir/rpm_qa_installed_after";

my $startpage = 'http://start.mandriva.com/';

my $CLIENT_VERSION = "4";
my $YEARS = "2002-2006";

#for compatibilities with former versions
mkdir_p($confdir) if !-d $confdir;
-e '/root/.mdkupdate' and system "/bin/mv", "/root/.mdkupdate", $conffile;


sub usage() {
    print STDERR N("mdkupdate version %s
Copyright (C) %s Mandriva.
This is free software and may be redistributed under the terms of the GNU GPL.

usage:
", $CLIENT_VERSION, $YEARS) . N("  --help		- print this help message.
") . N("  --auto		- Mandriva Update launched automatically.
") . N("  --mnf			- launch mnf specific scripts.
") . N("  --noX			- text mode version of Mandriva Update.
") . N("  --debug			- log what is done
") . N("  --bundle file.bundle	- parse and install package from .bundle metainfo file.
");
    exit(0);
}

my ($auto, $mnf, $noX, $bundle, $debug);
my %options = (
	       'auto'	    => \$auto,
	       'mnf'	    => \$mnf,
	       'noX'	    => \$noX,
            'd|debug'   => \$debug,
	       'b|bundle:s' => sub { $bundle = $_[1] || 'webbundle' } ,
	       'h|help'    => \&usage,
	      );

GetOptions(%options);
# workaround an issue with browsers that sometimes drop the --bundle option:
$bundle = shift @ARGV if $ARGV[0] =~ /\.bundle$/;

$bundle eq "webbundle" and mdkonline::get_site($startpage), exit(0);

my $in;

$bundle || $noX and $in = interactive->vnew;

my $result;
my $wc = mdkonline::read_conf();
-e $logfile and system "/bin/rm", $logfile;

if (!$bundle) {
     my ($release) = mdkonline::get_release();
    if ($wc->{HOST_ID} && $wc->{HOST_KEY}) {
	my $getupdates;
	$getupdates = mdkonline::soap_get_updates_for_host($wc->{HOST_ID}, $wc->{HOST_KEY});

     my $ret = mdkonline::check_server_response($getupdates);
	print Data::Dumper->Dump([ $getupdates ], [ qw(getupdates) ]);
     if ($ret eq 'OK') {
         # doble check mdkapplet:
         if (my $updates = $getupdates->{data}{updates}) { # there're updates

             my %mirrors = add_mirrors($in, undef, $getupdates->{data}{mirrors}, {}, '--update');
             my $mirror = find { $_ } keys %mirrors; # pick a random mirror
             my $pkgs = [ map { $_->{filename} } @$updates ];
             print Data::Dumper->Dump([ $updates, $pkgs], [ qw(updates pkgs) ]);

	    if ($auto) { # FIXME
             my $ret = update_pkgs(@$pkgs);
             $ret == 1 or output_p($logfile, "[mdkupdate] Error 100: Packages failed to upgrade");
	    } else {
		$pkgs = ask_pkgs($in) if !$auto;
		install_pkgs($in, $pkgs, $mirror, { no_X => $noX || $auto });
		$in->exit(0);
	    }
	    rpm_qa($afterrpm);
	    my $wc = mdkonline::read_conf();
	    my $need_upload = get_rpm_diff();
	    if ($need_upload || $auto || $mnf) {
		#- send configuration and get back key to use...
		$result = mdkonline::prepare_upload_conf($wc);
	    }
	    clean_dir();
         }
     } else {
         log::explanations("geting updates failed: $ret");
     }
    } else { # no HOST_ID 
	
    }
} else {
    log::explanations("managing the $bundle bundle");
    if (-d '/live/media/loopbacks') {
        $in->ask_warn(N("Warning"),
                      #-PO: here Live Install is currently *NOT* translated on the desktop, so it's better to keep as it:
                      N("You first need to install the system on your harddrive with the 'Live Install' wizard."));
        $in->exit(1);
    }
    my $w = $in->wait_message(N("Please wait"), N("Preparing..."));
    my %bundle_vars = getVarsFromSh($bundle);
    rm_rf($bundle);
    
    my %mapping = (
        USER => 'USER_EMAIL',
        #SESSION_ID => 'HOST_KEY',
    );
    while (my ($bundle_varname, $onlinesrv_varname) = each %mapping) {
        $wc->{$onlinesrv_varname} = $bundle_vars{$bundle_varname};
    }
    if (!($wc->{HOST_ID} && $wc->{HOST_KEY})) {
        use lang;
        my $hostname = chomp_(cat_('/proc/sys/kernel/hostname'));
        my $reg_host = mdkonline::soap_register_host($bundle_vars{USER}, $bundle_vars{PASS}, $hostname, ' ', lang::read()->{country});
        my $res = mdkonline::check_server_response($reg_host);
        if ($res ne 'OK') {
            undef $w;
            $in->ask_warn(N("Error"), N("Failed to authenticate to the bundle server:\n\n%s", $reg_host->{message}));
            exit(3);
        }
        # we've no previous config so write one so that write_wide_conf() do not miss some fields:
        setVarsInSh('/etc/sysconfig/mdkonline', {
            USER_EMAIL => $bundle_vars{USER},
            HOST_NAME => $hostname,
        });
        mdkonline::write_wide_conf($reg_host);
    }

    $wc = mdkonline::read_conf();
    $wc->{USER_EMAIL} or die("Configuration not uploaded to Mandriva Online");
    
    my $res = mdkonline::prepare_upload_conf($wc);
    if ($res ne 'OK') {
        undef $w;
        log::explanations("we failed to be accepted by the server: $res");
        $in->ask_warn(N("Error"), N("An error occurred") . "\n\n" . $res);
    }
    
    if ($bundle_vars{CLIENT_VERSION} > $CLIENT_VERSION) {
        log::explanations("the client is too old in order to install the bundle $bundle_vars{BUNDLE}");
        $in->ask_warn(N("Warning"), N("The version of the Mandriva Online client is too old.

You need to update to a newer version. You can get a new one from http://start.mandriva.com"));
        $in->exit(1);
    }
    my $bundle_info = mdkonline::soap_query_bundle($wc, $bundle_vars{BUNDLE});
    $res = mdkonline::check_server_response($bundle_info);
    print Data::Dumper->Dump([ $bundle_info ], [ qw(bundle_info) ]);
    if ($res eq 'OK') {
	my @bundles;
	$w = $in->wait_message(N("Please wait"), N("Preparing..."));
	my ($mirrors, $bundle) = ($bundle_info->{data}{mirrors}, $bundle_info->{data}{bundle});
	$bundle =~ s/-[^-]*-[^-]*\.[^.]*\.rpm$//;
	push @bundles, $bundle;
     my %mirrors = add_mirrors($in, $w, $mirrors, \%bundle_vars);
     undef $w;
	install_pkgs($in, \@bundles, (find { /^bundle/ } keys %mirrors),
                  { is_bundle => 1,
                    auto_select => ($bundle_vars{POST} =~ /AUTO_SELECT/ ? 1 : 0),
                    medias => [ keys %mirrors ],
                });
    } else {
        undef $w;
        log::explanations("we did not got back a bundle: $bundle_info->{message}");
        $in->ask_warn(N("Error"), N("An error occurred") . "\n\n" . $res . "\n\n" . $bundle_info->{message});
    }
}

sub add_mirrors {
    my ($in, $w, $mirrors, $bundle_vars, $option) = @_;
    foreach my $mirror (@$mirrors) {
        next if $mirror->{mode} eq 'anon'; # nothing to do
        if ($mirror->{mode} eq 'auth') {
            # add "user:pass@" substring if needed:
            # user password & login provided by server on those provided with the bundle:
            $bundle_vars->{USER} = $mirror->{user} if $mirror->{user};
            $bundle_vars->{PASS} = $mirror->{pass} if $mirror->{pass};
            my $encoded_login = uri_escape($bundle_vars->{USER});
            my $encoded_pass = uri_escape($bundle_vars->{PASS});
            $mirror->{url} =~ s!^([^:]*)://!\1://$encoded_login:$encoded_pass@!;
        } else { # unknown method, aborting
             undef $w;
             log::explanations("we got a bad bundle");
             $in->ask_warn(N("Error"), N("This bundle is not well formated. Aborting."));
             $in->exit(1);
         } 
    }
    my %mirrors = map { $_->{name} => join('@', grep { $_ } $_->{auth}, $_->{url}) } @$mirrors;
    add_media($_, $mirrors{$_}, 'media_info/synthesis.hdlist.cz', $option) foreach keys %mirrors;
    %mirrors;
}

sub ask_pkgs {
    my ($in) = @_;
    my $pkgs = get_updatable_pkgs();
    $in->ask_browse_tree_info('Mdkupdate', N("Choose which packages should be installed and Press Ok"),
			      {
			       node_state => sub { $pkgs->{$_[0]}{selected} ? 'selected' : 'unselected' },
			       build_tree => sub {
				   my ($add_node, $_flat) = @_;
				   $add_node->($_, undef) foreach sort keys %$pkgs;
			       },
			       grep_unselected => sub { grep { !$pkgs->{$_}{selected} } @_ },
			       toggle_nodes => sub {
				   my ($set_state, @nodes) = @_;
				   my $new_state = !$pkgs->{$nodes[0]}{selected};
				   foreach (@nodes) {
				       $set_state->($_, $new_state ? 'selected' : 'unselected');
				       $pkgs->{$_}{selected} = $new_state;
				   }
			       },
			       get_info => sub {},
			      }) or return keys %$pkgs; #- no change on cancel.
    [ grep { $pkgs->{$_}{selected} } keys %$pkgs ];
}

sub install_pkgs {
    my ($in, $choosed, $media_name, $o_options) = @_;
    $o_options ||= {};
    my $w = $in->wait_message(N("Please wait"), N("Installing packages ...\n")) if !$o_options->{is_bundle};
    my $program = $o_options->{no_X} ? '/usr/sbin/urpmi' : '/usr/bin/gurpmi';
    eval {
        if (!$o_options->{is_bundle}) {
            log::explanations("applying the updates");
            system $program, "--auto", "--media", $media_name, @$choosed;
        } else {
            log::explanations("installing the bundle");
            system $program, '--auto', if_($o_options->{auto_select}, "--auto-select"),
              if_($o_options->{medias}, "--media", join(',', @{$o_options->{medias}})),
                "--searchmedia", $media_name, @$choosed;
        }
	$? == 0 or die N("Unable to update packages from update_source medium.\n");
    };
    undef $w;
}

sub get_updatable_pkgs() {
    my $urpm = new urpm;
    $urpm->read_config;
    my %installable_pkgs; my @update_medias;
    my ($medium) = grep { $_->{name} eq "update_source" } @{$urpm->{media}};
    
    if ($medium) {
	$urpm->configure(media => $medium->{name});
	@update_medias = grep { !$_->{ignore} && $_->{update} } @{$urpm->{media}};
	$urpm->compute_installed_flags(URPM::DB::open);
	foreach my $pkg (@{$urpm->{depslist}}) {
	    $pkg->flag_upgrade or next;
	    my $selected = 0;
	    $pkg->flag_installed or next;
	    any { $pkg->id >= $_->{start} && $pkg->id <= $_->{end} } @update_medias or next;
	    $selected = member($pkg->name, qw(perl-URPM, urpmi, mdkonline, drakxtools)) ? 1 : 0;
	    $installable_pkgs{my_fullname($pkg)} = { selected => $selected, pkg => $pkg };
	}
    }
    \%installable_pkgs;
}

sub my_fullname {
    return '?-?-?' unless ref $_[0];
    my ($name, $version, $release) = $_[0]->fullname;
    "$name-$version-$release";
}

sub add_media {
    my ($media_name, $mirror, $hdlist, $option) = @_;
    log::explanations("removing/adding the media $media_name");
    eval { 
	system "/usr/sbin/urpmi.removemedia", $media_name;
	# use curl because wget sometime fail on https url
	system "/usr/sbin/urpmi.addmedia", if_($option, $option), '--curl', $media_name, $mirror, "with", $hdlist;
    };
    $@ and die "Problem adding bundle media with urpmi";
}

sub prepare_media {
    my $mirror = shift;
    my ($r, $da, $is_x8664, $dist_name);
    ($r) = mdkonline::get_release();
    # retrieve dist and arch from /etc/mandrakelinux file
    $da = mdkonline::get_distro_type();
    my ($path2new_arch, $path2new_synthesis) = $r <= 10.0 ? ('/RPMS/', '../base/synthesis.hdlist.cz') : ('/main_updates/', 'media_info/synthesis.hdlist.cz');
    #sometimes server returns the full link http:// or ftp://
    ($is_x8664) = $da->{arch} =~ /(x86_64)/;
    $dist_name = $da->{name};
    my $fullpath2mir = if_($mirror !~ m!^(?:http|ftp)://! , "ftp://") . $mirror . if_($is_x8664, "/$is_x8664") . if_($dist_name, "/$dist_name") . "/$r" . $path2new_arch;
    add_media('update_source', $fullpath2mir, $path2new_synthesis, '--update');
}

sub update_pkgs {
    my (@pkgs) = @_;
    eval {
	system "/usr/sbin/urpmi", '--auto-update', '--update', map { if_(/(.*)-[^-]*-[^-]*\.[^-.]*?\.rpm$/, $1) } @pkgs;
	$? == 0 or die N("Unable to update packages from update_source medium.\n");
    };
    $@ and output_p($logfile, "[mdkupdate] Error 99: $@"), return 0;
    return 1;
}

sub get_rpm_diff() {
    my $isdif = `sdiff -s $afterrpm $currentrpm`;
    $isdif and output_p($difflog, $isdif), return 1;
    return 0;
}

sub new_rpm_base() {
    -f $afterrpm and system('/bin/mv', $afterrpm, $currentrpm);
}

sub clean_dir() {
    new_rpm_base();
    mdkonline::clean_confdir();
    output_p($logfile, 'OK');
}

sub rpm_qa {
    my ($file) = @_;
    output($file, chomp_(join('', sort(`rpm -qa`))));
}