#!/usr/bin/perl

# Copyright (C) 2012 STRATO.  All rights reserved.
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public
# License v2 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 021110-1307, USA.

use strict;
use warnings;
use Getopt::Std;
use Time::HiRes qw(time);
use IPC::Open3;
use Symbol qw(gensym);

my @fs = qw(btrfs zfs);
my %opts = ();
my $ssh_chld = 0;

sub usage {
	print STDERR <<EO_USAGE;
$0 -s source -d destination [...]
  -d  destination type:device (required; always local)
  -f  fuzz testing (number of tests, run after -t tests. -1: infinite)
  -F  single fuzz test with seed
  -k  keep temporary files
  -p  pedanctic mode (stop on error)
  -q  quiet
  -r  remote host (needs ssh root login)
  -s  source type:device (required; remote with -r, otherwise local)
  -t  test spec (e.g. "1,2,3", "1-3,6:1,7:2-4,8-12")
  -v  verbose
type must be one of: @fs
EO_USAGE
	exit(shift);
}

sub out {
	print @_ if !$opts{q};
}

sub verbose {
	print @_ if $opts{v};
}

sub do_local {
	my @out = capture_local(@_);
	print map {"$_\n"} @out if $opts{v};
}

my $remote_host;
my $ssh_socket;
sub args_for_remote {
	return @_ if !$remote_host;
	return ("ssh", "-l", "root", "-S", $ssh_socket, $remote_host,
		map {ref($_) ? $_ : quotemeta($_)} @_);
}

sub do_remote {
	return do_local(args_for_remote(@_));
}

sub capture_local {
	# we only open() to local handles and let perl do the close()s
	my $args = pop if (ref $_[-1]);
	verbose("running @_ ",
		$args->{input} ? "< $args->{input} " : "",
		$args->{output} ? "> $args->{output} " : "",
		"... ");
	my $t_start = time;
	local (*OUTFILE, *INFILE, *DATAFILE);
	my ($fd_in, $fd_out, $fd_out_err, $fd_infile) = ();
	my $data = "";
	if ($args->{input}) {
		open(INFILE, "<", $args->{input})
			or die "\nERROR from command: @_\ncannot redirect ".
			       "input from $args->{input}: $!\n";
		$fd_infile = \*INFILE;
	}
	if ($args->{data}) {
		open(DATAFILE, "<", $args->{data})
			or die "\nERROR from command: @_\ncannot get input ".
			       "data from $args->{data}: $!\n";
	}
	if ($args->{output}) {
		open(OUTFILE, ">", $args->{output})
			or die "\nERROR from command: @_\ncannot redirect ".
			       "output to $args->{output}: $!\n";
		$fd_out_err = gensym;
	}
	my $pid = open3($fd_in,
			$args->{output} ? ">&OUTFILE" : $fd_out,
			$fd_out_err, @_);
	if (!$args->{input}) {
		close($fd_in);
		undef $fd_in;
	}
	$fd_out = $fd_out_err if $args->{output};
	my ($rin, $win, $rout, $wout, @out) = ("", "");
	vec($rin, fileno($fd_out), 1) = 1 if $fd_out;
	vec($win, fileno($fd_in), 1) = 1 if $fd_in;
	while ($fd_in || $fd_out) {
		$rout = $rin;
		$wout = $win;
		select($fd_out ? $rout : undef, $fd_in ? $wout : undef,
		       undef, undef);
		if ($fd_in && $wout eq $win) {
			my $buf = <$fd_infile>;
			if (defined $buf) {
				syswrite($fd_in, $buf)
					or die "\nERROR from command: @_\n".
					       "cannot write to it: $!\n";
			} elsif ($args->{data} && $fd_infile != \*DATAFILE) {
				my $ret = syswrite($fd_in, "\n__END__\n");
				die if $ret != 9;
				$fd_infile = \*DATAFILE;
			} else {
				undef $fd_in;
			}
		}
		if ($fd_out && $rout eq $rin) {
			my $ret = sysread($fd_out, $data, 8192, length($data));
			if (!defined $ret) {
				die "\nERROR from command: @_\ncannot ".
				    "read from it: $!\n";
			}
			undef $fd_out if !$ret;
		}
	}
	waitpid($pid, 0);
	if ($? && !$args->{mayfail}) {
		die "\nERROR from command ($?): @_\noutput:\n$data\n";
	}
	my $t_elapsed = int((time - $t_start) * 100)/100;
	verbose("done ($t_elapsed sec)\n");
	return $data;
}

sub capture_remote {
	return capture_local(args_for_remote(@_));
}

sub ignore_local {
	capture_local(@_, {mayfail => 1});
}

sub ignore_remote {
	return ignore_local(args_for_remote(@_));
}

sub check_blkdev {
	my $dev = shift;
	my $is_loop = 0;
	if (!-b $dev) {
		foreach (split /\n/, capture_local("losetup", "--all")) {
			if (/^([^\s:]+):.*$dev/) {
				ignore_local("umount", $1);
			}
		}
		$dev = capture_local("losetup", "--show", "-f", $dev);
		chomp $dev;
		$is_loop = 1;
	}
	return ($dev, $is_loop);
}

my $p_refgen = "./refgen.pl";
my $p_refgen_actions = "./actions";
my $p_fssum = "fssum";
my $p_fardir = "/tmp/far-$$";
my $p_sumfile = "$p_fardir/fssum.out";
my $p_btrfs = "btrfs";
my $p_zfs = "zfs";
my $p_diff_outfile = "$p_fardir/send.far";
my $p_perl = "perl";

my $allok = getopts("d:f:F:hkpqr:s:t:v", \%opts);

if (!$opts{d}) {
	print STDERR "missing -d destination\n";
	$allok = 0;
}

if (!$opts{s}) {
	print STDERR "missing -s source\n";
	$allok = 0;
}

if (!$opts{t} && !$opts{f} && !$opts{F}) {
	print STDERR "no test given, use -t, -f or -F\n";
	$allok = 0;
} elsif ($opts{f} && $opts{F}) {
	print STDERR "-f cannot be combined with -F\n";
	$allok = 0;
}

my $allowed_fs = join("|", @fs);

if (!$allok || $opts{h}) {
	usage(!$opts{h});
}

if ($opts{d} !~ /^([^:]+):(.*)$/) {
	print STDERR "wrong format for -d destination ($opts{d})\n";
	$allok = 0;
}
my ($dst_type, $dst_dev, $dst_is_loop) = ($1, check_blkdev($2));
if (!grep $dst_type, @fs) {
	print STDERR "unsupported type for destination\n";
	$allok = 0;
}
if ($opts{s} !~ /^([^:]+):(.*)$/) {
	print STDERR "wrong format for -s source ($opts{s})\n";
	$allok = 0;
}
my ($src_type, $src_dev, $src_is_loop) = ($1, $opts{r} ? $2 : check_blkdev($2));
if (!grep $src_type, @fs) {
	print STDERR "unsupported type for source\n";
	$allok = 0;
}
if ($dst_type eq "zfs") {
	print STDERR "zfs destination type not implemented\n";
	$allok = 0;
}
my $fuzz_test_seed = $opts{F};
my $fuzz_tests = $fuzz_test_seed ? 1 : $opts{f};

my $dst_mnt = "$p_fardir/mnt-dst";
my $src_mnt = "$p_fardir/mnt-src";
my $verbose = $opts{v} ? "-vv" : "";
my $keep_temp = $opts{k};
$remote_host = $opts{r};
$ssh_socket = "$p_fardir/ssh_sock";

my ($src_type_opt, @p_send, $src_send, $dst_subvol, $send_incr_opt, @p_destroy);
if ($src_type eq "zfs") {
	$src_type_opt = "-z";
	@p_send = qw(zfs send -F);
	@p_destroy = qw(zfs destroy -r);
	$send_incr_opt = "-i";
	$src_send = $src_dev;
	$dst_subvol = $src_dev;
	$dst_subvol =~ s{.*/}{};
} elsif ($src_type eq "btrfs") {
	$src_type_opt = "-b";
	@p_send = qw(btrfs send);
	@p_destroy = qw();
	$send_incr_opt = "-p";
	$src_send = "$src_mnt/";
	$dst_subvol = "";
} else {
	die;
}

sub do_src_destroy {
	ignore_remote("umount", $src_dev);
	if ($src_type eq "zfs") {
		ignore_remote(qw(zfs destroy -r), $src_dev);
	}
}

sub do_src_create {
	if ($src_type eq "zfs") {
		do_remote(qw(zfs create -o), "mountpoint=$src_mnt", $src_dev);
	} else {
		do_remote("mkfs.btrfs", "-L", "fits", $src_dev);
		do_remote("mount", $src_dev, $src_mnt);
	}
}

sub get_src_snapshot_cmd {
	my $snap = shift;
	if ($src_type eq "zfs") {
		return ("zfs", "snapshot", "$src_send\@$snap");
	} else {
		return (qw(btrfs subvol snap -r),
			$src_send, "$src_send/\@$snap");
	}
}

sub do_src_snapshot {
	do_remote(get_src_snapshot_cmd(@_));
}

sub do_src_fsstress {
	my $fuzz_test_seed = shift;
	my $seed = capture_remote(
		qw(fsstress -n 100 -d), "$src_mnt",
		($fuzz_test_seed ? ("-s", $fuzz_test_seed) : ()),
		"-x", join(" ", get_src_snapshot_cmd("base"))
	);
	$seed =~ /^seed = (\d+)/;
	return $fuzz_test_seed ? $fuzz_test_seed : $1;
}

sub do_src_send {
	my ($snap, $data_file) = @_;
	if ($src_type eq "zfs") {
		do_remote(@p_send, "$src_send\@$snap", {output => $data_file});
	} else {
		do_remote(@p_send, "$src_send\@$snap", {output => $data_file});
	}
}

sub do_src_fssum {
	my $snap = shift;
	my @exclude = $src_type eq "zfs" ? () : @_;
	do_remote($p_fssum, "-f", snapshot_path($snap),
		  (map { ("-x", "$src_mnt/\@$snap/\@$_") } @exclude),
		  {output => $p_sumfile});
}

sub do_src_send_incr {
	my ($base, $incr, $data_file) = @_;
	do_remote(@p_send, $send_incr_opt, "$src_send\@$base",
		  "$src_send\@$incr", {output => $data_file});
}

sub cleanup_temp {
	if (!$keep_temp) {
		ignore_local("umount", $dst_mnt);
		ignore_remote("umount", $src_mnt);
		ignore_local("rm", "-rf", $p_fardir);
		if ($remote_host) {
			ignore_remote("rm", "-rf", $p_fardir);
		}
	}
}

sub cleanup {
	cleanup_temp();
	if ($ssh_chld) {
		kill "TERM", $ssh_chld;
		unlink $ssh_socket;
	}
	if ($dst_is_loop) {
		ignore_local("losetup", "-d", $dst_dev);
	}
	if ($src_is_loop) {
		ignore_local("losetup", "-d", $src_dev);
	}
}

local $SIG{INT} = sub {
	$SIG{INT} = "DEFAULT";
	cleanup();
	kill "INT", $$;
};
local $SIG{PIPE} = "IGNORE";

sub snapshot_path {
	return "$src_mnt/\@$_[0]" if ($src_type eq "btrfs");
	return "$src_mnt/.zfs/snapshot/$_[0]" if ($src_type eq "zfs");
	die;
}

sub parse_range {
	my $range = shift;
	if ($range !~ /^(\d+)(?:-(\d+))?$/) {
		die qq{failed to parse test spec at "$range"};
	}
	my $start = $1;
	my $end = defined $2 ? $2 : $start;
	if ($start > $end) {
		die qq{reverse range in test spec at "$range"};
	}
	return ($start, $end);
}

my $number_of_digits_in_expand = 3;
sub subtest_range {
	my ($s_start, $s_end) = @_;
	my $n = $number_of_digits_in_expand;
	my $test_spec = ":(?:";
	for ($s_start .. $s_end) {
		$test_spec .= sprintf("%0${n}d", $_);
		$test_spec .= "|";
	}
	chop $test_spec;
	$test_spec .= ")-";
	return $test_spec;
}

my $test_spec = "";
if ($opts{t} && $opts{t} eq "all") {
	$test_spec = ".";
} elsif ($opts{t}) {
	my $n = $number_of_digits_in_expand;
	foreach (split /,/, $opts{t}) {
		my ($tnum, $subtests) = split /:/;
		my ($t_start, $t_end) = $tnum ? parse_range($tnum) : (1, 1);
		my ($s_start, $s_end) = parse_range($subtests) if $subtests;
		for ($t_start .. $t_end) {
			$test_spec .= "^";
			$test_spec .= $tnum ? sprintf("%0${n}d", $_) : "\\d+";
			if ($subtests) {
				$test_spec .= subtest_range($s_start, $s_end);
			} else {
				$test_spec .= ":";
			}
			$test_spec .= "|";
		}
	}
	chop $test_spec;
	eval {
		$test_spec = qr{$test_spec};
	};
	if ($@) {
		die "failed to compile regexp for test spec: $@"
	}
}
if (!$test_spec && !$fuzz_tests) {
	die qq{need either -t TESTSPEC|"all" or -f NUM\n};
}

mkdir($p_fardir) or die "mkdir for temp dir $p_fardir failed: $!\n";
mkdir($dst_mnt) or die "mkdir $dst_mnt failed: $!\n";
if ($remote_host) {
	# setup shared socket
	$ssh_chld = fork();
	if (!defined $ssh_chld) {
		die "fork failed: $!\n";
	}
	if (!$ssh_chld) {
		close(STDIN);
		close(STDOUT);
		close(STDERR);
		exec("ssh", "-M", "-N", "-l", "root", "-S",
		     $ssh_socket, $remote_host);
		die "exec failed: $!\n";
	}
	verbose("ssh master has pid $ssh_chld, socket $ssh_socket\n");
	do_remote("mkdir", $p_fardir);
	do_remote("mkdir", $src_mnt);
} else {
	mkdir($src_mnt) or die "mkdir $src_mnt failed: $!\n";
}
if ($fuzz_tests) {
	verbose("checking for fsstress availablity\n");
	my $out = capture_remote("fsstress", "-n", 0, "-d", $p_fardir);
}

ignore_local("umount", $dst_dev);
ignore_remote("umount", $src_dev);

my @files = split /\n/, capture_local("ls", $p_refgen_actions);
my @failed_tests = ();
my $cnt = 0;
my $ex_ret = 0;
foreach my $action_file (@files) {
	if (!$test_spec) {
		last;
	}
	if ($action_file !~ $test_spec) {
		next;
	}
	my $i = 0;
	my $n_snaps = 0;
	my $t_start = time;
	eval {
		out("running check $action_file... ");
		if ($cnt++) {
			do_local("umount", $dst_mnt);
			do_remote("umount", $src_mnt);
		}
		do_local("mkfs.btrfs", "-fL", "fits", $dst_dev);
		do_local("mount", "-o", "noatime", $dst_dev, $dst_mnt);

		do_remote($p_perl, "-", "-p", $src_mnt, $src_type_opt, $src_dev,
			  ($verbose ? $verbose : ()), {
				input => $p_refgen,
				data => "$p_refgen_actions/$action_file",
		});

		$n_snaps = capture_local("grep", "-c", "^snapshot\$",
					 "$p_refgen_actions/$action_file");
		chomp $n_snaps;

		my @exclude = ();
		for ($i = 1; $i <= $n_snaps; $i++) {
			my ($data_file);
			if ($i == 1) {
				$data_file = $p_diff_outfile.".full";
				do_remote(@p_send, "$src_send\@1",
					  {output => $data_file});
			} else {
				my $prev = $i - 1;
				$data_file = $p_diff_outfile.".incr.$prev-$i";
				do_remote(@p_send, $send_incr_opt,
					  "$src_send\@$prev", "$src_send\@$i",
					  {output => $data_file});
			}

			do_local($p_btrfs, "receive",
				 ($verbose ? $verbose : ()),
				 $dst_mnt, {input => $data_file});

			my @x = map { ("-x", "$src_mnt/\@$i/\@$_") } @exclude
				if $src_type eq "btrfs";
			do_remote($p_fssum, @x, "-f", snapshot_path($i),
				  {output => $p_sumfile});
			do_local($p_fssum, "-r", $p_sumfile,
				 "$dst_mnt/$dst_subvol\@$i");
			verbose("done\n");
			push @exclude, $i;
		}
	};

	if ($@) {
		die($@) if $opts{p};
		out($i ? "step $i/$n_snaps" : "preparation", " failed\n")
			if !$verbose;
		verbose($@);
		$ex_ret++;
		push @failed_tests, $action_file;
	} else {
		my $t_elapsed = int((time - $t_start) * 100)/100;
		out("ok ($t_elapsed sec)\n");
	}
}

for (my $i = 1; $fuzz_tests == -1 || $i <= $fuzz_tests; ++$i) {
	my $seed;
	my $t_start = time;
	eval {
		out("running fuzz check $i... ");
		ignore_local("umount", $dst_mnt);
		do_local("mkfs.btrfs", "-L", "fits", $dst_dev);
		do_local("mount", "-o", "noatime", $dst_dev, $dst_mnt);
		do_src_destroy();
		do_src_create();
		$seed = do_src_fsstress($fuzz_test_seed);
		out("(seed $seed) ");
		do_src_snapshot("incr");

		my $data_file = $p_diff_outfile.".full";
		do_src_send("base", $data_file);

		do_local($p_btrfs, "receive", ($verbose ? $verbose : ()),
			 $dst_mnt, {input => $data_file});

		do_src_fssum("base");
		do_local($p_fssum, "-r", $p_sumfile,
			 "$dst_mnt/$dst_subvol\@base");

		$data_file = $p_diff_outfile.".incr.0-1";
		do_src_send_incr("base", "incr", $data_file);
		do_local($p_btrfs, "receive", ($verbose ? $verbose : ()),
			 $dst_mnt, {input => $data_file});

		do_src_fssum("incr", "base");
		do_local($p_fssum, "-r", $p_sumfile,
			 "$dst_mnt/$dst_subvol\@incr");
	};

	if ($@) {
		die($@) if $opts{p};
		out(" failed\n");
		verbose($@);
		$ex_ret++;
		push @failed_tests, "fuzz test seed $seed";
	} else {
		my $t_elapsed = int((time - $t_start) * 100)/100;
		out("ok ($t_elapsed sec)\n");
	}
}

if (@failed_tests) {
	print "\nFailed tests: ", join(", ", @failed_tests), "\n";
} else {
	print "\nAll tests ok\n";
}

exit($ex_ret);

END {
	cleanup();
};