summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2017-12-26 13:23:40 +0100
committerYorhel <git@yorhel.nl>2017-12-26 13:23:46 +0100
commit0297bc628344618eecf773fc2f65c44b5f531cff (patch)
tree4731a73032ef4c1d215e29109a30afd71bfdfd46
parent2aee6b38815548cece7bc8c47f3947a2292f9eee (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.pm30
-rw-r--r--lib/TUWF/Request.pm28
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;
}