Back-port CVE fixes from 14.14 PostgreSQL

doc/src/sgml/plperl.sgml

@@ -1082,6 +1082,19 @@ $$ LANGUAGE plperl;
    be permitted to use this language.
   </para>
 
+  <warning>
+   <para>
+    Trusted PL/Perl relies on the Perl <literal>Opcode</literal> module to
+    preserve security.
+    Perl
+    <ulink url="https://perldoc.perl.org/Opcode#WARNING">documents</ulink>
+    that the module is not effective for the trusted PL/Perl use case.  If
+    your security needs are incompatible with the uncertainty in that warning,
+    consider executing <literal>REVOKE USAGE ON LANGUAGE plperl FROM
+    PUBLIC</literal>.
+   </para>
+  </warning>
+
   <para>
    Here is an example of a function that will not work because file
    system operations are not allowed for security reasons:

src/backend/executor/functions.c

@@ -2120,6 +2120,12 @@ check_sql_fn_retval(List *queryTreeLists,
 		rtr->rtindex = 1;
 		newquery->jointree = makeFromExpr(list_make1(rtr), NULL);
 
+		/*
+		 * Make sure the new query is marked as having row security if the
+		 * original one does.
+		 */
+		newquery->hasRowSecurity = parse->hasRowSecurity;
+
 		/* Replace original query in the correct element of the query list */
 		lfirst(parse_cell) = newquery;
 	}

src/backend/rewrite/rewriteHandler.c

@@ -59,6 +59,12 @@ typedef struct acquireLocksOnSubLinks_context
 	bool		for_execute;	/* AcquireRewriteLocks' forExecute param */
 } acquireLocksOnSubLinks_context;
 
+typedef struct fireRIRonSubLink_context
+{
+	List	   *activeRIRs;
+	bool		hasRowSecurity;
+} fireRIRonSubLink_context;
+
 static bool acquireLocksOnSubLinks(Node *node,
 								   acquireLocksOnSubLinks_context *context);
 static Query *rewriteRuleAction(Query *parsetree,
@@ -1910,6 +1916,12 @@ ApplyRetrieveRule(Query *parsetree,
 	 */
 	rule_action = fireRIRrules(rule_action, activeRIRs);
 
+	/*
+	 * Make sure the query is marked as having row security if the view query
+	 * does.
+	 */
+	parsetree->hasRowSecurity |= rule_action->hasRowSecurity;
+
 	/*
 	 * Now, plug the view query in as a subselect, converting the relation's
 	 * original RTE to a subquery RTE.
@@ -2021,7 +2033,7 @@ markQueryForLocking(Query *qry, Node *jtnode,
  * the SubLink's subselect link with the possibly-rewritten subquery.
  */
 static bool
-fireRIRonSubLink(Node *node, List *activeRIRs)
+fireRIRonSubLink(Node *node, fireRIRonSubLink_context *context)
 {
 	if (node == NULL)
 		return false;
@@ -2031,7 +2043,13 @@ fireRIRonSubLink(Node *node, List *activeRIRs)
 
 		/* Do what we came for */
 		sub->subselect = (Node *) fireRIRrules((Query *) sub->subselect,
-											   activeRIRs);
+											   context->activeRIRs);
+
+		/*
+		 * Remember if any of the sublinks have row security.
+		 */
+		context->hasRowSecurity |= ((Query *) sub->subselect)->hasRowSecurity;
+
 		/* Fall through to process lefthand args of SubLink */
 	}
 
@@ -2040,7 +2058,7 @@ fireRIRonSubLink(Node *node, List *activeRIRs)
 	 * subselects of subselects for us.
 	 */
 	return expression_tree_walker(node, fireRIRonSubLink,
-								  (void *) activeRIRs);
+								  (void *) context);
 }
 
 
@@ -2101,6 +2119,13 @@ fireRIRrules(Query *parsetree, List *activeRIRs)
 		if (rte->rtekind == RTE_SUBQUERY || rte->rtekind == RTE_TABLEFUNCTION)
 		{
 			rte->subquery = fireRIRrules(rte->subquery, activeRIRs);
+
+			/*
+			 * While we are here, make sure the query is marked as having row
+			 * security if any of its subqueries do.
+			 */
+			parsetree->hasRowSecurity |= rte->subquery->hasRowSecurity;
+
 			continue;
 		}
 
@@ -2218,16 +2243,35 @@ fireRIRrules(Query *parsetree, List *activeRIRs)
 
 		cte->ctequery = (Node *)
 			fireRIRrules((Query *) cte->ctequery, activeRIRs);
+
+		/*
+		 * While we are here, make sure the query is marked as having row
+		 * security if any of its CTEs do.
+		 */
+		parsetree->hasRowSecurity |= ((Query *) cte->ctequery)->hasRowSecurity;
 	}
 
 	/*
 	 * Recurse into sublink subqueries, too.  But we already did the ones in
 	 * the rtable and cteList.
 	 */
 	if (parsetree->hasSubLinks)
-		query_tree_walker(parsetree, fireRIRonSubLink, (void *) activeRIRs,
+	{
+		fireRIRonSubLink_context context;
+
+		context.activeRIRs = activeRIRs;
+		context.hasRowSecurity = false;
+
+		query_tree_walker(parsetree, fireRIRonSubLink, (void *) &context,
 						  QTW_IGNORE_RC_SUBQUERIES);
 
+		/*
+		 * Make sure the query is marked as having row security if any of its
+		 * sublinks do.
+		 */
+		parsetree->hasRowSecurity |= context.hasRowSecurity;
+	}
+
 	/*
 	 * Apply any row-level security policies.  We do this last because it
 	 * requires special recursion detection if the new quals have sublink
@@ -2266,6 +2310,7 @@ fireRIRrules(Query *parsetree, List *activeRIRs)
 			if (hasSubLinks)
 			{
 				acquireLocksOnSubLinks_context context;
+				fireRIRonSubLink_context fire_context;
 
 				/*
 				 * Recursively process the new quals, checking for infinite
@@ -2296,11 +2341,21 @@ fireRIRrules(Query *parsetree, List *activeRIRs)
 				 * Now that we have the locks on anything added by
 				 * get_row_security_policies, fire any RIR rules for them.
 				 */
+				fire_context.activeRIRs = activeRIRs;
+				fire_context.hasRowSecurity = false;
+
 				expression_tree_walker((Node *) securityQuals,
-									   fireRIRonSubLink, (void *) activeRIRs);
+									   fireRIRonSubLink, (void *) &fire_context);
 
 				expression_tree_walker((Node *) withCheckOptions,
-									   fireRIRonSubLink, (void *) activeRIRs);
+									   fireRIRonSubLink, (void *) &fire_context);
+
+				/*
+				 * We can ignore the value of fire_context.hasRowSecurity
+				 * since we only reach this code in cases where hasRowSecurity
+				 * is already true.
+				 */
+				Assert(hasRowSecurity);
 
 				activeRIRs = list_delete_last(activeRIRs);
 			}

src/pl/plperl/GNUmakefile

@@ -55,11 +55,11 @@ endif # win32
 
 SHLIB_LINK = $(perl_embed_ldflags)
 
-REGRESS_OPTS = --dbname=$(PL_TESTDB)
+REGRESS_OPTS = --dbname=$(PL_TESTDB) --dlpath=$(top_builddir)/src/test/regress
 REGRESS_OPTS += --init-file=init_file
 REGRESS = plperl_setup plperl plperl_lc plperl_trigger plperl_shared \
 	plperl_elog plperl_util plperl_init plperlu plperl_array \
-	plperl_call plperl_transaction
+	plperl_call plperl_transaction plperl_env
 # if Perl can support two interpreters in one backend,
 # test plperl-and-plperlu cases
 ifneq ($(PERL),)
@@ -130,6 +130,7 @@ submake:
 
 clean distclean maintainer-clean: clean-lib
 	rm -f SPI.c Util.c $(OBJS) perlchunks.h plperl_opmask.h
+	rm -f sql/plperl_env.sql expected/plperl_env.out
 	rm -rf $(pg_regress_clean_files)
 ifeq ($(PORTNAME), win32)
 	rm -f $(perlwithver).def

src/pl/plperl/expected/.gitignore

@@ -0,0 +1 @@
+/plperl_env.out

src/pl/plperl/input/plperl_env.source

@@ -0,0 +1,55 @@
+--
+-- Test the environment setting
+--
+
+CREATE FUNCTION get_environ()
+   RETURNS text[]
+   AS '@libdir@/regress@DLSUFFIX@', 'get_environ'
+   LANGUAGE C STRICT;
+
+-- fetch the process environment
+
+CREATE FUNCTION process_env () RETURNS text[]
+LANGUAGE plpgsql AS
+$$
+
+declare
+   res text[];
+   tmp text[];
+   f record;
+begin
+    for f in select unnest(get_environ()) as t loop
+         tmp := regexp_split_to_array(f.t, '=');
+         if array_length(tmp, 1) = 2 then
+            res := res || tmp;
+         end if;
+    end loop;
+    return res;
+end
+
+$$;
+
+-- plperl should not be able to affect the process environment
+
+DO
+$$
+   $ENV{TEST_PLPERL_ENV_FOO} = "shouldfail";
+   untie %ENV;
+   $ENV{TEST_PLPERL_ENV_FOO} = "testval";
+   my $penv = spi_exec_query("select unnest(process_env()) as pe");
+   my %received;
+   for (my $f = 0; $f < $penv->{processed}; $f += 2)
+   {
+      my $k = $penv->{rows}[$f]->{pe};
+      my $v = $penv->{rows}[$f+1]->{pe};
+      $received{$k} = $v;
+   }
+   unless (exists $received{TEST_PLPERL_ENV_FOO})
+   {
+      elog(NOTICE, "environ unaffected")
+   }
+
+$$ LANGUAGE plperl;
+
+-- clean up to simplify cross-version upgrade testing
+DROP FUNCTION get_environ();

src/pl/plperl/output/plperl_env.source

@@ -0,0 +1,51 @@
+--
+-- Test the environment setting
+--
+CREATE FUNCTION get_environ()
+   RETURNS text[]
+   AS '@libdir@/regress@DLSUFFIX@', 'get_environ'
+   LANGUAGE C STRICT;
+-- fetch the process environment
+CREATE FUNCTION process_env () RETURNS text[]
+LANGUAGE plpgsql AS
+$$
+
+declare
+   res text[];
+   tmp text[];
+   f record;
+begin
+    for f in select unnest(get_environ()) as t loop
+         tmp := regexp_split_to_array(f.t, '=');
+         if array_length(tmp, 1) = 2 then
+            res := res || tmp;
+         end if;
+    end loop;
+    return res;
+end
+
+$$;
+-- plperl should not be able to affect the process environment
+DO
+$$
+   $ENV{TEST_PLPERL_ENV_FOO} = "shouldfail";
+   untie %ENV;
+   $ENV{TEST_PLPERL_ENV_FOO} = "testval";
+   my $penv = spi_exec_query("select unnest(process_env()) as pe");
+   my %received;
+   for (my $f = 0; $f < $penv->{processed}; $f += 2)
+   {
+      my $k = $penv->{rows}[$f]->{pe};
+      my $v = $penv->{rows}[$f+1]->{pe};
+      $received{$k} = $v;
+   }
+   unless (exists $received{TEST_PLPERL_ENV_FOO})
+   {
+      elog(NOTICE, "environ unaffected")
+   }
+
+$$ LANGUAGE plperl;
+WARNING:  attempted alteration of $ENV{TEST_PLPERL_ENV_FOO} at line 12.
+NOTICE:  environ unaffected
+-- clean up to simplify cross-version upgrade testing
+DROP FUNCTION get_environ();

src/pl/plperl/plc_trusted.pl

@@ -30,3 +30,27 @@ package PostgreSQL::InServer::safe; ## no critic (RequireFilenameMatchesPackage)
 require Carp::Heavy;
 require warnings;
 require feature if $] >= 5.010000;
+
+#<<< protect next line from perltidy so perlcritic annotation works
+package PostgreSQL::InServer::WarnEnv; ## no critic (RequireFilenameMatchesPackage)
+#>>>
+
+use strict;
+use warnings;
+use Tie::Hash;
+our @ISA = qw(Tie::StdHash);
+
+sub STORE  { warn "attempted alteration of \$ENV{$_[1]}"; }
+sub DELETE { warn "attempted deletion of \$ENV{$_[1]}"; }
+sub CLEAR  { warn "attempted clearance of ENV hash"; }
+
+# Remove magic property of %ENV. Changes to this will now not be reflected in
+# the process environment.
+*main::ENV = {%ENV};
+
+# Block %ENV changes from trusted PL/Perl, and warn. We changed %ENV to just a
+# normal hash, yet the application may be expecting the usual Perl %ENV
+# magic. Blocking and warning avoids silent application breakage. The user can
+# untie or otherwise disable this, e.g. if the lost mutation is unimportant
+# and modifying the code to stop that mutation would be onerous.
+tie %main::ENV, 'PostgreSQL::InServer::WarnEnv', %ENV or die $!;

src/pl/plperl/sql/.gitignore

@@ -0,0 +1 @@
+/plperl_env.sql