1# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/ 2# 3# Copyright (C) 2004 Florian Weimer, Crawford Currie http://c-dot.co.uk 4# Copyright (C) 2004-2018 Peter Thoeny, peter[at]thoeny.org 5# and TWiki Contributors. All Rights Reserved. TWiki Contributors 6# are listed in the AUTHORS file in the root of this distribution. 7# NOTE: Please extend that file, not this notice. 8# 9# This program is free software; you can redistribute it and/or 10# modify it under the terms of the GNU General Public License 11# as published by the Free Software Foundation; either version 3 12# of the License, or (at your option) any later version. For 13# more details read LICENSE in the root of this distribution. 14# 15# This program is distributed in the hope that it will be useful, 16# but WITHOUT ANY WARRANTY; without even the implied warranty of 17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 18# 19# As per the GPL, removal of this notice is prohibited. 20 21=pod 22 23---+ package TWiki::Sandbox 24 25This object provides an interface to the outside world. All calls to 26system functions, or handling of file names, should be brokered by 27this object. 28 29NOTE: TWiki creates a singleton sandbox that is *shared* by all TWiki 30runs under a single mod_perl instance. If any TWiki run modifies the 31sandbox, that modification will carry over in to subsequent runs. 32Be very, very careful! 33 34=cut 35 36package TWiki::Sandbox; 37 38use strict; 39use Assert; 40use Error qw( :try ); 41 42require File::Spec; 43 44require TWiki; 45 46# Set to 1 to trace commands to STDERR 47sub TRACE { 0 } 48 49# TODO: Sandbox module should probably use custom 'die' handler so that 50# output goes only to web server error log - otherwise it might give 51# useful debugging information to someone developing an exploit. 52 53=pod 54 55---++ ClassMethod new( $os, $realOS ) 56 57Construct a new sandbox suitable for $os, setting 58flags for platform features that help. $realOS distinguishes 59Perl variants on platforms such as Windows. 60 61=cut 62 63sub new { 64 my ( $class, $os, $realOS ) = @_; 65 my $this = bless( {}, $class ); 66 67 ASSERT( defined $os ) if DEBUG; 68 ASSERT( defined $realOS ) if DEBUG; 69 70 $this->{REAL_SAFE_PIPE_OPEN} = 1; # supports open(FH, '-|") 71 $this->{EMULATED_SAFE_PIPE_OPEN} = 1; # supports pipe() and fork() 72 73 # filter the support based on what platforms are proven 74 # not to work. 75 #from the Activestate Docco this is _only_ defined on ActiveState Perl 76 if( defined( &Win32::BuildNumber ) ) { 77 $this->{REAL_SAFE_PIPE_OPEN} = 0; 78 $this->{EMULATED_SAFE_PIPE_OPEN} = 0; 79 } 80 81 # 'Safe' means no need to filter in on this platform - check 82 # sandbox status at time of filtering 83 $this->{SAFE} = ( $this->{REAL_SAFE_PIPE_OPEN} || 84 $this->{EMULATED_SAFE_PIPE_OPEN} ); 85 86 # Shell quoting - shell used only on non-safe platforms 87 if( $os eq 'UNIX' or ( $os eq 'WINDOWS' and $realOS eq 'cygwin' ) ) { 88 $this->{CMDQUOTE} = '\''; 89 } else { 90 $this->{CMDQUOTE} = '"'; 91 } 92 93 return $this; 94}; 95 96=begin twiki 97 98---++ ObjectMethod finish() 99Break circular references. 100 101=cut 102 103# Note to developers; please undef *all* fields in the object explicitly, 104# whether they are references or not. That way this method is "golden 105# documentation" of the live fields in the object. 106sub finish { 107 my $this = shift; 108} 109 110=pod 111 112---++ StaticMethod untaintUnchecked ( $string ) -> $untainted 113 114Untaints $string without any checks (dangerous). If $string is 115undefined, return undef. 116 117The intent is to use this routine to be able to find all untainting 118places using grep. 119 120=cut 121 122sub untaintUnchecked { 123 my ( $string ) = @_; 124 125 if( defined( $string) && $string =~ /^(.*)$/ ) { 126 return $1; 127 } 128 return $string; # Can't happen. 129} 130 131=pod 132 133---++ StaticMethod normalizeFileName( $string ) -> $filename 134 135Errors out if $string contains filtered characters. 136 137The returned string is not tainted, but it may contain shell 138metacharacters and even control characters. 139 140=cut 141 142sub normalizeFileName { 143 my ( $string ) = @_; 144 return '' unless $string; 145 my ( $volume, $dirs, $file ) = File::Spec->splitpath( $string ); 146 my @result; 147 my $first = 1; 148 foreach my $component ( File::Spec->splitdir( $dirs ) ) { 149 next unless( defined( $component ) && $component ne '' || $first ); 150 $first = 0; 151 $component ||= ''; 152 next if( $component eq '.' ); 153 if( $component eq '..' ) { 154 throw Error::Simple( 'relative path in filename '.$string ); 155 } elsif( $component =~ /$TWiki::cfg{NameFilter}/ ) { 156 throw Error::Simple( 'illegal characters in file name component ' 157 . $component.' of filename '.$string ); 158 } 159 push( @result, $component ); 160 } 161 162 if( scalar( @result ) ) { 163 $dirs = File::Spec->catdir( @result ); 164 } else { 165 $dirs = ''; 166 } 167 $string = File::Spec->catpath( $volume, $dirs, $file ); 168 169 # We need to untaint the string explicitly. 170 # FIXME: This might be a Perl bug. 171 return untaintUnchecked( $string ); 172} 173 174=pod 175 176---++ StaticMethod sanitizeAttachmentName($fname) -> ($fileName, $origName) 177 178Given a file name received in a query parameter, sanitise it. Returns 179the sanitised name together with the basename before sanitisation. 180 181Sanitisation includes filtering illegal characters and mapping client 182file names to legal server names. 183 184=cut 185 186sub sanitizeAttachmentName { 187 my $fileName = shift; # Full pathname if browser is IE 188 189 # Homegrown split equivalent because File::Spec functions will assume that 190 # directory path is using / in UNIX and \ in Windows as defined in the HOST 191 # environment. And we don't know the client OS. Problem is specific to IE 192 # which sends the full original client path when you upload files. See 193 # Item2859 and Item2225 before trying again to use File::Spec functions and 194 # remember to test with IE. 195 $fileName =~ s{[\\/]+$}{}; # Get rid of trailing slash/backslash (unlikely) 196 $fileName =~ s!^.*[\\/]!!; # Get rid of directory part 197 $fileName =~ s/[\x00-\x19]//go; # Item7560: Remove non-printable characters 198 199 my $origName = $fileName; 200 # Item7560: Strip trailing dots 201 $fileName =~ s/\.*$//o; 202 # Change spaces to underscore 203 $fileName =~ s/ /_/go; 204 # Strip dots and slashes at start 205 # untaint at the same time 206 $fileName =~ s/^([\.\/\\]*)*(.*?)$/$2/go; 207 208 if ( $TWiki::cfg{AllowI18NFileName} || $TWiki::cfg{UseLocale} ) { 209 # Filter out (less secure) only if using locales 210 # TODO: Make this use filtering in, using locales or full Codev.UnicodeSupport 211 $fileName =~ s/$TWiki::cfg{NameFilter}//goi; 212 } else { 213 # No I18N, so just filter in alphanumeric etc 214 $fileName =~ s/$TWiki::regex{filenameInvalidCharRegex}//g; 215 } 216 217 # Append .txt to some files 218 $fileName =~ s/$TWiki::cfg{UploadFilter}/$1\.txt/goi; 219 220 # Item7483, prevent a null file name 221 if ( $fileName eq '' || $fileName =~ /^\./ ) { 222 $fileName = '_' . $fileName; 223 } 224 225 # Untaint 226 $fileName = untaintUnchecked($fileName); 227 228 return( $fileName, $origName ); 229} 230 231# $template is split at whitespace, and '%VAR%' strings contained in it 232# are replaced with $params{VAR}. %params may consist of scalars and 233# array references as values. Array references are dereferenced and the 234# array elements are inserted into the command line at the indicated 235# point. 236# 237# '%VAR%' can optionally take the form '%VAR|FLAG%', where FLAG is a 238# single character flag. Permitted flags are 239# * U untaint without further checks -- dangerous, 240# * F normalize as file name, 241# * N generalized number, 242# * S simple, short string, 243# * D rcs format date 244 245sub _buildCommandLine { 246 my ( $this, $template, %params ) = @_; 247 my @arguments; 248 249 $template ||= ''; 250 251 for my $tmplarg ( split /\s+/, $template ) { 252 next if $tmplarg eq ''; # ignore leading/trailing whitespace 253 254 # Split single argument into its parts. It may contain 255 # multiple substitutions. 256 257 my @tmplarg = $tmplarg =~ /([^%]+|%[^%]+%)/g; 258 my @targs; 259 for my $t ( @tmplarg ) { 260 if( $t =~ /%(.*?)(|\|[A-Z])%/ ) { 261 my ( $p, $flag ) = ( $1, $2 ); 262 unless( exists $params{$p} ) { 263 throw Error::Simple( 'unknown parameter name '.$p ); 264 } 265 my $type = ref $params{$p}; 266 my @params; 267 if( $type eq '' ) { 268 @params = ($params{$p}); 269 } elsif( $type eq 'ARRAY' ) { 270 @params = @{$params{$p}}; 271 } else { 272 throw Error::Simple( $type.' reference passed in '.$p ); 273 } 274 275 for my $param ( @params ) { 276 unless( $flag ) { 277 push( @targs, $param ); 278 next; 279 } 280 if( $flag =~ /U/ ) { 281 push( @targs, untaintUnchecked( $param ) ); 282 } elsif ($flag =~ /F/) { 283 $param = normalizeFileName( $param ); 284 $param = "./$param" if $param =~ /^-/; 285 push @targs, $param; 286 } elsif( $flag =~ /N/ ) { 287 # Generalized number. 288 if( $param =~ /^([0-9A-Fa-f.x+\-]{0,30})$/ ) { 289 push( @targs, $1 ); 290 } else { 291 throw Error::Simple( "invalid number argument '$param' $t" ); 292 } 293 } elsif( $flag =~ /S/ ) { 294 # "Harmless" string. Aggressively filter-in on unsafe 295 # platforms. 296 if( $this->{SAFE} || $param =~ /^[-0-9A-Za-z.+_]+$/ ) { 297 push( @targs, untaintUnchecked( $param ) ); 298 } else { 299 throw Error::Simple( "invalid string argument '$param' $t" ); 300 } 301 } elsif( $flag =~ /D/ ) { 302 # RCS date. 303 if( $param =~ m|^(\d\d\d\d/\d\d/\d\d \d\d:\d\d:\d\d)$| ) { 304 push( @targs, $1 ); 305 } else { 306 throw Error::Simple( "invalid date argument '$param' $t" ); 307 } 308 } else { 309 throw Error::Simple( 'illegal flag in '.$t ); 310 } 311 } 312 } else { 313 push( @targs, $t ); 314 } 315 } 316 317 # Recombine the argument if the template argument contained 318 # multiple parts. 319 320 if( @tmplarg == 1 ) { 321 push( @arguments, @targs ); 322 } else { 323 map { ASSERT( defined( $_ ) ) } @targs if( DEBUG ); 324 push( @arguments, join ( '', @targs ) ); 325 } 326 } 327 328 return @arguments; 329} 330 331# Catch and redirect error reports from programs and argument processing, 332# to avert the risk of exposing server paths to a hacker. 333sub _safeDie { 334 print STDERR $_[0]; 335 die "TWiki experienced a fatal error. Please check your webserver error logs for details." 336} 337 338=pod 339 340---++ ObjectMethod sysCommand( $template, @params ) -> ( $data, $exit ) 341 342Invokes the program described by $template 343and @params, and returns the output of the program and an exit code. 344STDOUT is returned. STDERR is THROWN AWAY. 345 346The caller has to ensure that the invoked program does not react in a 347harmful way to the passed arguments. sysCommand merely 348ensures that the shell does not interpret any of the passed arguments. 349 350=cut 351 352# TODO: get emulated pipes or even backticks working on ActivePerl... 353 354sub sysCommand { 355 ASSERT(scalar(@_) % 2 == 0) if DEBUG; 356 my ($this, $template, %params) = @_; 357 358 #local $SIG{__DIE__} = &_safeDie; 359 360 my $data = ''; # Output 361 my $handle; # Holds filehandle to read from process 362 my $exit = 0; # Exit status of child process 363 364 return '' unless $template; 365 366 $template =~ /(^.*?)\s+(.*)$/; 367 my $path = $1; 368 my $pTmpl = $2; 369 my $cmd; 370 my $cq = $this->{CMDQUOTE}; 371 372 # Item5449: A random key known by both parent and child. 373 # Used to make it possible that the parent detects when 374 # child execution fails. Child can't throw exceptions 375 # cause they are separated processes, so it's up to 376 # the parent. 377 my $key = int( rand( 255 ) ) + 1; 378 379 # Build argument list from template 380 my @args = _buildCommandLine( $this, $pTmpl, %params ); 381 if( $this->{REAL_SAFE_PIPE_OPEN} ) { 382 # Real safe pipes, open from process directly - works 383 # for most Unix/Linux Perl platforms and on Cygwin. Based on 384 # perlipc(1). 385 386 # Note that there doesn't seem to be any way to redirect 387 # STDERR when using safe pipes. 388 389 my $pid = open( $handle, '-|' ); 390 391 throw Error::Simple( 'open of pipe failed: '.$! ) unless( defined $pid ); 392 393 if( $pid ) { 394 # Parent - read data from process filehandle 395 local $/ = undef; # set to read to EOF 396 $data = <$handle>; 397 close $handle; 398 $exit = ( $? >> 8 ); 399 if( $exit == $key && $data =~ /$key: (.*)/ ) { 400 throw Error::Simple( 'exec failed: '. $1 .' '.$path ); 401 } 402 } else { 403 # Child - run the command 404 untie( *STDERR ); 405 open( STDERR, '>'.File::Spec->devnull() ) || die "Can't kill STDERR: '$!'"; 406 unless( exec( $path, @args ) ) { 407 syswrite( STDOUT, $key . ": $!\n" ); 408 exit( $key ); 409 } 410 # can never get here 411 } 412 413 } elsif( $this->{EMULATED_SAFE_PIPE_OPEN} ) { 414 # Safe pipe emulation mostly on Windows platforms 415 416 # Create pipe 417 my $readHandle; 418 my $writeHandle; 419 420 pipe( $readHandle, $writeHandle ) || 421 throw Error::Simple( 'could not create pipe: '.$! ); 422 423 my $pid = fork(); 424 throw Error::Simple( 'fork() failed: '.$! ) unless defined( $pid ); 425 426 if( $pid ) { 427 # Parent - read data from process filehandle and remove newlines 428 429 close( $writeHandle ) or die; 430 431 local $/ = undef; # set to read to EOF 432 $data = <$readHandle>; 433 close( $readHandle ); 434 $pid = wait; # wait for child process so we can get exit status 435 $exit = ( $? >> 8 ); 436 if( $exit == $key && $data =~ /$key: (.*)/ ) { 437 throw Error::Simple( 'exec failed: '. $1 .' '.$path ); 438 } 439 440 } else { 441 # Child - run the command, stdout to pipe 442 443 # close the read side of the pipe and streams inherited from parent 444 close( $readHandle ) || die; 445 446 # Despite documentation apparently to the contrary, closing 447 # STDOUT first makes the subsequent open useless. So don't. 448 # When running tests -log, then STDOUT is tied to an object 449 # that tees the output. Unfortunately, what we need here is a plain 450 # file handle, so we need to make sure we untie it. untie is a 451 # NOP if STDOUT is not tied. 452 untie( *STDOUT ); 453 untie( *STDERR ); 454 455 open( STDOUT, ">&=".fileno( $writeHandle ) ) or die; 456 457 open( STDERR, '>'.File::Spec->devnull() ); 458 unless( exec( $path, @args ) ) { 459 syswrite( STDOUT, $key . ": $!\n" ); 460 exit( $key ); 461 } 462 # can never get here 463 } 464 465 } else { 466 # No safe pipes available, use the shell as last resort (with 467 # earlier filtering in unless administrator forced filtering out) 468 469 # This appears to be the only way to get ActiveStatePerl working 470 # Escape the cmd quote using \ 471 if( $cq eq '"' ) { 472 # DOS shell :-( Tried dozens of ways of trying to get the quotes 473 # right, but it just won't play nicely 474 $cmd = $path.' "'.join( '" "', @args ).'"'; 475 } else { 476 $cmd = $path.' '.$cq. 477 join( $cq.' '.$cq, map { s/$cq/\\$cq/g; $_ } @args ).$cq; 478 } 479 480 if( ( $TWiki::cfg{DetailedOS} eq 'MSWin32' ) && 481 ( length( $cmd ) > 8192 ) ) { 482 #heck, on pre WinXP its only 2048 - http://support.microsoft.com/kb/830473 483 print STDERR "WARNING: Sandbox::sysCommand commandline probably too long (".length( $cmd ).")\n"; 484 } 485 486 open( OLDERR, '>&STDERR' ) || die "Can't steal STDERR: $!"; 487 open( STDERR, '>'.File::Spec->devnull() ); 488 $data = `$cmd`; 489 # restore STDERR 490 close( STDERR ); 491 open( STDERR, '>&OLDERR' ) || die "Can't restore STDERR: $!"; 492 close( OLDERR ); 493 494 $exit = ( $? >> 8 ); 495 # Do *not* return the error message; it contains sensitive path info. 496 print STDERR "\n$cmd failed: $exit\n" if (TRACE && $exit); 497 } 498 499 if( TRACE ) { 500 $cmd ||= $path.' '.$cq.join($cq.' '.$cq, @args).$cq; 501 $data ||= ''; 502 print( STDERR $cmd, ' -> ', $data, "\n" ); 503 } 504 return ( $data, $exit ); 505} 506 5071; 508