#!/usr/bin/perl
# Generate TSV sheet for admins
# Bruno Wolff III
# Last revised Octiber 13, 2012
# While areaid and gameid can't currently contain any uri specials, I want
# assume they can here, so I if tweak the database schema, things don't
# break here. The problem characters that might eventually be allowed
# are '#', '/' and '?'. Also note that '/'s don't really work at all
# since the server has a special check for / (encoded as %2F) in a component.
# An empty game code is taken to be a request for Other Interested Player
# data.
# Use unbuffered output as there are some long delays while doing queries
select(STDOUT);
$| = 1;
$" = '';
use Pg;
# Use this to clean stuff extracted from the database for html output
sub clean(@) {
local $str = "@_";
$str =~ s/&/&/g;
$str =~ s//>/g;
$str =~ s/"/"/g;
return $str;
}
# Use this to convert REQUEST_URI to unescaped string
sub urldecode(@) {
local $str = "@_";
$str =~ s/\%[0-9a-fA-F]{2}/$urldhash{$&}/eg;
return $str;
}
# Use this to make sure urls don't contain url specials
sub urlencode(@) {
local $str = "@_";
$str =~ s/[^-_A-Za-z0-9.$+!*'(),]/$urlehash{$&}/eg;
return $str;
}
# One time build of data used by url decode
sub urlinit() {
my $c;
my $f;
my $i;
for ($i=0; $i<=255; $i++) {
$c = chr($i);
$f = sprintf('%%%.2X', $i);
$urldhash{$f} = $c;
$urldhash{lc($f)} = $c;
$urlehash{$c} = $f;
}
}
urlinit;
# +s in the query part are really spaces
$uri = $ENV{REQUEST_URI};
if ($uri =~ m/^([^?]*\?)(.*)$/) {
$uri = $1;
$temp = $2;
$temp =~ s/\+/ /g;
$uri .= $temp;
}
$uri = urldecode($uri);
if ($ENV{REQUEST_METHOD} ne '' && $ENV{REQUEST_METHOD} ne 'GET' &&
$ENV{REQUEST_METHOD} ne 'HEAD') {
$meth = clean($ENV{REQUEST_METHOD});
$uri = clean($ENV{REQUEST_URI});
print <<"EOF";
content-type: text/html; charset=UTF-8
status: 501 Method not implemented
501 Method Not Implemented
Method Not Implemented
Method '$meth' not implented for '$uri'.
EOF
exit;
}
$ENV{SCRIPT_NAME} =~ s%\?.*$%%;
$ENV{SCRIPT_NAME} =~ s%[^/]*$%%;
$script = $ENV{SCRIPT_NAME};
$script = urldecode($script);
# The length check is to protect against buffer overrun attacks.
if (length($uri) > 1000 || $uri !~ m/^\Q$script\E(S)_([\040-\176]*)\.tsv$/) {
$uri = clean($ENV{REQUEST_URI});
print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found
404 File Not Found
404 File Not Found
'$uri' not found.
EOF
exit;
}
$type = $1;
$index = uc($2);
# Check if encoding is safe, otherwise browsers might mess up relative links
$check = $ENV{REQUEST_URI};
for ($i=0; $i
301 moved permanently
301 moved permanently
Improperly escaped URL. Use $cloc instead.