diff options
author | Yorhel <git@yorhel.nl> | 2017-12-26 13:23:40 +0100 |
---|---|---|
committer | Yorhel <git@yorhel.nl> | 2017-12-26 13:23:46 +0100 |
commit | 0297bc628344618eecf773fc2f65c44b5f531cff (patch) | |
tree | 4731a73032ef4c1d215e29109a30afd71bfdfd46 | |
parent | 2aee6b38815548cece7bc8c47f3947a2292f9eee (diff) |
TUWF::Request: Check for control characters on all client input
Seems much safer. I've not tested this patch as well as I'd like, I'll
do some more testing later to see if I broke something.
-rw-r--r-- | examples/MyWebsite/InfoDump.pm | 30 | ||||
-rw-r--r-- | lib/TUWF/Request.pm | 28 |
2 files changed, 29 insertions, 29 deletions
diff --git a/examples/MyWebsite/InfoDump.pm b/examples/MyWebsite/InfoDump.pm index 27acebf..c6b1e2d 100644 --- a/examples/MyWebsite/InfoDump.pm +++ b/examples/MyWebsite/InfoDump.pm @@ -9,15 +9,7 @@ use warnings; use TUWF ':html'; -TUWF::register( - qr/info/ => \&info, - qr{info/forms} => \&forms, -); - - -sub info { - my $self = shift; - +TUWF::any ['get','post'], '/info' => sub { my $tr = sub { Tr; td shift; td shift; end }; html; @@ -38,45 +30,45 @@ sub info { h2 'GET Parameters'; table; thead; Tr; td 'Name'; td 'Value'; end; end; - $tr->($_, join "\n---\n", $self->reqGet($_)) for ($self->reqGets()); + $tr->($_, join "\n---\n", tuwf->reqGet($_)) for (tuwf->reqGets); end; h2 'POST Parameters'; table; thead; Tr; td 'Name'; td 'Value'; end; end; - $tr->($_, join "\n---\n", $self->reqPost($_)) for ($self->reqPosts()); + $tr->($_, join "\n---\n", tuwf->reqPost($_)) for (tuwf->reqPosts); end; h2 'Uploaded files'; table; thead; Tr; td 'Name'; td 'File size - File name - Mime type'; end; end; - $tr->($_, length($self->reqUploadRaw($_)).' - '.$self->reqPost($_).' - '.$self->reqUploadMIME($_)) for ($self->reqUploadMIMEs()); + $tr->($_, length(tuwf->reqUploadRaw($_)).' - '.tuwf->reqPost($_).' - '.tuwf->reqUploadMIME($_)) for (tuwf->reqUploadMIMEs); end; h2 'HTTP Headers'; table; thead; Tr; td 'Header'; td 'Value'; end; end; - $tr->($_, $self->reqHeader($_)) for ($self->reqHeader()); + $tr->($_, tuwf->reqHeader($_)) for (tuwf->reqHeader); end; h2 'HTTP Cookies'; table; thead; Tr; td 'Cookie'; td 'Value'; end; end; - $tr->($_, $self->reqCookie($_)) for ($self->reqCookie()); + $tr->($_, tuwf->reqCookie($_)) for (tuwf->reqCookie); end; h2 'Misc. request functions'; table; thead; Tr; td 'Function'; td 'Return value'; end; end; - $tr->($_, eval "\$self->$_;") for(qw{ - reqMethod() reqPath() reqBaseURI() reqURI() reqHost() reqIP() + $tr->($_, tuwf->$_) for(qw{ + reqProtocol reqMethod reqPath reqBaseURI reqURI reqQuery reqHost reqIP }); end; end; -} +}; -sub forms { +TUWF::get '/info/forms' => sub { html; body; h1 'Forms for generating some input for /info'; @@ -125,7 +117,7 @@ sub forms { end; end; -} +}; 1; diff --git a/lib/TUWF/Request.pm b/lib/TUWF/Request.pm index f7d67b4..5b3852b 100644 --- a/lib/TUWF/Request.pm +++ b/lib/TUWF/Request.pm @@ -63,6 +63,14 @@ sub reqInit { } +sub _check_control { + # Disallow any control codes, except for x09 (tab), x0a (newline) and x0d (carriage return) + # The error message is a hack to trigger the 'utf8' error code. + die "Illegal control code (does not map to Unicode)" if $_[0] =~ /[\x00-\x08\x0b\x0c\x0e-\x1f]/; + $_[0] +} + + sub _parse_urlencoded { my %dat; my $d = shift; @@ -77,9 +85,7 @@ sub _parse_urlencoded { decode_utf8($s, 1); #eg; s/%u([0-9a-fA-F]{4})/chr hex($1)/eg; - # Disallow any control codes, except for x09 (tab), x0a (newline) and x0d (carriage return) - # The error message is a hack to trigger the 'utf8' error code. - die "Illegal control code (does not map to Unicode)" if /[\x00-\x08\x0b\x0c\x0e-\x1f]/; + _check_control($_); } push @{$dat{$key}}, $val; } @@ -139,11 +145,11 @@ sub _parse_multipart { # regular form element. The standards do not require the filename to be # present, but I am not aware of any browser that does not send it. if($filename) { - push @{$nfo->{POST}{$name}}, decode_utf8 $filename, 1; - push @{$nfo->{MIMES}{$name}}, decode_utf8 $mime, 1; + push @{$nfo->{POST}{$name}}, _check_control decode_utf8 $filename, 1; + push @{$nfo->{MIMES}{$name}}, _check_control decode_utf8 $mime, 1; push @{$nfo->{FILES}{$name}}, $value; # not decoded, can be binary } else { - push @{$nfo->{POST}{$name}}, decode_utf8 $value, 1; + push @{$nfo->{POST}{$name}}, _check_control decode_utf8 $value, 1; } } } @@ -164,6 +170,8 @@ sub _parse_cookies { next if !$_ || !m{^([^\(\)<>@,;:\\"/\[\]\?=\{\}\t\s]+)=("?)(.*)\2$}; my($n, $v) = ($1, $3); next if $self->{_TUWF}{cookie_prefix} && !($n =~ s/^\Q$self->{_TUWF}{cookie_prefix}\E//); + _check_control $n; + _check_control $v; $dat{$n} = $v if !exists $dat{$n}; } return \%dat; @@ -259,13 +267,13 @@ sub reqHeader { my($self, $name) = @_; if(@_ == 2) { (my $v = uc $_[1]) =~ tr/-/_/; - return $ENV{"HTTP_$v"}||''; + return _check_control decode_utf8 $ENV{"HTTP_$v"}||'', 1; } else { return (map { if(/^HTTP_/) { (my $h = lc $_) =~ s/_([a-z])/-\U$1/g; $h =~ s/^http-//; - decode_utf8 $h, 1; + _check_control decode_utf8 $h, 1; } else { () } } sort keys %ENV); } @@ -275,7 +283,7 @@ sub reqHeader { # returns the path part of the current URI, including the leading slash sub reqPath { (my $u = ($ENV{REQUEST_URI}||'')) =~ s{\?.*$}{}; - return decode_utf8 $u, 1; + return _check_control decode_utf8 $u, 1; } @@ -293,7 +301,7 @@ sub reqBaseURI { sub reqQuery { my $u = $ENV{QUERY_STRING} ? '?'.$ENV{QUERY_STRING} : ''; - return decode_utf8 $u, 1; + return _check_control decode_utf8 $u, 1; } |