diff --git a/conf/pg_config.dist.yml b/conf/pg_config.dist.yml index 513ecd203..1872cae53 100644 --- a/conf/pg_config.dist.yml +++ b/conf/pg_config.dist.yml @@ -189,7 +189,6 @@ modules: - ['Encode::Encoding'] - ['HTML::Parser'] - ['HTML::Entities'] - - [DynaLoader] - [Exporter] - [GD] - [utf8] @@ -233,7 +232,6 @@ modules: - ['Locale::Maketext'] - ['WeBWorK::PG::Localize'] - ['Mojo::JSON'] - - ['IO::Handle'] - ['Rserve'] - [DragNDrop] - ['Types::Serialiser'] diff --git a/lib/Rserve.pm b/lib/Rserve.pm index 414ada95e..593784b70 100644 --- a/lib/Rserve.pm +++ b/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)); diff --git a/lib/WWSafe.pm b/lib/WWSafe.pm index 78a8bc3d8..44071d8cd 100644 --- a/lib/WWSafe.pm +++ b/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; diff --git a/lib/WeBWorK/PG/SafeIOHandle.pm b/lib/WeBWorK/PG/SafeIOHandle.pm new file mode 100644 index 000000000..72ba34f3a --- /dev/null +++ b/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 blesses its connection socket as an L and uses its +C, C, C, and C methods. If the C package +is shared directly, then all of its methods are exposed. In particular the +C method is exposed (in addition to other potentially dangerous +methods such as C, C, 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 package (via +C) 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; diff --git a/lib/WeBWorK/PG/Translator.pm b/lib/WeBWorK/PG/Translator.pm index effd47399..debb39db5 100644 --- a/lib/WeBWorK/PG/Translator.pm +++ b/lib/WeBWorK/PG/Translator.pm @@ -56,6 +56,7 @@ use Mojo::DOM; use WWSafe; use PGUtil qw(pretty_print); use WeBWorK::PG::IO qw(fileFromPath); +use WeBWorK::PG::SafeIOHandle; BEGIN { # Setup the safe compartment for the standalone renderer. @@ -91,6 +92,12 @@ 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'); + my $store_mask = $safeCache->mask(); $safeCache->mask(Opcode::empty_opset()); my $safe_cmpt_package_name = $safeCache->root(); @@ -233,6 +240,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 +265,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 +282,7 @@ 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'); } return; @@ -497,7 +515,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; } diff --git a/macros/core/RserveClient.pl b/macros/core/RserveClient.pl index 96c69103e..1f1d1becf 100644 --- a/macros/core/RserveClient.pl +++ b/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(); diff --git a/t/rserve/rserve-eval-live.t b/t/rserve/rserve-eval-live.t index aca760487..b93704ace 100644 --- a/t/rserve/rserve-eval-live.t +++ b/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: $!"; diff --git a/t/rserve/rserve-getfile-live.t b/t/rserve/rserve-getfile-live.t index d85cb2d22..00628e465 100644 --- a/t/rserve/rserve-getfile-live.t +++ b/t/rserve/rserve-getfile-live.t @@ -17,6 +17,10 @@ use Rserve; # 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: $!"; diff --git a/t/rserve/rserveclient-macro.t b/t/rserve/rserveclient-macro.t index 8160d4ae8..a575c18c5 100644 --- a/t/rserve/rserveclient-macro.t +++ b/t/rserve/rserveclient-macro.t @@ -25,6 +25,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, which is only consulted by RserveClient.pl for its "is this configured" message. +$WeBWorK::PG::IO::pg_envir->{specialPGEnvironmentVars}{Rserve} = $main::Rserve; + my $s; eval { socket($s, PF_INET, SOCK_STREAM, getprotobyname('tcp')) || die "socket: $!";