The issue I suspect is with the untainted file I'm trying to manipulate to upload file from other directories in lines 171-176. I'm able to upload file in lines 168-169 but not the opposite.
The error message tells you the issue is $destination_filename is tainted
Looking how you build it, I am horrified to see
my $user_id = "";
foreach my $key (sort keys(%ENV)) {
if ($key =~ /QUERY_STRING/) {
push(@ts_dir,$ENV{$key});
#print "$ENV{$key}<p>";
}
elsif ($key =~ /IWUSER/) {
$user_id = $ENV{$key};
#print "$user_id<p>";
}
}
That is the craziest thing I've seen in a long time :)
Part of your confusion stems from skipping perlintro, so
Drop what you're doing and read perlintro (or Tutorials) please!
Then replace that loop with
my @ts_dir = $ENV{QUERY_STRING};
my $user_id = $ENV{IWUSER};
The other part is you're not quite sure what it should do, so it does too much
- You should document your subroutines
- What input the subroutines takes
- what output it produces
- what effects it has / what actions it performs (copy file)
After you're done with perlintro, read http://search.cpan.org/dist/CGI.pm/lib/CGI.pm#Accessing_the_temp_files_directly
And reduce save_file to this
#!I:\Interwoven\TeamSite\iw-perl\bin\iwperl -T --
use strict;
use warnings;
use diagnostics;
use CGI;
use CGI::Carp qw(fatalsToBrowser warningsToBrowser set_message);
use File::Copy qw/ copy /;
Main( @ARGV );
exit( 0 );
sub Main {
set_message("It's not a bug, it's a feature!");
local $CGI::POST_MAX = 1024 * 100; # maximum upload filesize is 1
+00K
my $q = CGI->new;
print $q->header;
warningsToBrowser(1);
print buildForm( $q );
if ( !$q->param('filename') && $q->cgi_error() ) {
...
} else {
save_file($q);
}
print $q->end_html;
}
sub save_file {
my( $q ) = @_;
my $filename = $query->param('uploaded_file');
my $destination_filename = File::Spec->catfile( $hardcoded_destina
+tion_directory, WashFilename( $filename ) );
copy( $filename->handle, $destination_filename ) or die "Copy to
+( $destination_filename) failed: $!";
}
WashFilename should create a new (normalized) filename, not warn about dots and other things (action instead of talk)
Something like this (save as WashFilename-test.pl)
for my $testfn (
"a/b/c",
'a\b\c',
'a:b:c',
"a[!{(\205)}!].ext",
"a.ext",
){
printf "( %s )\n\t(%s)\n\n", $testfn , WashFilename( $testfn );
}
sub WashFilename {
use File::Basename;
my $basename = basename( shift );
#~ $basename =~ s/[^a-zA-Z0-9]//g; # remove everything except a-z
+A-Z 0-9
$basename = join '', $basename =~ m/([.a-zA-Z0-9])/g; # untainted
+, only use a-z A-Z 0-9 and dot
# basename is now, hopefully, file.ext
## so to ensure uniqueness, we adulterate it :)
my $id = $$.'-'.time;
my( $file, $ext ) = split /\./, $basename, 2 ;
return join '.', grep defined, $file, $id, $ext;
}
__END__
( a/b/c )
(c.1272-1316599567)
( a\b\c )
(c.1272-1316599567)
( a:b:c )
(c.1272-1316599567)
( a[!{(à)}!].ext )
(a.1272-1316599567.ext)
( a.ext )
(a.1272-1316599567.ext)
Instead of removing everything but safe characters, you could encode all characters as hex
(save as WashFilename2-test.pl)
for my $testfn (
"a/b/c",
'a\b\c',
'a:b:c',
"a[!{(\205)}!].ext",
"a.ext",
){
printf "( %s )\n\t(%s)\n\n", $testfn , WashFilename( $testfn );
}
sub WashFilename {
use File::Basename;
my $basename = basename( shift );
my $id = $$.'-'.time;
my( $file, $ext ) = map { unpack 'h*',$_ } split /\./, $basename,
+2 ;
return join '.', grep defined, $file, $id, $ext;
}
__END__
( a/b/c )
(36.3924-1316599650)
( a\b\c )
(36.3924-1316599650)
( a:b:c )
(36.3924-1316599650)
( a[!{(à)}!].ext )
(16b512b7825892d712d5.3924-1316599650.568747)
( a.ext )
(16.3924-1316599650.568747)
You would benefit greatly from reading http://learn.perl.org/books/beginning-perl/
And maybe Modern Perl: the free book
That is all I have time for, it only took ~3 hours :)