#! /usr/bin/env perl
#
# plan-downgrade.pl - Tool to find dependencies of package downgrade
# Copyright (C) 2011 Tommi Saviranta  <wnd@iki.fi>
#
# 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 3 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>.
#
#
# This script depends on the following packages:
#   - libapt-pkg-perl   (developed with 0.1.25)
#   - libwww-curl-perl  (developed with 4.15-1+b1)
#
#
# Version history:
#    1   5 Oct 2011 - Initial version
#    2   6 Oct 2011 - Script can now find Debian snapshot archive timestamps


use strict;
use warnings FATAL => 'all';
use IO::Handle;
use Getopt::Long;

use AptPkg::Config '$_config';
use AptPkg::System '$_system';
use AptPkg::Cache;


sub fetch($$) {
	use WWW::Curl::Easy;

	my $curl = shift;
	my $url = shift;

	$curl->setopt(CURLOPT_HEADER, 1);
	$curl->setopt(CURLOPT_URL, $url);
	my $response;
	$curl->setopt(CURLOPT_WRITEDATA, \$response);

	my $retcode = $curl->perform;
	if ($retcode == 0 && $curl->getinfo(CURLINFO_HTTP_CODE) == 200) {
		return $response;
	} else {
		print STDERR "Snapshot server returned error: " .
				$curl->strerror($retcode) .
				" " . $curl->errbuf . "\n";
		return undef;
	}
}


sub list_versions($$) {
	my ($data, $show) = @_;
	my (%link, %version);
	my $n = 1;

	foreach my $html_raw ($data =~ /<li>(.*?)<\/li>/gi) {
		my ($link, $ver) = $html_raw =~ /<a href="(.*?)">(.*?) /;
		$link{$n} = $link;
		$link{$ver} = $link;
		$version{$n} = $ver;
		$version{$ver} = $ver;
		($show) && printf "%3d: %s\n", $n, $ver;
		$n++;
	}

	return (\%link, \%version);
}


sub show_and_select_version($$$) {
	my ($data, $pkgname, $pkgver) = @_;
	my $link;

	if ($pkgver) {
		my ($r0, $r1) = list_versions($data, 0);
		my %link = %{$r0};
		$link = $link{$pkgver};
		unless ($link) {
			print STDERR "$pkgname=$pkgver is not available!\n";
		}
	}

	if (! $link) {
		print "\nAvailable versions:\n";
		my ($r0, $r1) = list_versions($data, 1);
		my %link = %{$r0};
		my %version = %{$r1};
		print "\n";

		while (! $link) {
			print "Which version? ";
			STDOUT->flush();
			my $i = <STDIN>;
			chomp $i;
			$link = $link{$i};
			$pkgver = $version{$i};
		}
	}

	return ($link, $pkgver);
}


sub find_timestamp($$$) {
	my ($data, $pkgname, $arch) = @_;

	foreach my $farch ($arch, "all") {
		my ($ts) = $data =~
		/href=".*?\/([0-9TZ]+)\/pool.*\/${pkgname}_.*?_${farch}.deb/i;
		defined($ts) && return $ts;
	}
	return undef;
}



(my $self = $0) =~ s#.*/##;

my %process_list = ( "Installed" => 1, "UnPacked" => 1,
	"HalfConfigured" => 1, "HalfInstalled" => 1 );

my $arch;
my $allow_upgrade = 0;
my $find_snapshots = 0;
my $help = 0;
my $getopt_result = GetOptions(
	"allow-upgrade" => \$allow_upgrade,
	"find-snapshots" => \$find_snapshots,
	"arch=s" => \$arch,
	"help" => \$help);
if ($help or $#ARGV == -1) {
	print <<EOF;
Usage: $self [options] PKGNAME=VERSION ...
Usage: $self --find-snapshots PKGNAME[=VERSION] ...

Find dependencies to satisfy downgrade of given packages.

Options:
  --allow-upgrade	Allow upgrading some packages. Upgrade may take place
			even when it is not required for downgrade of given
			packages.
  --find-snapshots	Find available snapshots for packages.
  --arch=s		Use architecture other than system architecture.
EOF
	exit(0);
}


if ($find_snapshots) {
	use WWW::Curl::Easy;

	if (! defined($arch)) {
		open(PIPE, "dpkg-architecture -qDEB_HOST_ARCH |");
		$arch = <PIPE>;
		close(PIPE);
		chomp $arch;
		print STDERR "Using architecture: $arch\n";
	}

	my %timestamps;
	my %missing;

	my $curl = WWW::Curl::Easy->new;
	foreach my $pkgname_raw (@ARGV) {
		my ($pkgname, $pkgver) = split(/=/, $pkgname_raw);
		print "\nPackage: $pkgname\n";
		my $url = "http://snapshot.debian.org/binary/$pkgname/";

		print STDERR "Retrieving available versions for $pkgname...\n";
		my $ver_data = fetch($curl, $url);
		next unless ($ver_data);

		my $link;
		while (1) {
			($link, $pkgver) = show_and_select_version(
					$ver_data, $pkgname, $pkgver);

			print STDERR "Retrieving timestamps " .
					"for $pkgname=$pkgver...\n";
			my $ts_data = fetch($curl, $url . $link);
			next unless ($ts_data);

			my $timestamp = find_timestamp($ts_data, $pkgname,
					$arch);
			if ($timestamp) {
				$timestamps{$timestamp} = 1;
				last;
			} else {
				print STDERR "No timestamp found for " .
						"$pkgname=$pkgver!\n";
				print "Try another version [Y|n]? ";
				STDOUT->flush();
				my $i = <STDIN>;
				chomp $i;
				if ($i =~ /^n/i) {
					$missing{$pkgname} = 1;
					last;
				}
			}
		}
	}

	my @timestamps = keys %timestamps;
	if ($#timestamps >= 0) {
		print "\n";
		print "Snapshot repositories:\n";
		foreach my $ts (@timestamps) {
			print "$ts  http://snapshot.debian.org/" .
					"archive/debian/$ts/\n";
		}
	}
	my @missing = keys %missing;
	if ($#missing >= 0) {
		print "\n";
		print "Missing packages:\n";
		foreach my $pkg (@missing) {
			print "\t$pkg\n";
		}
	}
	exit(0);
}


$_system = $_config->system;

my $cache = AptPkg::Cache->new();
my $version = $_system->versioning;


my @plan_pkg;
my %inst_pkg;

push(@plan_pkg, @ARGV);


while ($#plan_pkg >= 0) {
	my $pkgname_raw = shift(@plan_pkg);

	my ($pkgname, $pkgver) = split(/=/, $pkgname_raw);
	print STDERR "Investigating $pkgname_raw...\n";
	flush STDERR;
	my $pkg = $cache->{$pkgname};
	unless ($pkg) {
		warn "$pkgname not known\n";
		next;
	}

	my $ver_avail = $pkg->{VersionList};
	unless ($ver_avail) {
		warn "$pkgname has no versions available\n";
		next;
	}

	my $ver_found = 0;
	for my $ver (@$ver_avail) {
		if ($ver->{VerStr} eq $pkgver) {
			$ver_found = 1;
			last;
		}
	}
	unless ($ver_found) {
		warn "$pkgname has no version $pkgver available\n";
		next;
	}
	$inst_pkg{$pkgname} = $pkgver;

	my $rdeps = $pkg->{RevDependsList};
	next unless ($rdeps);

	for my $rdep (@$rdeps) {
		my $rdep_pkgname = $rdep->{ParentPkg}{Name};
		my $rdep_pkg = $cache->{$rdep_pkgname};
		next unless ($process_list{$rdep_pkg->{CurrentState}});
		next unless ($rdep->{TargetVer});

		if ($rdep->{DepType} eq "Depends") {
			my $rdep_ver = $rdep->{ParentVer}{VerStr};
			next if ($rdep_pkg->{CurrentVer} and ! $allow_upgrade
					and $version->check_dep(
						$rdep_pkg->{CurrentVer}{VerStr},
						"<<", $rdep_ver));
			next unless ($version->check_dep($pkgver,
					$rdep->{CompTypeDeb},
					$rdep->{TargetVer}));
			my $queued = $inst_pkg{$rdep_pkgname};
			next unless (! defined($queued) or $version->check_dep(
					$queued, "<<", $rdep_ver));

			$inst_pkg{$rdep_pkgname} = $rdep_ver;
			push(@plan_pkg, "$rdep_pkgname=$rdep_ver");
		}
	}
}


while (my ($name, $ver) = each %inst_pkg) {
	print "$name=$ver ";
}
print "\n";