t/integration/config_engine_upload_file_real.t

#!/usr/bin/env perl

# mt-aws-glacier - Amazon Glacier sync client
# Copyright (C) 2012-2014  Victor Efimov
# http://mt-aws.com (also http://vs-dev.com) vs@vs-dev.com
# License: GPLv3
#
# This file is part of "mt-aws-glacier"
#
#    mt-aws-glacier 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.
#
#    mt-aws-glacier 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/>.

use strict;
use warnings;
use utf8;
use Test::More tests => 194;
use Test::Deep;
use Carp;
use FindBin;
use lib map { "$FindBin::RealBin/$_" } qw{../lib ../../lib};
use TestUtils 'w_fatal';
use Test::MockModule;
use File::Path;
use File::stat;
use Encode;
use Data::Dumper;

use App::MtAws::Utils;



my $mtroot = get_temp_dir();

# upload_file command parsing test

my ($default_concurrency, $default_partsize) = (4, 16);

# upload-file


my %common = (
	journal => 'j',
	partsize => $default_partsize,
	concurrency => $default_concurrency,
	key=>'mykey',
	secret => 'mysecret',
	region => 'myregion',
	protocol => 'http',
	vault =>'myvault',
	config=>'glacier.cfg',
	timeout => 180,
	'journal-encoding' => 'UTF-8',
	'terminal-encoding' => 'UTF-8',
	'config-encoding' => 'UTF-8'
);


#
# some integration testing
#

sub assert_passes_on_filesystem($$%)
{
	my ($msg, $query, %result) = @_;
	fake_config sub {
		disable_validations qw/journal secret key/ => sub {
			my $res = config_create_and_parse(@$query);
			print Dumper $res->{error_texts} if $res->{errors};
			ok !($res->{errors}||$res->{warnings}), $msg;
			is $res->{command}, 'upload-file', $msg;
			is_deeply($res->{options}, {
				%common,
				%result
			}, $msg);
		}
	}
}

sub assert_fails_on_filesystem($$%)
{
	my ($msg, $query, $novalidations, $error, %opts) = @_;
	fake_config sub {
		disable_validations qw/journal key secret/, @$novalidations => sub {
			my $res = config_create_and_parse(@$query);
			print Dumper $res->{options} unless $res->{errors};
			ok $res->{errors}, $msg;
			ok !defined $res->{warnings}, $msg;
			ok !defined $res->{command}, $msg;
			cmp_deeply [grep { $_->{format} eq $error } @{ $res->{errors} }], [{%opts, format => $error}], $msg;
		}
	}
}


sub test_file_and_dir
{
	my ($msg, $dir, $filename, $expected, $encoding) = @_;

	my $filename_enc = encode("UTF-8", $filename, Encode::DIE_ON_ERR|Encode::LEAVE_SRC);
	my $dir_enc = encode("UTF-8", $dir, Encode::DIE_ON_ERR|Encode::LEAVE_SRC);
	$encoding ||= "UTF-8";
	local $App::MtAws::Utils::_filename_encoding = undef;

	assert_passes_on_filesystem $msg,
		[qw!upload-file --config glacier.cfg --vault myvault --journal j!, '--filename', $filename_enc, '--dir', $dir_enc,'--filenames-encoding', $encoding],
		'name-type' => 'dir',
		'data-type' => 'filename',
		relfilename => $expected,
		dir => $dir,
		filename => $filename,
		'filenames-encoding' => $encoding;
}

sub fails_file_and_dir
{
	my ($msg, $dir, $filename, $error, %opts) = @_;
	assert_fails_on_filesystem $msg,
		[qw!upload-file --config glacier.cfg --vault myvault --journal j!, '--filename', $filename, '--dir', $dir],
		[],
		$error, %opts;
}



sub with_save_dir(&)
{
	my $curdir = Cwd::getcwd;
	shift->();
	chdir $curdir or confess;
}

sub with_my_dir($%)
{
	my ($d, $cb, @dirs) = (shift, pop, @_);
	my $dir = "$mtroot/$d";
	with_save_dir {
		mkpath binaryfilename $dir;
		mkpath binaryfilename "$mtroot/$_" for (@dirs);
		chdir binaryfilename $dir or confess;
		$cb->($dir);
	}
}

sub touch
{
	my ($filename, $content) = (@_, "1");
	open my $f, ">", binaryfilename $filename or confess;
	print $f $content;
	close $f;
}

with_my_dir "d1/d2", sub {
	touch "myfile";
	test_file_and_dir "dir/filename should work with ..",
		".", "myfile", "myfile";
	test_file_and_dir "dir/filename should work with ..",
		"..", "myfile", "d2/myfile";
	test_file_and_dir "dir/filename should work with ../..",
		"../..", "myfile", "d1/d2/myfile";
};


SKIP: {
	skip "Test cannot be performed on character-oriented filesystem", 36 unless can_work_with_non_utf8_files;
	for my $encoding (qw/UTF-8 CP1251 KOI8-R/) {
		local $App::MtAws::Utils::_filename_encoding = $encoding;
		with_my_dir "д1/д2", sub {
			touch "мойфайл";
			test_file_and_dir "dir/filename should work with ..",
				".", "мойфайл", "мойфайл", $encoding;
			test_file_and_dir "dir/filename should work with ..",
				"../д2", "мойфайл", "мойфайл", $encoding;
			test_file_and_dir "dir/filename should work with ..",
				"..", "мойфайл", "д2/мойфайл", $encoding;
			test_file_and_dir "dir/filename should work with ../..",
				"../..", "мойфайл", "д1/д2/мойфайл", $encoding;
		};
	}
}

with_my_dir "d1/d2", "d1/d2/d3", sub {
	my ($curdir) = @_;

	touch "d3/myfile";

	test_file_and_dir "dir/filename should work with ..",
		"d3", "d3/myfile", "myfile";
	test_file_and_dir "dir/filename should work with ..",
		"d3/", "d3/myfile", "myfile";
	test_file_and_dir "dir/filename should work with ..",
		"$curdir/d3/", "d3/myfile", "myfile";


	test_file_and_dir "dir/filename should work with ..",
		".", "d3/myfile", "d3/myfile";
	test_file_and_dir "dir/filename should work with ..",
		"..", "d3/myfile", "d2/d3/myfile";
	test_file_and_dir "dir/filename should work with ../..",
		"../..", "d3/myfile", "d1/d2/d3/myfile";
	test_file_and_dir "dir/filename should work with ../..",
		"../d2", "d3/myfile", "d3/myfile";
	test_file_and_dir "dir/filename should work with ../..",
		"../d2/../d2", "d3/myfile", "d3/myfile";
	test_file_and_dir "dir/filename should work with ../..",
		"../d2/.", "./d3/myfile", "d3/myfile";
	test_file_and_dir "dir/filename should work with ../..",
		"../d2", "../d2/d3/myfile", "d3/myfile";
	test_file_and_dir "dir/filename should work with ../..",
		".", "../d2/d3/myfile", "d3/myfile";
	test_file_and_dir "dir/filename should work with ../..",
		"../..", "../../d1/d2/d3/myfile", "d1/d2/d3/myfile";
};

with_my_dir "d1/d2", "d1/d2/d3", "d1/d2/d3/d4", sub {
	touch "d3/myfile";
	touch "d3/d4/myfile2";
	symlink "d3", "ds" or confess;

	test_file_and_dir "dir/filename should work with symlinks 1",
		"d3", "d3/myfile", "myfile";

	test_file_and_dir "dir/filename should work with symlinks 1",
		"d3/", "d3/myfile", "myfile";

	test_file_and_dir "dir/filename should work with symlinks 2",
		"ds", "d3/myfile", "myfile";

	test_file_and_dir "dir/filename should work with symlinks 3",
		"d3", "ds/myfile", "myfile";

	test_file_and_dir "dir/filename should work with symlinks 4",
		"ds", "ds/myfile", "myfile";


	test_file_and_dir "dir/filename should work with symlinks 5",
		"d3", "d3/d4/myfile2", "d4/myfile2";

	test_file_and_dir "dir/filename should work with symlinks 6",
		"ds", "d3/d4/myfile2", "d4/myfile2";

	test_file_and_dir "dir/filename should work with symlinks 7",
		"d3", "ds/d4/myfile2", "d4/myfile2";

	test_file_and_dir "dir/filename should work with symlinks 8",
		"ds", "ds/d4/myfile2", "d4/myfile2";

	test_file_and_dir "dir/filename should work with symlinks 8",
		"ds/", "ds/d4/myfile2", "d4/myfile2";
};


my @filename_inside_dir = ('filename_inside_dir', a => 'filename', b => 'dir');
my @not_a_file = ('%option a% not a file', a => 'filename');
my @not_a_dir = ('%option a% not a directory', a => 'dir');

with_my_dir "d1/d2", "d1/d2/d3", sub {
	my ($curdir) = @_;

	touch "../myfile1";
	touch "myfile2";
	touch "d3/myfile3";

	fails_file_and_dir "filename inside dir",
		"d3", "myfile2", @filename_inside_dir;

	fails_file_and_dir "filename inside dir",
		"$curdir/d3", "$curdir/myfile2", @filename_inside_dir;

	fails_file_and_dir "filename inside dir",
		"d3", "../myfile1", @filename_inside_dir;

	fails_file_and_dir "filename inside dir",
		".", "../myfile1", @filename_inside_dir;

	fails_file_and_dir "file not found",
		".", "../notafile", @not_a_file, value => '../notafile';

	fails_file_and_dir "file not found",
		"d3", "../notafile", @not_a_file, value => '../notafile';

	fails_file_and_dir "file not found",
		"d3", "notafile", @not_a_file, value => 'notafile';

	fails_file_and_dir "filename inside dir",
		"notadir", "myfile2", @not_a_dir, value => 'notadir';

	fails_file_and_dir "filename inside dir",
		"$curdir/notadir", "$curdir/myfile2", @not_a_dir, value => "$curdir/notadir";

	fails_file_and_dir "filename inside dir",
		"notadir", "notafile", @not_a_dir, value => 'notadir';

	# TODO: test also for bad filename
	fails_file_and_dir "filename inside dir",
		('x' x 2048), "myfile2", '%option a% should be less than 512 characters', a => 'dir', value => ("x" x 2048);

};

SKIP: {
	skip "Cannot run under root", 24 if $^O eq 'cygwin' || is_posix_root; # too britle even under cygwin non-root

	my $restricted_abs = "$mtroot/restricted";
	my $normal_abs = "$restricted_abs/normal";
	my $file_abs = "$normal_abs/file";


	with_my_dir "restricted/normal", "restricted/normal/another", sub {
		touch $file_abs;

		mkpath "top";

		my $file_rel = "file";
		my $normal_rel = "../normal";

		is stat($file_rel)->ino, stat($file_abs)->ino;
		is stat($normal_rel)->ino, stat($normal_abs)->ino;

		ok -f $file_rel;
		ok -f $file_abs;
		ok -d $normal_rel;
		ok -d $normal_rel;


		test_file_and_dir "dir/filename should work",
			"another/..", $file_rel, $file_rel;

		test_file_and_dir "dir/filename should work",
			"$mtroot/restricted/normal", $file_rel, $file_rel;

		chmod 000, $restricted_abs;

		ok  -f $file_rel;
		ok !-f $file_abs;
		ok !-d $normal_rel;
		ok !-d $normal_abs;

		fails_file_and_dir "filename inside dir - dir is unresolvable",
			"another/..", $file_rel, 'cannot_resolve_dir', a => 'dir';

		fails_file_and_dir "filename inside dir - file is unresolvable",
			$mtroot, $file_rel, 'cannot_resolve_file', a => 'filename';

		chmod 700, $restricted_abs;
	}
};

# TODO: also test with non-ascii filenames
with_my_dir "d1", sub {
	touch "myfile";
	touch "unreadable";
	touch "empty", "";

	chmod 000, "unreadable";

	assert_fails_on_filesystem "should check --filename for readability",
		[qw!upload-file --config glacier.cfg --vault myvault --journal j --set-rel-filename somefile!, '--filename', "notafile"],
		[],
		'%option a% not a file', a => 'filename', value => 'notafile';

	assert_fails_on_filesystem "should check --filename for readability",
		[qw!upload-file --config glacier.cfg --vault myvault --journal j --set-rel-filename somefile!, '--filename', "empty"],
		[],
		'%option a% file size is zero', a => 'filename', value => 'empty';

	SKIP: {
		skip "Cannot run under root", 4 if is_posix_root;
		assert_fails_on_filesystem "should check --filename for readability",
			[qw!upload-file --config glacier.cfg --vault myvault --journal j --set-rel-filename somefile!, '--filename', "unreadable"],
			[],
			'%option a% file not readable', a => 'filename', value => 'unreadable';
	}

	assert_passes_on_filesystem "should check --filename for readability",
		[qw!upload-file --config glacier.cfg --vault myvault --journal j --set-rel-filename somefile!, '--filename', "myfile"],
		'name-type' => 'rel-filename',
		'data-type' => 'filename',
		'set-rel-filename' => 'somefile',
		'relfilename' => 'somefile',
		filename => 'myfile',
		'filenames-encoding' => 'UTF-8';
};

1;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)