The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl

use Test::More;

use Git::Raw;
use File::Spec::Functions qw(catfile rel2abs);
use File::Slurp::Tiny qw(write_file);
use File::Basename qw(dirname);
use File::Spec::Unix;
use File::Path qw(make_path remove_tree);

my $local_path = rel2abs(catfile('t', 'local_bare_repo'));
make_path($local_path);

my $local_repo = Git::Raw::Repository -> init($local_path, 1);
is $local_repo -> is_bare, 1;

my $path = rel2abs(catfile('t', 'test_repo'));
my $repo = Git::Raw::Repository -> open($path);

my $remote = Git::Raw::Remote -> create_anonymous($repo, $local_path);
isa_ok $remote, 'Git::Raw::Remote';

my $total_packed = 0;
is $remote -> upload(['refs/heads/master:refs/heads/master'], {
		'callbacks' => {
			'pack_progress' => sub {
				my ($stage, $current, $total) = @_;

				ok ($stage == Git::Raw::Packbuilder->ADDING_OBJECTS ||
					$stage == Git::Raw::Packbuilder->DELTAFICATION);
				if ($stage == Git::Raw::Packbuilder->ADDING_OBJECTS)
				{
					is $current, 1;
					is $total, 0;
				}
				else
				{
					ok ($current <= $total);
					ok ($total > 0);
				}
				$total_packed++;
			}
		}
	}), 1;
ok ($total_packed > 0);

$remote = undef;
$local_repo = undef;

remove_tree $local_path;
ok ! -e $local_path;

my $local_url;
if ($^O eq 'MSWin32') {
	$local_url = "file:///$local_path";
} else {
	$local_url = "file://$local_path";
}
$local_repo = Git::Raw::Repository -> init($local_path, 1);
$remote = Git::Raw::Remote -> create_anonymous($repo, $local_url);

my $updated_ref;
$total_packed = 0;
is $remote -> upload(['refs/heads/master:refs/heads/master'], {
		'callbacks' => {
			'pack_progress' => sub {
				my ($stage, $current, $total) = @_;

				ok ($stage == 0 || $stage == 1);
				if ($stage == 0)
				{
					is $current, 1;
					is $total, 0;
				}
				else
				{
					ok ($current <= $total);
					ok ($total > 0);
				}

				$total_packed++;
			},
			'push_update_reference' => sub {
				my ($ref, $msg) = @_;

				ok (defined($ref));
				ok (!defined($msg));
				$updated_ref = $ref;
			}
		}
	}), 1;
ok ($total_packed > 0);
is $updated_ref, "refs/heads/master";

remove_tree $local_path;
ok ! -e $local_path;

unless ($ENV{NETWORK_TESTING} or $ENV{RELEASE_TESTING}) {
	diag('remote push tests require network');
	done_testing;
	exit;
}

if ($^O eq 'MSWin32') {
	diag("Windows doesn't have a SSH server, skipping SSH push tests");
	done_testing;
	exit;
}

my %features = Git::Raw -> features;
if ($features{'ssh'} == 0) {
	diag("SSH support not available, skipping SSH push tests");
	done_testing;
	exit;
}

my $remote_path = rel2abs(catfile('t', 'test_repo'));
my $remote_url = "ssh://$ENV{USER}\@localhost$remote_path";
$path = rel2abs(catfile('t', 'test_repo_ssh'));

my $challenge = sub {
	my ($name, $instruction, @prompts) = @_;

	is scalar(@prompts), 1;
	my $prompt = shift @prompts;
	like $prompt->{text}, qr/Password/;
	is $prompt->{echo}, 0;
	return ('blah');
};

my $tried_interactive = 0;
my $credentials = sub {
	my ($url, $user, $types) = @_;

	is ref($types), 'ARRAY';
	is scalar(grep { $_ eq 'ssh_key' } @$types), 1;
	is scalar(grep { $_ eq 'ssh_custom' } @$types), 1;
	is scalar(grep { $_ eq 'ssh_interactive' } @$types), 1;

	if (!$tried_interactive) {
		$tried_interactive = 1;
		return Git::Raw::Cred -> sshinteractive($user, $challenge);
	}

	my $ssh_dir = File::Spec -> catfile($ENV{HOME}, '.ssh');
	ok -e $ssh_dir;

	my $public_key = File::Spec -> catfile($ssh_dir, 'id_rsa.pub');
	my $private_key = File::Spec -> catfile($ssh_dir, 'id_rsa');
	ok -f $public_key;
	ok -f $private_key;

	return Git::Raw::Cred -> sshkey($user, $public_key, $private_key);
};

$repo = Git::Raw::Repository -> clone($remote_url, $path, {}, {
	'callbacks' => {
		'credentials' => $credentials
	}
});

ok !$repo -> is_empty;
@remotes = $repo -> remotes;

my $config = $repo -> config;
$config -> str('user.name', 'some user');
$config -> str('user.email', 'someuser@somewhere.com');

my $branch = Git::Raw::Branch -> create($repo, "ssh_branch", $repo -> head -> target);
isa_ok $branch, 'Git::Raw::Branch';

$repo -> checkout($repo -> head($branch), {
	'checkout_strategy' => {
		'safe' => 1
	}
});

my $file  = $repo -> workdir . 'file_on_ssh_branch';
write_file($file, 'this is a test');

my $index = $repo -> index;
$index -> add('file_on_ssh_branch');
$index -> write;

my $me = Git::Raw::Signature -> default($repo);
my $commit = $repo -> commit("commit on file_on_ssh_branch\n", $me, $me, [$branch -> target],
	$index -> write_tree);

is scalar(@remotes), 1;
$remote = shift @remotes;

my ($credentials_fired, $sideband_fired, $update_tips_fired) = (0, 0, 0);
my ($pack_progress_fired, $transfer_progress_fired, $status_fired) = (0, 0, 0);
my ($negotation_fired, $transport_fired) = (0, 0);

my $callbacks = {
	'credentials' => sub {
		$credentials_fired = 1;
		return &{$credentials}(@_);
	},
	'sideband_progress' => sub {
		my ($msg) = @_;

		diag("Remote message (sideband): $msg");
		is $msg, "This is from the pre-receive hook! (Disallowing it)";
		$sideband_fired = 1;
	},
	'pack_progress' => sub {
		my ($stage, $current, $total) = @_;

		$pack_progress_fired = 1;
	},
	'push_transfer_progress' => sub {
		my ($current, $total, $bytes) = @_;

		$transfer_progress_fired = 1;
	},
	'push_update_reference' => sub {
		my ($ref, $msg) = @_;

		is $ref, 'refs/heads/ssh_branch';
		ok defined($msg);
		like $msg, qr/pre-receive hook/;
		$status_fired = 1;
	},
	'push_negotiation' => sub {
		my ($values) = @_;

		isa_ok $values, 'ARRAY';
		is scalar(@$values), 1;

		my $info = shift @$values;
		is_deeply $info, {
			'src_refname' => 'refs/heads/ssh_branch',
			'dst_refname' => 'refs/heads/ssh_branch',
			'src'         => '0' x 40,
			'dst'         => $commit -> id,
		};

		$negotation_fired = 1;
		return 0;
	},
	'update_tips' => sub {
		my ($ref, $a, $b) = @_;
		$update_tips_fired = 1;
	},
	'transport' => sub {
		my ($remote) = @_;

		isa_ok $remote, 'Git::Raw::Remote';
		is $remote -> url, $remote_url;
		$transport_fired = 1;

		#TODO: Return a transport here
	},
};

# setup a pre-receive hook that fails
my $pre_receive_content = <<'EOS';
#!/usr/bin/env perl

$|++;

print STDERR "This is from the pre-receive hook! (Disallowing it)";
exit(1);
EOS

my $pre_receive_file = File::Spec->catfile ($remote_path, '.git', 'hooks', 'pre-receive');
make_path dirname($pre_receive_file);
ok -e dirname($pre_receive_file);

write_file($pre_receive_file, $pre_receive_content);

ok -e $pre_receive_file;
chmod 0755, $pre_receive_file;

# pre-receive hook kick
$remote -> connect('push', $callbacks);
is $remote -> push(["refs/heads/ssh_branch:refs/heads/ssh_branch"], {
	'callbacks' => $callbacks
}), 1;
diag("Pre-receive hook (successfully) declined the push");

is $sideband_fired, 1;
is $credentials_fired, 1;
is $pack_progress_fired, 1;
is $transfer_progress_fired, 1;
is $status_fired, 1;
is $update_tips_fired, 0;
is $negotation_fired, 1;
is $transport_fired, 1;

# setup a pre-receive hook that succeeds
$pre_receive_content = <<'EOS';
#!/usr/bin/env perl

$|++;

print STDERR "This is from the pre-receive hook! (Allowing it)";
exit(0);
EOS

write_file($pre_receive_file, $pre_receive_content);

$callbacks = {
	'credentials' => sub {
		$credentials_fired = 1;
		return &{$credentials}(@_);
	},
	'sideband_progress' => sub {
		my ($msg) = @_;

		diag("Remote message (sideband): $msg");
		is $msg, "This is from the pre-receive hook! (Allowing it)";
		$sideband_fired = 1;
	},
	'update_tips' => sub {
		my ($ref, $a, $b) = @_;

		is $ref, 'refs/remotes/origin/ssh_branch';
		ok !defined($a);
		ok defined($b);
		isnt $a, $b;
		$update_tips_fired = 1;
	},
	'push_update_reference' => sub {
		my ($ref, $msg) = @_;

		is $ref, 'refs/heads/ssh_branch';
		ok !defined($msg);
		$status_fired = 1;
	}
};

$sideband_fired = 0;
$update_tips_fired = 0;
$status_fired = 0;
is $remote -> push(["refs/heads/ssh_branch:refs/heads/ssh_branch"], {
	'callbacks' => $callbacks
}), 1;
is $sideband_fired, 1;
is $status_fired, 1;
is $update_tips_fired, 1;

@remotes = ();
$repo = undef;

remove_tree $path;
ok ! -e $path;

done_testing;