v45-0003-Extending-PostgresNode-to-test-corruption.patch

From 9a68cf04ce1f847b2c4f02ed8e5e88fce997b664 Mon Sep 17 00:00:00 2001
From: Mark Dilger <mark.dilger@enterprisedb.com>
Date: Tue, 2 Feb 2021 12:37:58 -0800
Subject: [PATCH v45 3/3] Extending PostgresNode to test corruption.

PostgresNode now has functions for overwriting relation files
with full or partial prior versions of those files, creating
corruption beyond merely twiddling the bits of a heap relation
file.

Adding a regression test for pg_amcheck based on this new
functionality.
---
 contrib/pg_amcheck/t/006_relfile_damage.pl    | 145 ++++++++++
 src/test/modules/Makefile                     |   1 +
 src/test/modules/corruption/Makefile          |  16 ++
 .../modules/corruption/t/001_corruption.pl    |  83 ++++++
 src/test/perl/PostgresNode.pm                 | 265 ++++++++++++++++++
 5 files changed, 510 insertions(+)
 create mode 100644 contrib/pg_amcheck/t/006_relfile_damage.pl
 create mode 100644 src/test/modules/corruption/Makefile
 create mode 100644 src/test/modules/corruption/t/001_corruption.pl

diff --git a/contrib/pg_amcheck/t/006_relfile_damage.pl b/contrib/pg_amcheck/t/006_relfile_damage.pl
new file mode 100644
index 0000000000..45ad223531
--- /dev/null
+++ b/contrib/pg_amcheck/t/006_relfile_damage.pl
@@ -0,0 +1,145 @@
+use strict;
+use warnings;
+
+use TestLib;
+use Test::More tests => 22;
+use PostgresNode;
+
+my ($node, $port);
+
+# Returns the name of the toast relation associated with the named relation.
+#
+# Assumes the test node is running
+sub relation_toast($$)
+{
+	my ($dbname, $relname) = @_;
+
+	my $rel = $node->safe_psql($dbname, qq(
+		SELECT ct.relname
+			FROM pg_catalog.pg_class cr, pg_catalog.pg_class ct
+			WHERE cr.oid = '$relname'::regclass
+			  AND cr.reltoastrelid = ct.oid
+			));
+	return undef unless defined $rel;
+	return "pg_toast.$rel";
+}
+
+# Test set-up
+$node = get_new_node('test');
+$node->init;
+$node->start;
+$port = $node->port;
+
+# Load the amcheck extension, upon which pg_amcheck depends
+$node->safe_psql('postgres', q(CREATE EXTENSION amcheck));
+
+# Create a table with a btree index.  Use a fillfactor for the table and index
+# that will allow some fraction of updates to be on the original pages and some
+# on new pages.
+#
+$node->safe_psql('postgres', qq(
+create schema t;
+create table t.t1 (id integer, t text) with (fillfactor=75);
+alter table t.t1 alter column t set storage external;
+insert into t.t1 select gs, repeat('x',gs) from generate_series(9990,10000) gs;
+create index t1_idx on t.t1 (id) with (fillfactor=75);
+));
+
+my $toastrel = relation_toast('postgres', 't.t1');
+
+# Flush relation files to disk and take snapshots of the toast and index
+#
+$node->restart;
+$node->take_relfile_snapshot_minimal('postgres', 'idx', 't.t1_idx');
+$node->take_relfile_snapshot_minimal('postgres', 'toast', $toastrel);
+
+# Insert new data into the table and index
+#
+$node->safe_psql('postgres', qq(
+insert into t.t1 select gs, repeat('y',gs) from generate_series(10001,10100) gs;
+));
+
+# Revert index.  The reverted snapshot file is not corrupt, but it also
+# does not match the current contents of the table.
+#
+$node->stop;
+$node->revert_to_snapshot('idx');
+
+# Restart the node and check table and index with varying options.
+#
+$node->start;
+
+# Checks which do not reconcile the index and table via --heapallindexed will
+# not notice any problems
+#
+$node->command_like(
+	[ 'pg_amcheck', '--quiet', '-p', $port, '-r', 'postgres.t.*' ],
+	qr/^$/,
+	'pg_amcheck reverted index at default checking level');
+
+$node->command_like(
+	[ 'pg_amcheck', '--quiet', '-p', $port, '-r', 'postgres.t.*' ],
+	qr/^$/,
+	'pg_amcheck reverted index at default checking level');
+
+$node->command_like(
+	[ 'pg_amcheck', '--quiet', '-p', $port, '-r', 'postgres.t.*', '--parent-check' ],
+	qr/^$/,
+	'pg_amcheck reverted index with --parent-check');
+
+$node->command_like(
+	[ 'pg_amcheck', '--quiet', '-p', $port, '-r', 'postgres.t.*', '--rootdescend' ],
+	qr/^$/,
+	'pg_amcheck reverted index with --rootdescend');
+
+# Checks which do reconcile the index and table via --heapallindexed will
+# notice the mismatch in their contents
+#
+$node->command_checks_all(
+	[ 'pg_amcheck', '--quiet', '-p', $port, '-r', 'postgres.t.*', '--heapallindexed' ],
+	2,
+	[ qr/heap tuple .* from table "t1" lacks matching index tuple within index "t1_idx"/ ],
+	[ ],
+	'pg_amcheck reverted index with --heapallindexed');
+
+$node->command_checks_all(
+	[ 'pg_amcheck', '--quiet', '-p', $port, '-r', 'postgres.t.*', '--heapallindexed', '--rootdescend' ],
+	2,
+	[ qr/heap tuple .* from table "t1" lacks matching index tuple within index "t1_idx"/ ],
+	[ ],
+	'pg_amcheck reverted index with --heapallindexed --rootdescend');
+
+# Revert the toast.  The reverted toast table is not corrupt, but it does not
+# have entries for all toast pointers in the main table
+#
+$node->stop;
+$node->revert_to_snapshot('toast');
+
+# Restart the node and check table and toast with varying options.  When
+# checking the toast pointers, we may get errors produced by verify_heapam, but
+# we may also get errors from failure to read toast blocks that are beyond the
+# end of the toast table, of the form /ERROR:  could not read block/.  To avoid
+# having a brittle test, we accept any error message.
+#
+$node->start;
+
+$node->command_checks_all(
+	[ 'pg_amcheck', '--quiet', '-p', $port, '-r', $toastrel ],
+	0,
+	[ qr/^$/ ],
+	[ ],
+	'pg_amcheck reverted toast table');
+
+$node->command_checks_all(
+	[ 'pg_amcheck', '--quiet', '-p', $port, '-r', 'postgres.t.*', '--exclude-toast-pointers' ],
+	0,
+	[ qr/^$/ ],
+	[ ],
+	'pg_amcheck with reverted toast using --exclude-toast-pointers');
+
+$node->command_checks_all(
+	[ 'pg_amcheck', '--quiet', '-p', $port, '-r', 'postgres.t.*' ],
+	2,
+	[ qr/.+/ ],			# Any non-empty error message is acceptable
+	[ ],
+	'pg_amcheck with reverted toast and default checking');
diff --git a/src/test/modules/Makefile b/src/test/modules/Makefile
index 5391f461a2..c92d1702b4 100644
--- a/src/test/modules/Makefile
+++ b/src/test/modules/Makefile
@@ -7,6 +7,7 @@ include $(top_builddir)/src/Makefile.global
 SUBDIRS = \
 		  brin \
 		  commit_ts \
+		  corruption \
 		  delay_execution \
 		  dummy_index_am \
 		  dummy_seclabel \
diff --git a/src/test/modules/corruption/Makefile b/src/test/modules/corruption/Makefile
new file mode 100644
index 0000000000..ba461c645d
--- /dev/null
+++ b/src/test/modules/corruption/Makefile
@@ -0,0 +1,16 @@
+# src/test/modules/corruption/Makefile
+
+# EXTRA_INSTALL = contrib/pg_amcheck
+
+TAP_TESTS = 1
+
+ifdef USE_PGXS
+PG_CONFIG = pg_config
+PGXS := $(shell $(PG_CONFIG) --pgxs)
+include $(PGXS)
+else
+subdir = src/test/modules/corruption
+top_builddir = ../../../..
+include $(top_builddir)/src/Makefile.global
+include $(top_srcdir)/contrib/contrib-global.mk
+endif
diff --git a/src/test/modules/corruption/t/001_corruption.pl b/src/test/modules/corruption/t/001_corruption.pl
new file mode 100644
index 0000000000..ae4a262e06
--- /dev/null
+++ b/src/test/modules/corruption/t/001_corruption.pl
@@ -0,0 +1,83 @@
+use strict;
+use warnings;
+
+use TestLib;
+use Test::More tests => 10;
+use PostgresNode;
+
+my $node = get_new_node('test');
+$node->init;
+$node->start;
+
+# Create something non-trivial for the first snapshot
+$node->safe_psql('postgres', qq(
+create table t1 (id integer, short_text text, long_text text);
+insert into t1 (id, short_text, long_text)
+	(select gs, 'foo', repeat('x', gs)
+		from generate_series(1,10000) gs);
+create unique index idx1 on t1 (id, short_text);
+vacuum freeze;
+));
+
+# Flush relation files to disk and take snapshot of them
+$node->restart;
+$node->take_relfile_snapshot('postgres', 'snap1', 'public.t1');
+
+# Update data in the table, toast table, and index
+$node->safe_psql('postgres', qq(
+update t1 set
+	short_text = 'bar',
+	long_text = repeat('y', id);
+));
+
+# Flush relation files to disk and take second snapshot
+$node->restart;
+$node->take_relfile_snapshot('postgres', 'snap2', 'public.t1');
+
+# Revert the first page of t1 using a torn snapshot.  This should be a partial
+# and corrupt reverting of the update.
+$node->stop;
+$node->revert_to_torn_relfile_snapshot('snap1', 8192);
+
+# Restart the node and count the number of rows in t1 with the original
+# (pre-update) values.  It should not be zero, but nor will it be the full
+# 10000.
+$node->start;
+my ($old, $new, $oldtoast, $newtoast) = counts();
+ok($old > 0 && $old < 10000, "Torn snapshot reverts some of the main updates");
+ok($new > 0 && $new <= 10000, "Torn snapshot retains some of the main updates");
+
+# Revert t1 fully to the first snapshot.  This should fully restore the
+# original (pre-update) values.
+$node->stop;
+$node->revert_to_snapshot('snap1');
+
+# Restart the node and verify only old values remain
+$node->start;
+($old, $new, $oldtoast, $newtoast) = counts();
+is($old, 10000, "Full snapshot restores all the old main values");
+is($oldtoast, 10000, "Full snapshot restores all the old toast values");
+is($new, 0, "Full snapshot reverts all the new main values");
+is($newtoast, 0, "Full snapshot reverts all the new toast values");
+
+# Restore t1 fully to the second snapshot.  This should fully restore the
+# new (post-update) values.
+$node->stop;
+$node->revert_to_snapshot('snap2');
+
+# Restart the node and verify only new values remain
+$node->start;
+($old, $new, $oldtoast, $newtoast) = counts();
+is($old, 0, "Full snapshot reverts all the old main values");
+is($oldtoast, 0, "Full snapshot reverts all the old toast values");
+is($new, 10000, "Full snapshot restores all the new main values");
+is($newtoast, 10000, "Full snapshot restores all the new toast values");
+
+sub counts {
+	return map {
+		$node->safe_psql('postgres', qq(select count(*) from t1 where $_))
+	} ("short_text = 'foo'",
+	   "short_text = 'bar'",
+	   "long_text ~ 'x'",
+	   "long_text ~ 'y'");
+}
diff --git a/src/test/perl/PostgresNode.pm b/src/test/perl/PostgresNode.pm
index 9667f7667e..5402d020f1 100644
--- a/src/test/perl/PostgresNode.pm
+++ b/src/test/perl/PostgresNode.pm
@@ -2225,6 +2225,271 @@ sub pg_recvlogical_upto
 
 =back
 
+=head1 DATABASE CORRUPTION METHODS
+
+=over
+
+=item $node->relfile_snapshot_repository()
+
+The path to the parent directory of all directories storing snapshots of
+relation backing files.
+
+=cut
+
+sub relfile_snapshot_repository
+{
+	my ($self) = @_;
+	my $snaprepo = join('/', $self->basedir, 'snapshot');
+	unless (-d $snaprepo)
+	{
+		mkdir $snaprepo
+			or $!{EEXIST}
+			or BAIL_OUT("could not create snapshot repository directory \"$snaprepo\": $!");
+	}
+	return $snaprepo;
+}
+
+=pod
+
+=item $node->relfile_snapshot_directory(snapname)
+
+The path to the directory for storing the named snapshot.
+
+=cut
+
+sub relfile_snapshot_directory
+{
+	my ($self, $snapname) = @_;
+
+	join("/", $self->relfile_snapshot_repository(), $snapname);
+}
+
+=pod
+
+=item $node->take_relfile_snapshot($self, $dbname, $snapname, @relnames)
+
+Makes a copy of the files backing the relations B<@relname>, the associated
+toast relations (if any), and all associated indexes (if any).  No attempt is
+made to flush these files to disk, meaning the snapshot taken could be stale
+unless the caller ensures these files have been flushed prior to calling.
+
+Dies on failure to invoke psql.
+
+Dies on missing relations.
+
+Dies if the given B<$snapname> is already in use.
+
+=cut
+
+=pod
+
+=item $node->take_relfile_snapshot_minimal($self, $dbname, $snapname, @relnames)
+
+Makes a copy of the files backing the relations B<@relnames>.  No attempt is made
+to flush these files to disk, meaning the snapshot taken could be stale unless the
+caller ensures these files have been flushed prior to calling.
+
+Dies on failure to invoke psql.
+
+Dies on missing relation.
+
+Dies if the given B<$snapname> is already in use.
+
+=cut
+
+sub take_relfile_snapshot
+{
+	my ($self, $dbname, $snapname, @relnames) = @_;
+	$self->take_relfile_snapshot_helper($dbname, $snapname, 1, @relnames);
+}
+
+sub take_relfile_snapshot_minimal
+{
+	my ($self, $dbname, $snapname, @relnames) = @_;
+	$self->take_relfile_snapshot_helper($dbname, $snapname, 0, @relnames);
+}
+
+sub take_relfile_snapshot_helper
+{
+	my ($self, $dbname, $snapname, $extended, @relnames) = @_;
+
+	croak "dbname must be specified" unless defined $dbname;
+	croak "relnames must be defined" unless scalar(grep { defined $_ } @relnames);
+	croak "snapname must be specified" unless defined $snapname;
+	croak "snapname must be unique" if exists $self->{snapshot}->{$snapname};
+
+	my $pgdata = $self->data_dir;
+	my $snapdir = $self->relfile_snapshot_directory($snapname);
+	croak "snapname directory name already in use: $snapdir" if (-e $snapdir);
+	mkdir $snapdir
+		or BAIL_OUT("could not create snapshot directory \"$snapdir\": $!");
+
+	my @relpaths = map {
+		$self->safe_psql($dbname,
+			qq(SELECT pg_relation_filepath('$_')));
+	} @relnames;
+
+	my (@toastpaths, @idxpaths);
+	if ($extended)
+	{
+		for my $relname (@relnames)
+		{
+			push (@toastpaths, grep /\w/, split(/(?:\s*\r?\n\s*)+/, $self->safe_psql($dbname,
+				qq(SELECT pg_relation_filepath(c.reltoastrelid)
+					FROM pg_catalog.pg_class c
+					WHERE c.oid = '$relname'::regclass
+					AND c.reltoastrelid != 0::oid))));
+			push (@idxpaths, grep /\w/, split(/(?:\s*\r?\n\s*)+/, $self->safe_psql($dbname,
+				qq(SELECT pg_relation_filepath(i.indexrelid)
+					FROM pg_catalog.pg_index i
+					WHERE i.indrelid = '$relname'::regclass))));
+		}
+	}
+
+	$self->{snapshot}->{$snapname} = {};
+	for my $path (@relpaths, grep { defined($_) } @toastpaths, @idxpaths)
+	{
+		croak "file backing relation is missing: $pgdata/$path" unless -f "$pgdata/$path";
+		copy_file($snapdir, $pgdata, 0, $path);
+		$self->{snapshot}->{$snapname}->{$path} = 1;
+	}
+}
+
+=pod
+
+=item $node->revert_to_snapshot($self, $snapname)
+
+Overwrites the database's relation files with files previously saved in
+B<$snapname>.
+
+Dies if the given B<$snapname> does not exist.
+
+=cut
+
+=pod
+
+=item $node->revert_to_torn_relfile_snapshot($self, $snapname, $bytes)
+
+Partially overwrites the database's relation files using prefixes of the given
+number of bytes from the files saved in B<$snapname>.  If B<$bytes> is
+negative, uses suffixes of the given byte length rather than prefixes.
+
+If B<$bytes> is null, replaces the database's relation files using the saved
+files in the B<$snapname>, which unlike for non-undef values, means the file
+may become shorter if the saved file is shorter than the current file.
+
+=cut
+
+sub revert_to_snapshot
+{
+	my ($self, $snapname) = @_;
+	$self->revert_to_torn_relfile_snapshot($snapname, undef);
+}
+
+sub revert_to_torn_relfile_snapshot
+{
+	my ($self, $snapname, $bytes) = @_;
+
+	croak "no such snapshot" unless exists $self->{snapshot}->{$snapname};
+
+	my $pgdata = $self->data_dir;
+	my $snaprepo = join('/', $self->relfile_snapshot_repository, $snapname);
+	croak "snapname directory missing: $snaprepo" unless (-d $snaprepo);
+
+	if (defined $bytes)
+	{
+		tear_file($pgdata, $snaprepo, $bytes, $_)
+			for (keys %{$self->{snapshot}->{$snapname}});
+	}
+	else
+	{
+		copy_file($pgdata, $snaprepo, 1, $_)
+			for (keys %{$self->{snapshot}->{$snapname}});
+	}
+}
+
+sub copy_file
+{
+	my ($dstdir, $srcdir, $overwrite, $path) = @_;
+
+	croak "No such directory: $dstdir" unless -d $dstdir;
+	croak "No such directory: $srcdir" unless -d $srcdir;
+
+	foreach my $part (split(m{/}, $path))
+	{
+		my $srcpart = "$srcdir/$part";
+		my $dstpart = "$dstdir/$part";
+
+		if (-d $srcpart)
+		{
+			$srcdir = $srcpart;
+			$dstdir = $dstpart;
+			die "$dstdir is in the way" if (-e $dstdir && ! -d $dstdir);
+			unless (-d $dstdir)
+			{
+				mkdir $dstdir
+					or BAIL_OUT("could not create directory \"$dstdir\": $!");
+			}
+		}
+		elsif (-f $srcpart)
+		{
+			die "$dstdir/$part is in the way" if (!$overwrite && -e "$dstdir/$part");
+
+			File::Copy::copy($srcpart, "$dstdir/$part");
+		}
+	}
+}
+
+sub tear_file
+{
+	my ($dstdir, $srcdir, $bytes, $path) = @_;
+
+	croak "No such directory: $dstdir" unless -d $dstdir;
+	croak "No such directory: $srcdir" unless -d $srcdir;
+
+	my $srcfile = "$srcdir/$path";
+	my $dstfile = "$dstdir/$path";
+
+	croak "No such file: $srcfile" unless -f $srcfile;
+	croak "No such file: $dstfile" unless -f $dstfile;
+
+	my ($srcfh, $dstfh);
+	open($srcfh, '<', $srcfile) or die "Cannot read $srcfile: $!";
+	open($dstfh, '+<', $dstfile) or die "Cannot modify $dstfile: $!";
+	binmode($srcfh);
+	binmode($dstfh);
+
+	my $buffer;
+	if ($bytes < 0)
+	{
+		$bytes *= -1;		# Easier to use positive value
+		my $srcsize = (stat($srcfh))[7];
+		my $offset = $srcsize - $bytes;
+		seek($srcfh, $offset, 0) or die "seek failed: $!";
+		seek($dstfh, $offset, 0) or die "seek failed: $!";
+		defined(sysread($srcfh, $buffer, $bytes))
+			or die "sysread failed: $!";
+		defined(syswrite($dstfh, $buffer, $bytes))
+			or die "syswrite failed: $!";
+	}
+	else
+	{
+		seek($srcfh, 0, 0) or die "seek failed: $!";
+		seek($dstfh, 0, 0) or die "seek failed: $!";
+		defined(sysread($srcfh, $buffer, $bytes))
+			or die "sysread failed: $!";
+		defined(syswrite($dstfh, $buffer, $bytes))
+			or die "syswrite failed: $!";
+	}
+
+	close($srcfh);
+	close($dstfh);
+}
+
+=pod
+
+=back
+
 =cut
 
 1;
-- 
2.21.1 (Apple Git-122.3)