# See bottom of file for license and copyright information

=begin TML

---+ package Foswiki::Sandbox

This package provides an interface to the outside world. All calls to
system functions, or handling of file names, should be brokered by
the =sysCommand= function in this package.

API version $Date: 2009-04-21 03:53:50 +0200 (Tue, 21 Apr 2009) $ (revision $Rev: 6075 (2010-01-17) $)

*Since* _date_ indicates where functions or parameters have been added since
the baseline of the API (TWiki release 4.2.3). The _date_ indicates the
earliest date of a Foswiki release that will support that function or
parameter.

*Deprecated* _date_ indicates where a function or parameters has been
[[http://en.wikipedia.org/wiki/Deprecation][deprecated]]. Deprecated
functions will still work, though they should
_not_ be called in new plugins and should be replaced in older plugins
as soon as possible. Deprecated parameters are simply ignored in Foswiki
releases after _date_.

*Until* _date_ indicates where a function or parameter has been removed.
The _date_ indicates the latest date at which Foswiki releases still supported
the function or parameter.

=cut

package Foswiki::Sandbox;

use strict;
use Assert;
use Error qw( :try );

require File::Spec;

require Foswiki;

# Set to 1 to trace commands to STDERR
sub TRACE { 0 }

our $REAL_SAFE_PIPE_OPEN;
our $EMULATED_SAFE_PIPE_OPEN;
our $SAFE;
our $CMDQUOTE; # leave undef until _assessPipeSupport has run

# TODO: Sandbox module should probably use custom 'die' handler so that
# output goes only to web server error log - otherwise it might give
# useful debugging information to someone developing an exploit.

# Assess pipe support for =$os=, setting flags for platform features
# that help.
sub _assessPipeSupport {

    # filter the support based on what platforms are proven not to work.

    $REAL_SAFE_PIPE_OPEN = 1;
    $EMULATED_SAFE_PIPE_OPEN = 1;

    # Detect ActiveState and Strawberry perl.   (Cygwin perl returns "cygwin" for $^O) 
    if ( $^O eq 'MSWin32' ) {
        $REAL_SAFE_PIPE_OPEN     = 0;
        $EMULATED_SAFE_PIPE_OPEN = 0;
    }

    # 'Safe' means no need to filter in on this platform - check
    # sandbox status at time of filtering
    $SAFE = ( $REAL_SAFE_PIPE_OPEN || $EMULATED_SAFE_PIPE_OPEN ) ? 1 : 0;

    # Shell quoting - shell used only on non-safe platforms
    if ( $Foswiki::cfg{OS} eq 'UNIX'
           || ( $Foswiki::cfg{OS} eq 'WINDOWS'
                  && $Foswiki::cfg{DetailedOS} eq 'cygwin' ) ) {
        $CMDQUOTE = "'";
    }
    else {
        $CMDQUOTE = '"';
    }
}

=begin TML

---++ StaticMethod untaintUnchecked ( $string ) -> $untainted

Untaints =$string= without any checks.  If $string is
undefined, return undef.

This function doesn't perform *any* checks on the data being untainted.
Callers *must* ensure that =$string= does not contain any dangerous content,
such as interpolation characters, if it is to be used in potentially
unsafe operations.

=cut

sub untaintUnchecked {
    my ($string) = @_;

    if ( defined($string) && $string =~ /^(.*)$/ ) {
        return $1;
    }
    return $string;    # Can't happen.
}

=begin TML

---++ StaticMethod untaint ( $datum, \&method, ... ) -> $untainted

Calls &$method($datum, ...) and if it returns a non-undef result, returns
that result after untainting it. Otherwise returns undef.

\&method can indicate a validation problem in a couple of ways. First, it
can throw an exception. Second, it can return undef, which then causes
the untaint function to return undef.

=cut

sub untaint {
    my $datum = shift;
    my $method = shift;
    ASSERT(ref($method)) if DEBUG;
    $datum = &$method($datum, @_);

    if ( defined $datum ) {
        $datum =~ /^(.*)$/;
        return $1;
    }
    return $datum;
}

=begin TML

---++ StaticMethod validateWebName($name) -> $web

Check that the name is valid for use as a web name. Method used for
validation with untaint(). Returns the name, or undef if it is invalid.

=cut

sub validateWebName {
    my $web = shift;
    return $web if Foswiki::isValidWebName($web, 1);
    return undef;
}

=begin TML

---++ StaticMethod validateTopicName($name) -> $topic

Check that the name is valid for use as a topic name. Method used for
validation with untaint(). Returns the name, or undef if it is invalid.

=cut

sub validateTopicName {
    my $topic = shift;
    return $topic if Foswiki::isValidTopicName($topic, 1);
    return undef;
}

=begin TML

---++ StaticMethod normalizeFileName( $string ) -> $filename

Throws an exception if =$string= contains filtered characters, as
defined by =$Foswiki::cfg{NameFilter}=

The returned string is not tainted, but it may contain shell
metacharacters and even control characters.

=cut

sub normalizeFileName {
    my ($string) = @_;
    return '' unless $string;
    my ( $volume, $dirs, $file ) = File::Spec->splitpath($string);
    my @result;
    my $first = 1;
    foreach my $component ( File::Spec->splitdir($dirs) ) {
        next unless ( defined($component) && $component ne '' || $first );
        $first = 0;
        $component ||= '';
        next if $component eq '.';
        if ( $component eq '..' ) {
            throw Error::Simple( 'relative path in filename ' . $string );
        }
        elsif ( $component =~ /$Foswiki::cfg{NameFilter}/ ) {
            throw Error::Simple( 'illegal characters in file name component '
                  . $component
                  . ' of filename '
                  . $string );
        }
        push( @result, $component );
    }

    if ( scalar(@result) ) {
        $dirs = File::Spec->catdir(@result);
    }
    else {
        $dirs = '';
    }
    $string = File::Spec->catpath( $volume, $dirs, $file );

    # We need to untaint the string explicitly.
    # FIXME: This might be a Perl bug.
    return untaintUnchecked($string);
}

=begin TML

---++ StaticMethod sanitizeAttachmentName($fname) -> ($fileName, $origName)

Given a file name received in a query parameter, sanitise it. Returns
the sanitised name together with the basename before sanitisation.

Sanitation includes filtering illegal characters and mapping client
file names to legal server names.

=cut

sub sanitizeAttachmentName {
    my $fileName = shift;    # Full pathname if browser is IE

    # Homegrown split equivalent because File::Spec functions will assume that
    # directory path is using / in UNIX and \ in Windows as defined in the HOST
    # environment.  And we don't know the client OS. Problem is specific to IE
    # which sends the full original client path when you upload files. See
    # Item2859 and Item2225 before trying again to use File::Spec functions and
    # remember to test with IE.
    $fileName =~ s{[\\/]+$}{};  # Get rid of trailing slash/backslash (unlikely)
    $fileName =~ s!^.*[\\/]!!;  # Get rid of directory part

    my $origName = $fileName;

    # Change spaces to underscore
    $fileName =~ s/ /_/go;

    # Strip dots and slashes at start
    # untaint at the same time
    $fileName =~ s/^([\.\/\\]*)*(.*?)$/$2/go;

    if ( $Foswiki::cfg{UseLocale} ) {

        # Filter out (less secure) only if using locales
        # TODO: Make this use filtering in
        $fileName =~ s/$Foswiki::cfg{NameFilter}//goi;
    }
    else {

        # No I18N, so just filter in alphanumeric etc
        $fileName =~ s/$Foswiki::regex{filenameInvalidCharRegex}//g;
    }

    # Append .txt to some files
    $fileName =~ s/$Foswiki::cfg{UploadFilter}/$1\.txt/goi;

    # Untaint
    $fileName = untaintUnchecked($fileName);

    return ( $fileName, $origName );
}

sub _buildCommandLine {
    my ( $template, %params ) = @_;
    my @arguments;

    $template ||= '';

    for my $tmplarg ( split /\s+/, $template ) {
        next if $tmplarg eq '';    # ignore leading/trailing whitespace

        # Split single argument into its parts.  It may contain
        # multiple substitutions.

        my @tmplarg = $tmplarg =~ /([^%]+|%[^%]+%)/g;
        my @targs;
        for my $t (@tmplarg) {
            if ( $t =~ /%(.*?)(?:\|([A-Z]))?%/ ) {
                # implicit untaint of template OK
                my ( $p, $flag ) = ( $1, $2 );
                if ( !exists $params{$p} ) {
                    throw Error::Simple( 'unknown parameter name ' . $p );
                }
                my $type = ref $params{$p};
                my @params;
                if ( $type eq '' ) {
                    @params = ( $params{$p} );
                }
                elsif ( $type eq 'ARRAY' ) {
                    @params = @{ $params{$p} };
                }
                else {
                    throw Error::Simple( $type . ' reference passed in ' . $p );
                }

                for my $param (@params) {
                    unless ($flag) {
                        push @targs, $param;
                        next;
                    }
                    if ( $flag eq 'U' ) {
                        push @targs, untaintUnchecked($param);
                    }
                    elsif ( $flag eq 'F' ) {
                        $param = normalizeFileName($param);
                        # Some command interpreters are too stupid to deal
                        # with filenames that start with a non-alphanumeric
                        $param = "./$param" if $param =~ /^[^\w\/\\]/;
                        push @targs, $param;
                    }
                    elsif ( $flag eq 'N' ) {

                        # Generalized number.
                        if ( $param =~ /^([0-9A-Fa-f.x+\-]{0,30})$/ ) {
                            push @targs, $1;
                        }
                        else {
                            throw Error::Simple(
                                "invalid number argument '$param' $t");
                        }
                    }
                    elsif ( $flag eq 'S' ) {

                        # "Harmless" string. Aggressively filter-in on unsafe
                        # platforms.
                        if ( $SAFE || $param =~ /^[-0-9A-Za-z.+_]+$/ ) {
                            push @targs, untaintUnchecked($param);
                        }
                        else {
                            throw Error::Simple(
                                "invalid string argument '$param' $t");
                        }
                    }
                    elsif ( $flag eq 'D' ) {

                        # RCS date.
                        if (
                            $param =~ m|^(\d\d\d\d/\d\d/\d\d \d\d:\d\d:\d\d)$| )
                        {
                            push @targs, $1;
                        }
                        else {
                            throw Error::Simple(
                                "invalid date argument '$param' $t");
                        }
                    }
                    else {
                        throw Error::Simple( 'illegal flag in ' . $t );
                    }
                }
            }
            else {
                push @targs, $t;
            }
        }

        # Recombine the argument if the template argument contained
        # multiple parts.

        if ( @tmplarg == 1 ) {
            push @arguments, @targs;
        }
        else {
            map { ASSERT( defined($_) ) } @targs if (DEBUG);
            push @arguments, join( '', @targs );
        }
    }

    return @arguments;
}

# Catch and redirect error reports from programs and argument processing,
# to avert the risk of exposing server paths to a hacker.
sub _safeDie {
    print STDERR $_[0];
    die
'Foswiki experienced a fatal error. Please check your webserver error logs for details.';
}

=begin TML

---++ StaticMethod sysCommand( $class, $template, %params ) -> ( $data, $exit )

Invokes the program described by =$template=
and =%params=, and returns the output of the program and an exit code.
STDOUT is returned. STDERR is THROWN AWAY. $class is also ignored, and
is only present for compatibility.

The caller has to ensure that the invoked program does not react in a
harmful way to the passed arguments. =sysCommand= merely
ensures that the shell does not interpret any of the passed arguments.

$template is a template command-line for the program, which contains
typed tokens that are replaced with parameter values passed in the
=sysCommand= call. For example,
<verbatim>
    my ( $output, $exit ) = Foswiki::Sandbox->sysCommand(
        $command,
        FILENAME => $filename );
</verbatim>
where =$command= is a template for the command - for example,
<verbatim>
/usr/bin/rcs -i -t-none -kb %FILENAME|F%
</verbatim>
=$template= is split at whitespace, and '%VAR%' strings contained in it
are replaced with =$params{VAR}=.  =%params= values may consist of scalars and
array references.  Array references are dereferenced and the
array elements are inserted. '%VAR%' can optionally take the form '%VAR|T%',
where FLAG is a single character type flag.  Permitted type flags are
   * =U= untaint without further checks -- dangerous,
   * =F= normalize as file name,
   * =N= generalized number,
   * =S= simple, short string,
   * =D= RCS format date

=cut

# TODO: get emulated pipes or even backticks working on ActivePerl...

sub sysCommand {
    ASSERT( scalar(@_) % 2 == 0 ) if DEBUG;
    my ( $ignore, $template, %params ) = @_;

    #local $SIG{__DIE__} = &_safeDie;

    my $data = '';    # Output
    my $handle;       # Holds filehandle to read from process
    my $exit = 0;     # Exit status of child process

    return '' unless $template;

    # Implicit untaint OK; $template is safe
    $template =~ /(^.*?)\s+(.*)$/;
    my $path  = $1;
    my $pTmpl = $2;
    my $cmd;

    # Item5449: A random key known by both parent and child.
    # Used to make it possible that the parent detects when
    # child execution fails. Child can't throw exceptions
    # cause they are separated processes, so it's up to
    # the parent.
    my $key = int( rand(255) ) + 1;

    _assessPipeSupport() unless defined $CMDQUOTE;

    # Build argument list from template
    my @args = _buildCommandLine( $pTmpl, %params );
    if ( $REAL_SAFE_PIPE_OPEN ) {

        # Real safe pipes, open from process directly - works
        # for most Unix/Linux Perl platforms and on Cygwin.  Based on
        # perlipc(1).

        # Note that there doesn't seem to be any way to redirect
        # STDERR when using safe pipes.

        my $pid = open( $handle, '-|' );

        throw Error::Simple( 'open of pipe failed: ' . $! ) unless defined $pid;

        if ($pid) {

            # Parent - read data from process filehandle
            local $/ = undef;    # set to read to EOF
            $data = <$handle>;
            close $handle;
            $exit = ( $? >> 8 );
            if ( $exit == $key && $data =~ /$key: (.*)/ ) {
                throw Error::Simple( 'exec failed: ' . $1 );
            }
        }
        else {

            # Child - run the command
            untie(*STDERR);
            open( STDERR, '>', File::Spec->devnull() )
              || die "Can't kill STDERR: '$!'";

            unless ( exec( $path, @args ) ) {
                syswrite( STDOUT, $key . ": $!\n" );
                exit($key);
            }

            # can never get here
        }

    }
    elsif ( $EMULATED_SAFE_PIPE_OPEN ) {

        # Safe pipe emulation mostly on Windows platforms

        # Create pipe
        my $readHandle;
        my $writeHandle;

        pipe( $readHandle, $writeHandle )
          || throw Error::Simple( 'could not create pipe: ' . $! );

        my $pid = fork();
        throw Error::Simple( 'fork() failed: ' . $! ) unless defined($pid);

        if ($pid) {

            # Parent - read data from process filehandle and remove newlines

            close($writeHandle) or die;

            local $/ = undef;    # set to read to EOF
            $data = <$readHandle>;
            close($readHandle);
            $pid = wait;    # wait for child process so we can get exit status
            $exit = ( $? >> 8 );
            if ( $exit == $key && $data =~ /$key: (.*)/ ) {
                throw Error::Simple( 'exec failed: ' . $1 );
            }

        }
        else {

            # Child - run the command, stdout to pipe

            # close the read side of the pipe and streams inherited from parent
            close($readHandle) || die;

            # Despite documentation apparently to the contrary, closing
            # STDOUT first makes the subsequent open useless. So don't.
            # When running tests -log, then STDOUT is tied to an object
            # that tees the output. Unfortunately, what we need here is a plain
            # file handle, so we need to make sure we untie it. untie is a
            # NOP if STDOUT is not tied.
            untie(*STDOUT);
            untie(*STDERR);

            open( STDOUT, ">&=", fileno($writeHandle) ) or die;

            open( STDERR, '>', File::Spec->devnull() );
            unless ( exec( $path, @args ) ) {
                syswrite( STDOUT, $key . ": $!\n" );
                exit($key);
            }

            # can never get here
        }

    }
    else {

        # No safe pipes available, use the shell as last resort (with
        # earlier filtering in unless administrator forced filtering out)

        # This appears to be the only way to get ActiveStatePerl working
        # Escape the cmd quote using \
        if ( $CMDQUOTE eq '"' ) {

            # DOS shell :-( Tried dozens of ways of trying to get the quotes
            # right, but it just won't play nicely
            $cmd = $path . ' "' . join( '" "', @args ) . '"';
        }
        else {
            $cmd =
                $path . ' ' 
              . $CMDQUOTE
              . join( $CMDQUOTE . ' ' . $CMDQUOTE,
                      map { s/$CMDQUOTE/\\$CMDQUOTE/go; $_ } @args )
              . $CMDQUOTE;
        }

        if (   ( $Foswiki::cfg{DetailedOS} eq 'MSWin32' )
            && ( length($cmd) > 8192 ) )
        {

      #heck, on pre WinXP its only 2048 - http://support.microsoft.com/kb/830473
            print STDERR
              "WARNING: Sandbox::sysCommand commandline probably too long ("
              . length($cmd) . ")\n";
        }

        open( OLDERR, '>&STDERR' ) || die "Can't steal STDERR: $!";
        open( STDERR, '>', File::Spec->devnull() );
        $data = `$cmd`;

        # restore STDERR
        close(STDERR);
        open( STDERR, '>&OLDERR' ) || die "Can't restore STDERR: $!";
        close(OLDERR);

        $exit = ( $? >> 8 );

        # Do *not* return the error message; it contains sensitive path info.
        print STDERR "\n$cmd failed: $exit\n" if ( TRACE && $exit );
    }

    if (TRACE) {
        $cmd ||= $path . ' ' . $CMDQUOTE .
          join( $CMDQUOTE . ' ' . $CMDQUOTE, @args ) . $CMDQUOTE;
        $data ||= '';
        print STDERR $cmd, ' -> ', $data, "\n";
    }
    return ( $data, $exit );
}

1;
__DATA__
# Module of Foswiki - The Free and Open Source Wiki, http://foswiki.org/
#
# Copyright (C) 2008-2009 Foswiki Contributors. All Rights Reserved.
# Foswiki Contributors are listed in the AUTHORS file in the root
# of this distribution. NOTE: Please extend that file, not this notice.
#
# Additional copyrights apply to some or all of the code in this
# file as follows:
#
# Copyright (C) 2004-2007 TWiki Contributors. All Rights Reserved.
# TWiki Contributors are listed in the AUTHORS file in the root
# of this distribution. NOTE: Please extend that file, not this notice.
# Copyright (C) 2004 Florian Weimer, Crawford Currie http://c-dot.co.uk
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version. For
# more details read LICENSE in the root of this distribution.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# As per the GPL, removal of this notice is prohibited.
