#!/usr/bin/perl

use strict;
use warnings;

use Dpkg::Version;
use Cwd;
use File::Copy;
use Archive::Tar;
use File::Slurp;
use Text::Patch;
use IPC::Run qw( run );
use Getopt::Long;
use List::MoreUtils qw(uniq);

my %packages;
my %versions;
my %available;
my %ignored;
my %notest;
my %binary;
my %obsolete;
my %avoid;
my %ghcpkg;
my %flags;
my %group;
my %meta;
my %ahead;
my %behind;
my %key;

my $allow_upgrade = 0;
my $assume_lts = 0;
my $only_key_packages = 0;

my $error_count = 0;
my %stats;

GetOptions (
	"allow-upgrade" => \$allow_upgrade,
	"assume-lts" => \$assume_lts,
	"only-key-packages" => \$only_key_packages,
	) or die("Error in command line arguments\n");

print "Reading packages.txt...\n";
open PACKAGES, "<", "packages.txt" or die $!;
while (<PACKAGES>) {
	chomp;
	next if /^#/;
	next if /^\s*$/;
	unless (m/^(.*?) (.*?)(?: ([^#]*))?(?:#.*)?$/) {
		print "Ignoring unparseable line $.: $_\n";
	}
	my ($pkg,$version,$attribs) = ($1,$2,$3);
	$packages{$pkg}++;

	$attribs ||= '';

	$group{$pkg} = $1 if $attribs =~ s/group=([a-z0-9-]+)\s*//;
	$binary{$pkg} = $1 if $attribs =~ s/binary=([a-z0-9-]+)\s*//;
	$binary{$pkg} = $pkg if $attribs =~ s/binary\s*//;

	if ($attribs =~ s/obsolete\s*//) {
		$obsolete{$pkg}++;
		next;
	}
	if ($attribs =~ s/avoid\s*//) {
		$avoid{$pkg}++;
		next;
	}
	$versions{$pkg} = $version;
	$ignored{$pkg}++ if $attribs =~ s/ignored?\s*//;
	$notest{$pkg}++ if $attribs =~ s/notest\s*//;
	$ghcpkg{$pkg}++ if $attribs =~ s/ghcpkg\s*//;
	$meta{$pkg}++ if $attribs =~ s/meta\s*//;
	$ahead{$pkg}++ if $attribs =~ s/ahead\s*//;
	$behind{$pkg}++ if $attribs =~ s/behind\s*//;
	$key{$pkg}++ if $attribs =~ s/key\s*//;
	$flags{$pkg} = [] unless exists $flags{$pkg};
	push @{$flags{$pkg}}, $1 while $attribs =~ s/-f([^ ]+)\s*//;

	if ($attribs) {
		warn "Unknown attributs for $pkg: $attribs\n"
	}
}
close PACKAGES;

my %lts;
print "Reading lts.config...\n";
open LTS, "<", "lts.config" or die $!;
while (<LTS>) {
     chomp;
     next if /^#/;
     next if /^--/;
     next if /^\s*$/;
     next if /^with-compiler:/;
     next if /installed,?$/;
     unless (m/^(?:constraints:)?\s+(.*?) ==(.*?),?$/) {
             print "Ignoring unparseable line $.: $_\n";
     }
     my ($pkg,$version) = ($1,$2);
     $lts{$pkg} = $version;
}
close LTS;


print "Reading available versions...\n";
open AVAILABLE, "-|", "apt-cache dumpavail | grep-dctrl -F GHC-Package -r . -s GHC-Package -n" or die $!;
while (<AVAILABLE>) {
	chomp;
	unless (m/^(.*)-([0-9\.]*)-([A-Za-z0-9]*?)$/) {
		print "Ignoring unparseable grep-aptavail output line $.: $_\n";
		$error_count++;
	}
	my ($pkg,$version) = ($1, $2);
	$version = 0.85 if $pkg eq "IfElse" and $version eq "0.85.0.0.1"; # anomaly
	unless (exists ($available{$pkg}) and version_compare($version, $available{$pkg}) == -1) {
		$available{$pkg} = $version;
		$packages{$pkg}++;
	}
}
close AVAILABLE;

print "Reading available binary versions...\n";
my %binavail;
{
	my $pkg;
	open VERS, "-|", "apt-cache dumpavail | grep-dctrl -s Package,Version -n ." or die $!;
	while (<VERS>) {
		chomp;
		if ($_ eq '') {
			undef $pkg;
			next;
		}
		unless (defined $pkg) {
			$pkg = $_;
			$binavail{$pkg} = [] unless (exists $binavail{$pkg});
			next;
		}
		unless (m/^(?:.*:)?(.*?)(?:-(?:.*))?$/) {
			print "Ignoring unparseable version for $pkg: $_\n";
			$error_count++;
		}
		my $version = $1;
		if ($pkg eq "pandoc-citeproc-preamble" and $version =~ s/\+b\d+//) {
			print "WARNING: $pkg has a native version number for some reason\n";
		}
		push @{$binavail{$pkg}}, $version;
	}
	close VERS;
}

print "Calculating availability...\n";

while ( my ($pkg, $bin) = each %binary ) {
	foreach my $version (@{$binavail{$bin} or []}) {
		unless (exists ($available{$pkg}) and version_compare($version, $available{$pkg}) == -1) {
			$available{$pkg} = $version;
			$packages{$pkg}++;
		}
	}

}


print "Checking for outdated entries...\n";
for my $pkg (sort keys %packages) {
	if ($meta{$pkg}) {
		# do nothing
	} elsif ($obsolete{$pkg} && $available{$pkg}) {
		printf "Obsolete: %s %s\n" ,
			$pkg, $available{$pkg};
		$stats{obsolete}++;
	} elsif ($obsolete{$pkg} && !$available{$pkg}) {
		printf "REMOVED:  %s\n" ,
			$pkg;
		$error_count++;
		$stats{REMOVED}++;
	} elsif ($avoid{$pkg}) {
		# do nothing
	} elsif ($ignored{$pkg}) {
		# do nothing
	} elsif (! exists($versions{$pkg})) {
		printf "MISSING:  %s %s\n" ,
			$pkg, $available{$pkg};
		$error_count++;
		$stats{MISSING}++;
	} elsif (! exists($available{$pkg})) {
		printf "Added:    %s is %s here but does not exist in the archive.\n" ,
			$pkg, $versions{$pkg};
		$stats{Added}++;
	} elsif ( version_compare($versions{$pkg}, $available{$pkg}) == -1 ) {
		printf "OLD:      %s is %s here but %s exists in the archive.\n" ,
			$pkg, $versions{$pkg}, $available{$pkg};
		$error_count++;
		$stats{OLD}++;
	} elsif ( version_compare($versions{$pkg}, $available{$pkg}) == 1 ) {
		printf "Updated:  %s is %s in the archive but %s exists here.\n" ,
			$pkg, $available{$pkg}, $versions{$pkg};
		$stats{Updated}++;
	}

	if ( exists $lts{$pkg} and exists $versions{$pkg} ) {
		my $cmp = version_compare($versions{$pkg}, $lts{$pkg});
		if ( $cmp == 1 ) {
			if ( exists $ahead{$pkg} ) {
				# printf "Ahead:    %s is %s here, but only %s in the tracked LTS release (expected).\n" ,
				#	$pkg, $available{$pkg}, $lts{$pkg};
				$stats{"known-ahead"}++;
			} else {
				printf "AHEAD:    %s is %s here, but only %s in the tracked LTS release.\n" ,
					$pkg, $versions{$pkg}, $lts{$pkg};
				$stats{AHEAD}++;
				$error_count++;
			}
		} else {
			if ( exists $ahead{$pkg} ) {
				printf "NOT AHEAD:%s is (no longer) ahead of the LTS release, remove marker!\n", $pkg;
				$error_count++;
			}
		}

		if ( $cmp == -1 ) {
			if ( exists $behind{$pkg} ) {
				$stats{"known-behind"}++;
			} else {
				printf "BEHIND:   %s is %s here, %s in the archive, but already %s in the tracked LTS release.\n" ,
					$pkg, $versions{$pkg}, ($available{$pkg} or "MISSING"), $lts{$pkg};
				$stats{"lts-upgradeable"}++;
				$error_count++;
			}
		} else {
			if ( exists $behind{$pkg} ) {
				printf "NOTBEHIND:%s is (no longer) behind of the LTS release, remove marker!\n", $pkg;
				$error_count++;
			}
		}
	}
}

my $sandboxdir = cwd() . "/cabal-sandbox";
my $cabaldir = defined $ENV{CABAL_DIR} ? $ENV{CABAL_DIR} : $ENV{HOME}."/.cabal";
my $originaltarpath = "$cabaldir/packages/hackage.haskell.org/01-index.tar";
my $tarpath = "$sandboxdir/packages/debian/00-index.tar";
my $dbpath = "$sandboxdir/db";
my $createsandbox = 0;
if (-e $tarpath) {
	$createsandbox++ if (-M $originaltarpath < -M $tarpath);
	$createsandbox++ if (-M "./patches" < -M $tarpath);
	for my $patchfile (<./patches/*/*/*>) {
		$createsandbox++ if (-M $patchfile < -M $tarpath);
	}
	for my $cabalfile (<./additional-cabals/*.cabal>) {
		$createsandbox++ if (-M $cabalfile < -M $tarpath);
	}
} else {
	$createsandbox++;
}


if ($createsandbox) {
	print "(Re-)Creating local hackage \"repository\"...\n";
	system("rm","-rf",$sandboxdir);
	mkdir "$sandboxdir" or die $!;
	mkdir "$sandboxdir/packages" or die $!;
	mkdir "$sandboxdir/packages/debian" or die $!;
	open CABALCONFIG, ">", "cabal-sandbox/config" or die $!;
	print CABALCONFIG <<__END__;
remote-repo: debian:http://does-not-exist.example/packages/archive
remote-repo-cache: $sandboxdir/packages
world-file: $sandboxdir/world
install-dirs user
  prefix: /does-not-exist

install-dirs global
  prefix: /does-not-exist
__END__

	close CABALCONFIG or die $!;

	print "Reading 01-index.tar...\n";
	my $tar = Archive::Tar->new($originaltarpath);
	print "Removing package.json files...\n";
	my @allfiles = $tar->get_files();
	$tar->remove (grep /package\.json$/, @allfiles);
	print "Adding additional packages...\n";
	for my $cabalfile (<./additional-cabals/*.cabal>) {
		unless ($cabalfile =~ m!^./additional-cabals/(.*)-(.*).cabal!) {
		        printf "Ignoring $cabalfile, does not match not match naming scheme additional-cabals/<pkg>-<version>.cabal";
			$error_count++;
			next
		}
		my $package = $1;
		my $version = $2;

		my $content = read_file($cabalfile);
		my $filename = "$package/$version/$package.cabal";
		if ($tar->contains_file($filename)) {
			printf "Replacing %s\n", $filename;
			$tar->replace_content($filename, $content);
		} else {
			printf "Adding %s\n", $filename;
			$tar->add_data($filename, $content);
		}
	}

	print "Applying patches to repository .cabal files...\n";
	for my $seriesfile (<./patches/*/*/series>) {
		unless ($seriesfile =~ m!^./patches/(.*)/(.*?)/series$!) {
			printf "Ignoring $seriesfile, does not match naming scheme patches/<pkg>/<version>/series\n";
			$error_count++;
			next
	        }
		my $pkg = $1;
		my $version = $2;
		unless (exists $versions{$pkg} || exists $obsolete{$pkg}) {
			printf "Ignoring patches for %s-%s, not listed in packages.txt\n", $pkg ,$version;
			$error_count++;
			next
		}
		unless (exists $versions{$pkg} and $version eq $versions{$pkg}
		     or exists $lts{$pkg} and $version eq $lts{$pkg}) {
			# printf "Ignoring patches for %s-%s, version does not match %s in packages.txt\n", $pkg ,$version, $versions{$pkg};
			next
		}
		my $cabalpath = sprintf "%s/%s/%s.cabal", $pkg, $version, $pkg;
		unless ($tar->contains_file($cabalpath)) {
			printf "File %s not found in 00-index.tar\n", $cabalpath;
			$error_count++;
			next
		}

		printf "Patching %s.cabal (version %s)\n", $pkg, $version;
		my $content = $tar->get_content($cabalpath);
		my $series = read_file($seriesfile);
		foreach my $patchfile (split /^/, $series) {
			chomp $patchfile;
			my $patch;
			run ["filterdiff", "-i", "*.cabal",
				"patches/$pkg/$version/$patchfile"], \"", \$patch;
			if ($patch) {
				$patch =~ s/\r//g;
				$content =~ s/\r//g;
				$content = patch($content, $patch, STYLE => "Unified");
			} else {
				#print "Ignoring $patchfile\n";
			}
		};
		$tar->replace_content($cabalpath, $content) or die;
		$stats{patched}++;
	}
	print "Writing 00-index.tar...\n";
	$tar->write($tarpath);
}

print "Creating fake global package db\n";
system("rm","-rf",$dbpath);
mkdir "$dbpath" or die $!;
open GHCFILES, "-|", "dpkg-query -L ghc" or die $!;
while (<GHCFILES>) {
	chomp;
	if (m!^/var/lib/ghc/package.conf.d/(.*\.conf)$!) {
		symlink $_, "$dbpath/$1" or die $!;
	}
}
close GHCFILES;
system("ghc-pkg","--package-db=$dbpath","recache");

unlink "all-packages.cabal";


my %groups;
$groups{$_}++ foreach values %group;
$groups{default}++;
my @groups = keys %groups;
printf "Testing packages in %d different groups\n", (scalar @groups);

my $total_out;
my $all_runs_ok = 1;

for my $group (sort @groups) {
	my @params = ("cabal",
		 #"-v",
		 "--config-file",
		 "$sandboxdir/config",
		 "--ghc-pkg-option=--global-package-db=$dbpath",
		 "--global",
		 "v1-install",
		 "--dry-run",
		 "--force-reinstall",
		 "--max-backjumps",
		 "10000");

	for my $pkg (sort keys %flags) {
		for my $flag (@{$flags{$pkg}}) {
			push @params, "--constraint", sprintf "%s %s", $pkg, $flag;
		}
	}

	for my $pkg (sort keys %obsolete) {
		push @params, "--constraint", sprintf "%s (== 42.23.1.2)", $pkg;
	}
	for my $pkg (sort keys %avoid) {
		push @params, "--constraint", sprintf "%s (== 42.23.1.2)", $pkg;
	}

	# GHC pkgs: constrain to installed unless in a specific group
	for my $pkg (sort keys %ghcpkg) {
		if (defined $group{$pkg} and $group{$pkg} ne $group) {
			push @params, "--constraint", sprintf "%s installed", $pkg;
		}
	}

	for my $pkg (sort keys %versions) {
		next if (exists $ignored{$pkg});

		# If checking the default group, prohibit all packages from other groups
		# For other groups, allow packages from the default group
		if ($group eq "default" and defined $group{$pkg}
		 or $group ne "default" and defined $group{$pkg} and $group{$pkg} ne $group) {
			if (not exists $ghcpkg{$pkg}) {
				push @params, "--constraint", sprintf "%s (== 42.23.1.2)", $pkg;
			}
		} elsif ($assume_lts and not exists $ahead{$pkg} and not exists $behind{$pkg} and exists $lts{$pkg}) {
			push @params, "--constraint", sprintf "%s (== %s)", $pkg, $lts{$pkg};
		} elsif ($allow_upgrade) {
			push @params, "--constraint", sprintf "%s (>= %s)", $pkg, $versions{$pkg};
			push @params, "--preference", sprintf "%s (== %s)", $pkg, $versions{$pkg};
		} else {
			push @params, "--constraint", sprintf "%s (== %s)", $pkg, $versions{$pkg};
		}
	}
	for my $pkg (sort keys %versions) {
		next if (exists $ignored{$pkg});
		next if (exists $obsolete{$pkg});
		next if (exists $avoid{$pkg});
		next if (($group{$pkg} || 'default') ne $group);
		next if ($only_key_packages and (not (exists $lts{$pkg} or exists $key{$pkg})));
		push @params, sprintf "%s", $pkg;
		unless (exists $notest{$pkg}) {
			push @params, "--constraint", sprintf "%s test", $pkg;
		}
	}

	printf "Running cabal-install (group %s)...\n", $group;
	#printf join(" ", @params)."\n";

	write_file(sprintf("cabal-cmd-%s.sh", $group), join(" ", map ("'$_'", @params)));


	my $out;
	my $err;
	if (run \@params, \"", \$out, \$err) {
		$total_out .= $out;
	} else {
		print "Cabal install failed:\n";
		$error_count++;
		$all_runs_ok = 0;
		print $err;
	}
}
write_file("cabal-cmd.out", $total_out);

my %results;
my %upgradeable;

if ($all_runs_ok) {
	for (split /\n/, $total_out) {
		next if $_ eq "Reading available packages...";
		next if $_ eq "Choosing modular solver.";
		next if $_ eq "Resolving dependencies...";
		next if $_ eq "Updating the index cache file...";
		next if $_ =~ "In order, the following would be installed";
		next if $_ eq "package)"; # what is that?
		if (m!^([a-zA-Z0-9-]+)-([0-9.]+)!gm) {
			my ($pkg, $version) = ($1, $2);
			if (exists $results{$pkg} and $results{$pkg} ne $version) {
				printf "ERROR: Different groups yield different results for %s: %s vs. %s\n", $pkg, $version, $results{$pkg};
			} else {
				$results{$pkg} = $version;
			}

			if (m!latest:!) {
				$upgradeable{$pkg}++;
				#if (! exists $lts{$pkg}) {
				#	printf "NOTE: non-lts package %s can be updated\n", $pkg;
				#}
			}
		} else {
			print STDERR "Unparseable line in cabal install output: $_\n";
		}
	}

	my $count=0;
	while ( my ($pkg, $version) = each %results ) {
		unless (exists $versions{$pkg}) {
			printf "ERROR: Additional dependency pulled in: %s-%s\n", $pkg, $version;
			$error_count++;
			$stats{MISSING_DEP}++;
			next
		}
		unless ($versions{$pkg} eq $version) {
			if ($ignored{$pkg}) {
			} elsif ($allow_upgrade) {
				printf "Upgrading %s: %s -> %s\n", $pkg, $versions{$pkg}, $version;
			} else {
				printf "ERROR: %s has %s but should have %s\n", $pkg, $version, $versions{$pkg};
				$error_count++;
			}
			next
		}
		$count++;
	}

	for my $pkg ( sort keys %versions ) {
		next if (exists $ignored{$pkg});
		next if (exists $obsolete{$pkg});
		next if (exists $avoid{$pkg});
		next if (exists $ghcpkg{$pkg});

		next if (exists $results{$pkg});
		printf "ERROR: Package missing in package plan %s\n", $pkg;
		$error_count++;
	}

	printf "%d packages successfully tested for co-installability.\n", $count;
	$stats{total} = $count;
	printf "%d packages carry Debian-specific patches.\n", $stats{patched} if $createsandbox;
	printf "%d packages have newer versions on hackage\n", scalar (keys %upgradeable);
	$stats{upgradeable} = scalar (keys %upgradeable);
	unless ($count) {
		printf "Really no packages? output was:\n$total_out";
	}
}

open STATS, ">", "stats.csv" or die $!;
print STATS (join ",",sort keys %stats), "\n";
print STATS (join ",",map {$stats{$_}} sort keys %stats), "\n";
close STATS;

if ($error_count) {
	printf "%d error(s) in total.\n", $error_count;
	exit 1;
}