More vulnerability fixes

conf/pg_config.dist.yml

@@ -187,9 +187,7 @@ options:
 modules:
   - [Encode]
   - ['Encode::Encoding']
-  - ['HTML::Parser']
   - ['HTML::Entities']
-  - [DynaLoader]
   - [Exporter]
   - [GD]
   - [utf8]
@@ -233,7 +231,6 @@ modules:
   - ['Locale::Maketext']
   - ['WeBWorK::PG::Localize']
   - ['Mojo::JSON']
-  - ['IO::Handle']
   - ['Rserve']
   - [DragNDrop]
   - ['Types::Serialiser']

lib/AnswerHash.pm

@@ -594,7 +594,7 @@ sub evaluate {
 	}
 	$rh_ans = $self->dereference_array_ans($rh_ans);
 	# make sure that the student answer is not an array so that it is reported correctly in answer section.
-	eval(q!main::DEBUG_MESSAGE( `<h4>final result: </h4>`, pretty_print($rh_ans,'html'))!)
+	eval(q!main::DEBUG_MESSAGE('<h4>final result: </h4>', pretty_print($rh_ans,'html'))!)
 		if defined($self->{debug})
 		and $self->{debug} > 0;
 	# re-reference $rh_ans;

lib/PGalias.pm

@@ -211,8 +211,14 @@ sub alias_for_tex {
 	} elsif ($file_path =~ m|^$self->{htmlDirectory}|) {
 		# File is in the course html directory.
 		$resource_object->path($aux_file_id);
-	} else {
+	} elsif (WeBWorK::PG::IO::path_is_subdir(
+		$file_path, $WeBWorK::PG::IO::pg_envir->{directories}{permitted_read_dir}, 1
+	))
+	{
 		$resource_object->path($file_path);
+	} else {
+		$self->warning_message(qq{Unable to use the file "$file_path" because it is an unsafe path.});
+		return '';
 	}
 
 	if ($ext eq 'gif' || $ext eq 'svg') {

lib/PGloadfiles.pm

@@ -209,6 +209,11 @@ sub compile_file {
 	my $self     = shift;
 	my $filePath = shift;
 
+	# Only allow compilation of files that are in the macros path.
+	my @allowedDirs = map { $_ eq '.' ? $WeBWorK::PG::IO::pwd : $_ } @{ $WeBWorK::PG::IO::macrosPath // [] };
+	die "Refusing to compile $filePath as it is not located in an allowed location.\n"
+		unless grep { WeBWorK::PG::IO::path_is_subdir($filePath, $_) } @allowedDirs;
+
 	warn "loading $filePath" if $debugON;
 
 	local $/ = undef;    # allows us to treat the file as a single line

lib/Rserve.pm

@@ -49,6 +49,17 @@ sub new {
 
 	$self->{_autoflush} //= 1;
 
+	# When no filehandle was already supplied (i.e. a new connection is about to be opened), the host to connect to is
+	# always taken from the trusted PG environment configuration, never from whatever server/port a caller passed to
+	# this constructor. A problem source file or macro file cannot override this, since $WeBWorK::PG::IO::pg_envir is
+	# not visible to safe compartment code.
+	if (!defined $self->{fh} && defined $WeBWorK::PG::IO::pg_envir) {
+		my $host = $WeBWorK::PG::IO::pg_envir->{specialPGEnvironmentVars}{Rserve}{host};
+		croak 'Rserve is not configured' unless $host;
+		$self->{server} = $host;
+		$self->{port}   = $WeBWorK::PG::IO::pg_envir->{specialPGEnvironmentVars}{Rserve}{port} // 6311;
+	}
+
 	$self->{server} //= 'localhost';
 	die q{Attribute 'server' must be scalar value}
 		if exists($self->{server}) && (!defined $self->server || ref($self->server));

lib/WWSafe.pm

@@ -265,6 +265,33 @@ sub share_from {
 	$obj->share_record($pkg, $vars) unless $no_record or !$vars;
 }
 
+# Creates an empty package stash named $name directly under the compartment's root. This is not connected to any real
+# package. This is for packages that must exist so Perl's method resolution can walk through them (e.g. a shared
+# module's @ISA lists a package that must be resolvable, even though none of its actual methods should be reachable from
+# the compartment) without sharing that package's real contents.
+sub share_empty_package {
+	my ($obj, $name) = @_;
+	my $root = $obj->root();
+	no strict 'refs';
+	*{"${root}::${name}::"} = {};
+	return;
+}
+
+# Aliases $name, as seen from inside the compartment, to a real package's symbol table, rather than to whatever real
+# package happens to be named $name outside the compartment. Unlike share_from, which shares specific symbols but leaves
+# bless and method resolution for a class needing a fresh bless from code running nested inside a live reval
+# unresolvable unless that exact class name is itself an alias to a real package's symbol table, this lets $source_pkg
+# (e.g. a small, narrow package built on purpose) stand in for $name so that such a bless resolves correctly, without
+# exposing $name's real, unrestricted contents.
+sub share_package_as {
+	my ($obj, $name, $source_pkg) = @_;
+	my $root = $obj->root();
+	no strict 'refs';
+	croak("Package \"$source_pkg\" does not exist") unless keys %{"$source_pkg\::"};
+	*{"${root}::${name}::"} = \%{"${source_pkg}::"};
+	return;
+}
+
 sub share_record {
 	my $obj    = shift;
 	my $pkg    = shift;

lib/WeBWorK/PG.pm

@@ -192,6 +192,23 @@ sub defineProblemEnvironment ($pg_envir, $options = {}) {
 	$specialPGEnvironmentVars->{$_} = $options->{specialPGEnvironmentVars}{$_}
 		for keys %{ $options->{specialPGEnvironmentVars} };
 
+	# Save the macrosPath array and problem directory into WeBWorK::PG::IO. This is never exposed into the safe
+	# compartment. So PGloadfiles::compile_file can use it to ensure it is not asked to compile files elsewhere.
+
+	# The contents of the $macrosPath array must be copied. $macrosPath itself is shared to the safe compartment,
+	# and problem code can change its contents. So a reference is not sufficient.
+	my $macrosPath = $options->{macrosPath} // $pg_envir->{directories}{macrosPath};
+	$WeBWorK::PG::IO::macrosPath = [@$macrosPath];
+
+	# This is the same $pwd construction that PGloadfiles.pm uses.
+	my $probFileName      = $options->{sourceFilePath}    // '';
+	my $templateDirectory = $options->{templateDirectory} // '';
+	my $pwd               = $probFileName;
+	$pwd =~ s!/[^/]*$!!;
+	$pwd = $templateDirectory . $pwd unless substr($pwd, 0, 1) eq '/';
+	$pwd =~ s!/tmpEdit/!/!;
+	$WeBWorK::PG::IO::pwd = $pwd;
+
 	return {
 		# This copies everything from the provided options that are not explicitly dealt with below.
 		# With this the caller can add any desired key value pairs to the translator environment.
@@ -202,7 +219,7 @@ sub defineProblemEnvironment ($pg_envir, $options = {}) {
 		# value, or just hard coded defaults.
 
 		# Problem information
-		probFileName       => $options->{sourceFilePath}                                // '',
+		probFileName       => $probFileName,
 		displayMode        => DISPLAY_MODES()->{ $options->{displayMode} || 'MathJax' } // 'HTML_MathJax',
 		problemSeed        => $options->{problemSeed} || 1234,
 		psvn               => $options->{psvn}               // 1,
@@ -243,14 +260,14 @@ sub defineProblemEnvironment ($pg_envir, $options = {}) {
 
 		# Directories and URLs
 		pgMacrosDir       => "$pg_envir->{directories}{root}/macros",
-		macrosPath        => $options->{macrosPath}        // $pg_envir->{directories}{macrosPath},
-		htmlPath          => $options->{htmlPath}          // $pg_envir->{URLs}{htmlPath},
-		imagesPath        => $options->{imagesPath}        // $pg_envir->{URLs}{imagesPath},
-		htmlDirectory     => $options->{htmlDirectory}     // "$pg_envir->{directories}{html}/",
-		htmlURL           => $options->{htmlURL}           // "$pg_envir->{URLs}{html}/",
-		templateDirectory => $options->{templateDirectory} // '',
-		tempURL           => $options->{tempURL}           // "$pg_envir->{URLs}{tempURL}/",
-		localHelpURL      => $options->{localHelpURL}      // "$pg_envir->{URLs}{localHelpURL}/",
+		macrosPath        => $macrosPath,
+		htmlPath          => $options->{htmlPath}      // $pg_envir->{URLs}{htmlPath},
+		imagesPath        => $options->{imagesPath}    // $pg_envir->{URLs}{imagesPath},
+		htmlDirectory     => $options->{htmlDirectory} // "$pg_envir->{directories}{html}/",
+		htmlURL           => $options->{htmlURL}       // "$pg_envir->{URLs}{html}/",
+		templateDirectory => $templateDirectory,
+		tempURL           => $options->{tempURL}      // "$pg_envir->{URLs}{tempURL}/",
+		localHelpURL      => $options->{localHelpURL} // "$pg_envir->{URLs}{localHelpURL}/",
 
 		# Other things ...
 

lib/WeBWorK/PG/IO.pm

@@ -300,6 +300,10 @@ sub remove_tree {
 sub path_is_subdir {
 	my ($path, $dir, $allow_relative) = @_;
 
+	# An empty or undefined $dir normalizes via canonpath to '/', which every absolute path matches,
+	# turning "restrict to this directory" into "allow anything". Reject up front instead.
+	return 0 unless defined $dir && $dir ne '';
+
 	unless ($path =~ /^\//) {
 		if ($allow_relative) {
 			$path = "$dir/$path";

lib/WeBWorK/PG/SafeGD.pm

@@ -0,0 +1,99 @@
+package WeBWorK::PG::SafeGD;
+
+=head1 NAME
+
+WeBWorK::PG::SafeGD - Restrict GD::Image new method file path arguments to
+permitted_read_dir.
+
+=head1 DESCRIPTION
+
+GD is shared into the safe compartment for graphing macros (via WWPlot and the
+PGgraphmacros.pl macro). Several of the GD::Image methods take a file path
+argument and open it directly, with no restriction (C<new>, C<newFromPng>,
+C<newFromJpeg>, C<newFromGif>, C<newFromTiff>, C<newFromXbm>, C<newFromWebp>,
+C<newFromHeif>, C<newFromWBMP>, C<newFromBmp>, C<newFromGd>, C<newFromGd2>,
+C<newFromGd2Part>, and C<newFromXpm>). The C<restrict> method in this package
+ensures that if those methods are called on an unsafe path (a path not in the
+C<permitted_read_dir>), the methods do not reveal anything about the existence
+or lack thereof for the file path argument. The C<WWPlot> package does not use
+these path-taking forms (only the numeric-size constructor is used).
+
+C<restrict> patches the GD::Image symbol table in place, so it only needs to run
+once per process, after GD itself has been loaded.
+
+=cut
+
+use strict;
+use warnings;
+
+use WeBWorK::PG::IO;
+
+my $patched = 0;
+
+# Only reject arguments that look like they're meant to be a path (a plain string, not an
+# already-open filehandle/IO object) and that GD would otherwise try to open unrestricted.
+sub _unsafe_path {
+	my $path = shift;
+	return 0 if ref $path;
+	return 0 unless defined $path && length $path;
+	return !WeBWorK::PG::IO::path_is_subdir($path, $WeBWorK::PG::IO::pg_envir->{directories}{permitted_read_dir});
+}
+
+sub restrict {
+	return if $patched || !GD::Image->can('_make_filehandle');
+	$patched = 1;
+
+	no warnings qw(redefine prototype);
+
+	# Every newFrom* method implemented in GD/Image.pm other than the XS methods (Png, Jpeg, Gif, Tiff, Xbm, Webp, Heif,
+	# WBMP, and Bmp) call _make_filehandle. The new method does as well, but is wrapped separately below, since it
+	# touches the filesystem before calling this.
+	my $orig_make_filehandle = \&GD::Image::_make_filehandle;
+	*GD::Image::_make_filehandle = sub {
+		die "GD: refusing to open \"$_[1]\" as it is not in an allowed location.\n" if _unsafe_path($_[1]);
+		goto &$orig_make_filehandle;
+	};
+
+	# The single argument form of new executes -f tests on the given file path argument before it calls
+	# _make_filehandle. Skip the check only when the argument is recognized as raw image data rather than a path at all,
+	# since then no file access happens anywhere. Otherwise $! is set for non-existent files, and so this can be used
+	# for a file existence test in a problem.
+	my $orig_new = \&GD::Image::new;
+	*GD::Image::new = sub {
+		die "GD: refusing to open \"$_[1]\" as it is not in an allowed location.\n"
+			if @_ == 2 && !ref $_[1] && !GD::Image::_image_type($_[1]) && _unsafe_path($_[1]);
+		goto &$orig_new;
+	};
+
+	# These are implemented in XS and take a file path directly, bypassing _make_filehandle.
+	no strict 'refs';
+	for my $method (qw(newFromGd newFromGd2 newFromGd2Part newFromXpm)) {
+		next unless GD::Image->can($method);
+		my $orig = \&{"GD::Image::$method"};
+		*{"GD::Image::$method"} = sub {
+			die "GD: refusing to open \"$_[1]\" as it is not in an allowed location.\n" if _unsafe_path($_[1]);
+			goto &$orig;
+		};
+	}
+	use strict 'refs';
+
+	# stringFT's font file argument is only restricted when it looks like an absolute path, since it may legitimately be
+	# a relative name or fontconfig pattern (e.g. after useFontConfig) instead of a path.
+	if (GD::Image->can('stringFT')) {
+		my $orig_string_ft = \&GD::Image::stringFT;
+		*GD::Image::stringFT = sub {
+			die "GD: refusing to open \"$_[2]\" as it is not in an allowed location.\n"
+				if defined $_[2] && !ref $_[2] && $_[2] =~ m{^/} && _unsafe_path($_[2]);
+			goto &$orig_string_ft;
+		};
+		# stringTTF is a plain alias for stringFT set up when GD::Image was loaded, so it still points
+		# to the original, unwrapped sub unless it is re-aliased here.
+		*GD::Image::stringTTF = \&GD::Image::stringFT;
+	}
+
+	use warnings qw(redefine prototype);
+
+	return;
+}
+
+1;

lib/WeBWorK/PG/SafeIOHandle.pm

@@ -0,0 +1,32 @@
+package WeBWorK::PG::SafeIOHandle;
+
+=head1 NAME
+
+WeBWorK::PG::SafeIOHandle - A restricted stand-in for IO::Handle, shared into
+the safe compartment.
+
+=head1 DESCRIPTION
+
+L<Rserve> blesses its connection socket as an L<IO::Handle> and uses its
+C<print>, C<flush>, C<read>, and C<close> methods. If the C<IO::Handle> package
+is shared directly, then all of its methods are exposed. In particular the
+C<new_from_fd> method is exposed (in addition to other potentially dangerous
+methods such as C<new>, C<fdopen>, etc.) which allows a PG problem to wrap and
+read from or write to any file descriptor the process happens to have open. So
+instead this package is shared aliased as the C<IO::Handle> package (via
+C<WWSafe::share_package_as>) exposing only the necessary methods.
+
+=cut
+
+use strict;
+use warnings;
+
+use IO::Handle;
+
+BEGIN {
+	no strict 'refs';
+	*{"WeBWorK::PG::SafeIOHandle::$_"} = \&{"IO::Handle::$_"} for qw(print flush read close);
+	use strict 'refs';
+}
+
+1;

lib/WeBWorK/PG/Translator.pm

@@ -56,6 +56,8 @@ use Mojo::DOM;
 use WWSafe;
 use PGUtil          qw(pretty_print);
 use WeBWorK::PG::IO qw(fileFromPath);
+use WeBWorK::PG::SafeIOHandle;
+use WeBWorK::PG::SafeGD;
 
 BEGIN {
 	# Setup the safe compartment for the standalone renderer.
@@ -91,6 +93,15 @@ BEGIN {
 
 		$safeCache->share_from('main', $ra_included_modules);
 
+		# GD's @ISA includes DynaLoader (a common pattern for older XS modules), and so Perl's method resolution needs a
+		# "DynaLoader" package to be resolvable for anything that inherits from GD (e.g. WWPlot).  Share an empty stash
+		# rather than the real DynaLoader package, which would let any PG problem bootstrap and call into the raw XS
+		# functions of any installed shared library directly.
+		$safeCache->share_empty_package('DynaLoader');
+
+		# Restrict the GD::Image methods that take a file path argument (new, newFromPng, etc.).
+		WeBWorK::PG::SafeGD::restrict();
+
 		my $store_mask = $safeCache->mask();
 		$safeCache->mask(Opcode::empty_opset());
 		my $safe_cmpt_package_name = $safeCache->root();
@@ -233,6 +244,9 @@ The following translator methods are shared to the safe compartment:
 
 Also all methods that are exported by WeBWorK::PG::IO are shared.
 
+The compartment's view of IO::Handle is aliased to WeBWorK::PG::SafeIOHandle
+which is a restricted stand-in.
+
 In addition the environment hash C<%envir> is shared.  This variable is unpacked
 when PG.pl is run.
 
@@ -255,6 +269,13 @@ sub initialize {
 	$safe_cmpt->share_from('WeBWorK::PG::Translator', \@Translator_shared_subroutine_array);
 	$safe_cmpt->share_from('WeBWorK::PG::IO',         \@WeBWorK::PG::IO::EXPORT_OK);
 
+	# The Rserve package blesses its connection socket as an IO::Handle. So the WeBWorK::PG::SafeIOHandle package which
+	# aliases only print/flush/read/close from the IO::Handle package is shared as an alias to the IO::Handle package
+	# rather than sharing the IO::Handle package itself. Sharing the entire IO::Handle package would expose
+	# IO::Handle->new_from_fd(FD, MODE), and that would let a PG problem wrap and read or write to any file descriptor
+	# number the process happens to have open.
+	$safe_cmpt->share_package_as('IO::Handle', 'WeBWorK::PG::SafeIOHandle');
+
 	no strict;
 	local (%envir) = %{ $self->{envir} };
 	$safe_cmpt->share('%envir');
@@ -265,6 +286,10 @@ sub initialize {
 	# The standalone renderer does this when the module is compiled.
 	unless (exists($ENV{MOJO_MODE})) {
 		$safe_cmpt->share_from('main', $self->{ra_included_modules});
+		$safe_cmpt->share_empty_package('DynaLoader');
+
+		# Restrict the GD::Image methods that take a file path argument (new, newFromPng, etc.).
+		WeBWorK::PG::SafeGD::restrict();
 	}
 
 	return;
@@ -497,7 +522,7 @@ sub set_mask {
 	# Just to make sure, deny some things specifically.
 	$safe_cmpt->deny(qw(entereval));
 	$safe_cmpt->deny(qw(unlink symlink system exec));
-	$safe_cmpt->deny(qw(print require));
+	$safe_cmpt->deny(qw(print prtf require));
 	return;
 }
 

macros/core/RserveClient.pl

@@ -181,7 +181,7 @@ =head2 rserve_data_url
 
 sub _RserveClient_init { }
 
-my $rserve;    # Statistics::R::IO::Rserve instance
+my $rserve;    # Rserve instance
 
 sub _rserve_warn_no_config {
 	my @trace      = split /\n/, Value::traceback();

t/rserve/rserve-eval-live.t

@@ -22,6 +22,10 @@ use TestCases qw(TEST_CASES);
 # Fake configuration if this is disabled (it is by default in pg_config.dist.yml).
 $main::Rserve = { host => 'localhost' } unless ref($main::Rserve) eq 'HASH' && $main::Rserve->{host};
 
+# The actual host used to connect is read from $WeBWorK::PG::IO::pg_envir
+# (a trusted server configuration), not from $main::Rserve.
+$WeBWorK::PG::IO::pg_envir->{specialPGEnvironmentVars}{Rserve} = $main::Rserve;
+
 my $s;
 eval {
 	socket($s, PF_INET, SOCK_STREAM, getprotobyname('tcp'))          or die "socket: $!";