view release on metacpan or  search on metacpan

t/fuguweb/keys.t  view on Meta::CPAN

	spew( "$out/photos/deep/more.jpg", "mine\n" );

	ok( site( $config, $out )->build, 'a second build succeeds' );
	ok( -e "$out/photos/holiday.jpg", 'and it keeps the file' );
	ok( -e "$out/photos/deep/more.jpg", 'and the file below it' );
	ok( -d "$out/photos/deep",          'and the directory' );

	# The prune must never remove what the clean refuses to.
	ok( !site( $config, $out )->clean, 'the clean refuses the tree' );

	my @problems =
	    App::FuguWeb::Check->new( config => $config, out => $out )->run;
	ok(
		( grep { m{^photos/holiday\.jpg: in the output} } @problems ),
		'and the check reports it'
	) or diag join "\n", @problems;
};

subtest 'the checks see an empty directory that no build made' => sub {
	my ( $config, $reason ) = load( project() );
	ok( $config, 'the description loads' ) or diag $reason;

	my $out = tempdir( CLEANUP => 1 ) . '/out';
	ok( site( $config, $out )->build, 'the build succeeds' );

	mkdir "$out/archive" or die "Cannot make the directory: $!";

	# An empty directory is a leaf of the walk, so the checks and
	# the clean agree about the same tree.
	my @problems =
	    App::FuguWeb::Check->new( config => $config, out => $out )->run;
	ok( ( grep { m{^archive: in the output} } @problems ),
		'the check reports it' )
	    or diag join "\n", @problems;

	# The clean refuses this directory, so the build must keep it.
	# WEB-OUTPUT-6 holds for a directory as it holds for a file.
	ok( site( $config, $out )->build, 'a second build succeeds' );
	ok( -d "$out/archive", 'and the build keeps it' );
	ok( !site( $config, $out )->clean, 'the clean refuses it too' );

	spew( "$out/archive/notes.txt", "mine\n" );
	ok( site( $config, $out )->build, 'a third build succeeds' );
	ok( -e "$out/archive/notes.txt", 'and it keeps a directory of files' );
};

subtest 'the build reports a stray directory' => sub {
	my $root = project();
	my ( $config, $reason ) = load($root);
	ok( $config, 'the description loads' ) or diag $reason;

	my $out = "$root/out";
	ok( site( $config, $out )->build, 'the build succeeds' );

	spew( "$out/archive/notes.txt", "mine\n" );

	# The build keeps a directory that no build made, and it says
	# so. An empty one gets the same report, because the build
	# keeps that one too.
	my $said = '';
	open my $saved, '>&', \*STDERR or die "Cannot save stderr: $!";
	close STDERR;
	open STDERR, '>', \$said or die 'Cannot capture stderr';

	my $again = App::FuguWeb::Site->new(
		config => $config,
		out    => $out,
		render => App::FuguWeb::Render->new(
			config  => $config,
			mandoc  => '/bin/true',
			lowdown => '/bin/true',
		),
	)->build;

	close STDERR;
	open STDERR, '>&', $saved or die "Cannot restore stderr: $!";

	ok( $again, 'a second build succeeds' );
	ok( -e "$out/archive/notes.txt", 'and it keeps the file' );
	like( $said, qr{archive/notes\.txt is in the output},
		'and it reports the file' );

	# An empty directory below the key directory is nobody's
	# build, so it stays. The report of it has its own subtest.
	mkdir "$out/keys/stale" or die "Cannot make the directory: $!";
	ok( site( $config, $out )->build, 'a third build succeeds' );
	ok( -d "$out/keys/stale", 'and it keeps an empty one' );
	ok( !site( $config, $out )->clean, 'the clean refuses it too' );
};

subtest 'list_tree walks the leaves and no symlink' => sub {
	my $dir = tempdir( CLEANUP => 1 );

	spew( "$dir/top.txt",           "a\n" );
	spew( "$dir/below/deep/one.txt", "b\n" );
	mkdir "$dir/empty" or die "Cannot make the directory: $!";

	my $linked = -e '/etc/hostname' ? '/etc/hostname' : '/etc/passwd';
	my $made = symlink $linked, "$dir/link";
	my $tree = symlink $dir . '/below', "$dir/tree";

	my $paths = App::FuguWeb::list_tree($dir);
	ok( $paths, 'the walk reads the directory' );

	my %found = map { $_ => 1 } @$paths;
	ok( $found{'top.txt'},            'a file of the top level' );
	ok( $found{'below/deep/one.txt'}, 'a file below it' );
	ok( $found{'empty'}, 'an empty directory is a leaf of its own' );

	SKIP: {
		skip 'cannot make a symlink here', 2 unless $made && $tree;

		ok( $found{'link'}, 'a symlink is one entry' );
		ok( $found{'tree'},
			'and a symlinked directory is one entry, not a walk' );
	}

	is( App::FuguWeb::list_tree("$dir/no-such-directory"),
		undef, 'a directory that it cannot read gives undef' );
};

# renderers():
#	Whether every renderer of a page is installed. A subtest that
#	drives the real command needs them, and the rest of this file
#	needs none.
sub renderers ()
{
	for my $tool (qw(mandoc lowdown pod2man)) {
		return 0 unless system("command -v $tool >/dev/null 2>&1") == 0;
	}

	return 1;
}

# cli($root, @argv):
#	Run one command of the tool from the project root, with the
#	output captured, and return the exit code.
sub cli ( $root, @argv )
{
	my ( $out, $err ) = ( '', '' );

	my $here = Cwd::getcwd();
	chdir $root or die "Cannot chdir to $root: $!";

	open my $saved_out, '>&', \*STDOUT or die "Cannot save stdout: $!";
	open my $saved_err, '>&', \*STDERR or die "Cannot save stderr: $!";
	close STDOUT;
	close STDERR;
	open STDOUT, '>', \$out or die 'Cannot capture stdout';
	open STDERR, '>', \$err or die 'Cannot capture stderr';

	my $exit = eval { App::FuguWeb::CLI->run(@argv) };
	my $died = $@;

	close STDOUT;
	close STDERR;
	open STDOUT, '>&', $saved_out or die "Cannot restore stdout: $!";
	open STDERR, '>&', $saved_err or die "Cannot restore stderr: $!";

	chdir $here or die "Cannot chdir back: $!";
	die $died if $died;

	return ( $exit, $err );
}

subtest 'the clean command removes a key directory' => sub {
	my $root = project();
	my ( $config, $reason ) = load($root);
	ok( $config, 'the description loads' ) or diag $reason;

	my $out = "$root/out";
	ok( site( $config, $out )->build, 'the build succeeds' );
	ok( -d "$out/keys", 'the key directory is there' );

	# The command names --out, so it loads no description of its
	# own by the older rule. The description is what names the key
	# directory, and without it the clean refuses the whole site.
	my ( $exit, $err ) = cli( $root, 'clean', '--out', $out );
	is( $exit, 0, 'the clean succeeds' ) or diag $err;
	ok( !-e $out, 'and the whole tree is gone' );
};

subtest 'the clean command still refuses a tree that no build made' => sub {
	my $root = project();

	# A description that does not load must not stop the clean.
	# It is the command an operator reaches for when a description
	# is broken.
	spew( "$root/.fuguwebrc", "site = Example\nkeys \"keys\" {\n" );

	my $victim = "$root/victim";
	spew( "$victim/deep/keep.txt", "important\n" );

	my ( $exit, $err ) = cli( $root, 'clean', '--out', $victim );
	isnt( $exit, 0, 'the clean fails' );
	ok( -e "$victim/deep/keep.txt", 'and removes nothing' );
	like( $err, qr/refusing to remove it/, 'and says why' );
};

subtest 'clean refuses a file that the site does not name' => sub {
	my $root = project();
	my ( $config, $reason ) = load($root);
	ok( $config, 'the description loads' ) or diag $reason;

	my $out = "$root/out";
	ok( site( $config, $out )->build, 'the build succeeds' );

	# The site names the key directory, so a walk that read a
	# prefix would take every name below it. The rule is the
	# shape, and no key file is named notes.txt.
	spew( "$out/keys/notes.txt", "mine\n" );

	ok( !site( $config, $out )->clean, 'the clean refuses' );
	ok( -e "$out/keys/notes.txt", 'and removes nothing' );
};

subtest 'the top level takes any plain file that a build could write' =>
    sub {

t/fuguweb/keys.t  view on Meta::CPAN

		"mine\n" );

	my $hash = '.well-known/openpgpkey/hu/'
	    . 'ybndrfg8ejkmcpqxot1uwisza345h769';

	ok( site( $config, $out )->build, 'a second build succeeds' );
	ok( -e "$out/.well-known/security.txt",      'it keeps security.txt' );
	ok( -e "$out/.well-known/openpgpkey/policy", 'and the policy' );
	ok( -e "$out/$hash",                         'and the key of a hash' );

	ok( !site( $config, $out )->clean, 'the clean refuses the tree' );
	ok( -e "$out/.well-known/security.txt", 'and removes nothing' );
	ok( -e "$out/$hash",                    'the key of a hash as well' );
};

subtest 'a keyless description takes no foreign well-known tree' => sub {
	# The clean of a foreign target reads the description that it
	# can load. A .well-known directory alone must not make a tree
	# read like a built site.
	my ( $config, $reason ) = load( keyless() );
	ok( $config, 'the description loads' ) or diag $reason;

	my $out = tempdir( CLEANUP => 1 ) . '/out';
	make_path("$out/.well-known");
	spew( "$out/index.html", "<h1>Someone else</h1>\n" );
	spew( "$out/style.css",  "body{}\n" );
	spew( "$out/.well-known/security.txt", "Contact: theirs\n" );

	ok( !site( $config, $out )->clean, 'the clean refuses' );
	ok( -e "$out/.well-known/security.txt", 'and removes nothing' );
};

subtest 'a keyless description owns no well-known directory' => sub {
	# The directory half of the rule. An empty tree carries no
	# file, so the file guard never reaches it.
	my ( $config, $reason ) = load( keyless() );
	ok( $config, 'the description loads' ) or diag $reason;

	my $out = tempdir( CLEANUP => 1 ) . '/out';
	make_path("$out/.well-known/openpgpkey/hu");
	spew( "$out/index.html", "<h1>Someone else</h1>\n" );

	ok( !site( $config, $out )->clean, 'the clean refuses the tree' );
	ok( -d "$out/.well-known/openpgpkey/hu", 'and removes nothing' );
};

subtest 'the build names the stray directory that it keeps' => sub {
	# WEB-OUTPUT-4: the build keeps an entry that it may not
	# write, and it reports it. A silent build would leave the
	# operator to find the tree by hand.
	my $root = project();
	my ( $config, $reason ) = load($root);
	ok( $config, 'the description loads' ) or diag $reason;

	my $out = "$root/out";
	ok( site( $config, $out )->build, 'the build succeeds' );

	make_path("$out/photos/2024/raw");

	my $said = '';
	open my $saved, '>&', \*STDERR or die "Cannot save stderr: $!";
	close STDERR;
	open STDERR, '>', \$said or die 'Cannot capture stderr';

	my $again = App::FuguWeb::Site->new(
		config => $config,
		out    => $out,
		render => App::FuguWeb::Render->new(
			config  => $config,
			mandoc  => '/bin/true',
			lowdown => '/bin/true',
		),
	)->build;

	close STDERR;
	open STDERR, '>&', $saved or die "Cannot restore stderr: $!";

	ok( $again, 'a second build succeeds' );
	ok( -d "$out/photos/2024/raw", 'and it keeps the tree' );
	like( $said, qr{photos/2024/raw is in the output},
		'and it names the tree' );
};

subtest 'the clean refuses a directory of the source' => sub {
	# The build renders, so the skip comes before the first
	# assertion. A plan that arrives after one is not a plan.
	plan skip_all => 'a renderer is not installed' unless renderers();

	# The key files are the trust anchor of every release, and
	# each one sits at the top level of the key directory, where
	# the clean takes a plain file.
	my $root = project();
	my ( $config, $reason ) = load($root);
	ok( $config, 'the description loads' ) or diag $reason;

	for my $target (qw(web web/keys web/keys/deep)) {
		my ( $exit, $err ) = cli( $root, 'clean', '--out', $target );
		isnt( $exit, 0, "the clean refuses $target" );
		like( $err, qr{is the (?:source|key) directory},
			"and the target guard is the reason for $target" );
	}

	ok( -e "$root/web/keys/fugubsd-1-release.pub", 'the key survives' );
	ok( -e "$root/web/keys/SHA256",       'the manifest survives' );
	ok( -e "$root/web/keys/SHA256.sig",   'the signature survives' );
	ok( -e "$root/web/index.body.html",   'the source survives' );

	# The output directory that the description names is the one
	# exception below the source. This description names out, so
	# web/build is a directory of the source like any other.
	my ($exit) = cli( $root, 'build', '--out', 'web/build' );
	isnt( $exit, 0, 'the build refuses another directory of the source' );

	($exit) = cli( $root, 'build' );
	is( $exit, 0, 'and it takes the output that the site names' );

	# Every directory of the source, and not the key directory
	# alone. An operator directory there is content of the project.
	make_path("$root/web/img");
	spew( "$root/web/img/logo.svg", "logo\n" );

	for my $command (qw(build clean)) {
		my ($code) = cli( $root, $command, '--out', 'web/img' );
		isnt( $code, 0, "the $command refuses web/img" );
	}
	ok( -e "$root/web/img/logo.svg", 'the operator file survives' );
};

subtest 'a source that holds its own stylesheet' => sub {
	# The stylesheet guard alone would take this target, because
	# every build writes style.css and this source holds one. The
	# target guard is the rule that refuses it.
	my $root = project();
	spew( "$root/web/style.css", "body{}\n" );
	spew( "$root/.fuguwebrc", "site = Example\nnav \"index.html\" {\n" );