#!/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/&/&amp;/g;
  $str =~ s/</&lt;/g;
  $str =~ s/>/&gt;/g;
  $str =~ s/"/&quot;/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

<html><head>
<title>501 Method Not Implemented</title>
</head><body>
<h1>Method Not Implemented</h1>
Method '$meth' not implented for '$uri'.
</body></html>
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

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
</body></html>
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<length($script); $i++) {
  if ($check !~ s/^%[0-9A-Za-z]{2}//) {
    $check =~ s/^.//;
  }
}
$check =~ s/\%[0-9A-Za-z]{2}//g;
if ($check =~ m/[^-_A-Za-z0-9.+!*'()$,]/) {
  $loc = 'http://' . $ENV{SERVER_NAME} . $ENV{SCRIPT_NAME} . $type . '_' . urlencode($index) . '.html';
  $cloc = clean($loc);
  print <<"EOF";
content-type: text/html; charset=UTF-8
Status: 301
Location: $loc

<html><head>
<title>301 moved permanently</title>
</head><body>
<h1>301 moved permanently</h1>
Improperly escaped URL. Use <a href="$cloc">$cloc</a> instead.
</body></html>
EOF
  exit;
}

# Quotes and backslashes need to be quoted before using in a pg string constant
$qindex = $index;
$qindex =~ s/\\|'/\\$&/g;

# First try to connect
$conn = Pg::connectdb('dbname=area');
if ($conn->status != PGRES_CONNECTION_OK) {
  $uri = clean($ENV{REQUEST_URI});
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
Unable to connect to the database.
</body></html>
EOF
  exit;
}

$result = $conn->exec("begin");
if ($result->resultStatus != PGRES_COMMAND_OK) {
  $uri = clean($ENV{REQUEST_URI});
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
Unable to start a transaction.
</body></html>
EOF
  exit;
}

$result = $conn->exec("set transaction isolation level serializable");
if ($result->resultStatus != PGRES_COMMAND_OK) {
  $uri = clean($ENV{REQUEST_URI});
  print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
Unable to serialize transaction.
</body></html>
EOF
  exit;
}

if ($qindex ne '') {
  $result = $conn->exec("select gameid, title, to_char(touched, 'FMYYYY-MM-DD') from games where gameid = '$qindex'");
  
  if ($result->resultStatus != PGRES_TUPLES_OK) {
    $uri = clean($ENV{REQUEST_URI});
    print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
Unable to access the game table.
</body></html>
EOF
    exit;
  }
  if ($result->ntuples != 1) {
    $uri = clean($ENV{REQUEST_URI});
    print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
No such game.
</body></html>
EOF
    exit;
  }
  
  if (!(@row = $result->fetchrow)) {
    print <<"EOF";
content-type: text/html; charset=UTF-8
status: 404 File Not Found

<html><head>
<title>404 File Not Found</title>
</head><body>
<h1>404 File Not Found</h1>
'$uri' not found.
No such game.
</body></html>
EOF
    exit;
  }
  
  $gameid = $row[0];
  $cgameid = $gameid;
  $cgameid =~ s/\\|"/\\$&/g;
  $qgameid = $gameid;
  $qgameid =~ s/\\|'/\\$&/g;
  $title = $row[1];
  $gdate = $row[2];
  
  print << "EOF";
content-type: text/tab-separated-values; charset=UTF-8
content-disposition: attachment; filename="$cgameid.tsv"

EOF
  
  $result = $conn->exec("select pubname from gamepubs, publishers where gamepubs.pubid = publishers.pubid and gameid = '$qgameid' order by lower(pubname)");
  $pub = '';
  $sep = '';
  if ($result->resultStatus == PGRES_TUPLES_OK) {
    while (@row = $result->fetchrow) {
      $pub .= $sep . $row[0];
      $sep = ' / ';
    }
  }
  
  $result = $conn->exec("select cname_web.areaid, lname, fmname, aname, coalesce(genlab, to_char(gen, 'FMRN')), rate, frq, opp, rmp, trn, rmc, to_char(crate.touched, 'FMYYYY-MM-DD'), gm, displayid from cname_web, crate where cname_web.areaid = crate.areaid and gameid = '$qgameid' and frq > 0 order by lower(lname), lower(coalesce((aname || ' ') || fmname, fmname, aname)), gen, genlab, cname_web.areaid");
  if ($result->resultStatus != PGRES_TUPLES_OK) {
    print "Unable to retrieve player information from database.\n";
  }
  else {
    print "\t$title\t\t$gdate\n";
    print "\t$pub\n" unless $pub eq '';
    print "Rk\tID\tFName\tLName\tRate\tFrq\tOpp\tRmp\tTrn\tRmC\tActive\tGM\n";
    while (@row = $result->fetchrow) {
      if (!defined($row[1])) {
        $lname = 'Withheld';
        $fname = '';
      }
      else {
        $lname = $row[1];
        if (defined($row[4])) {
          $lname .= ' ' . $row[4];
        }
        $fname = '';
        if (defined($row[2])) {
          if (defined($row[3])) {
            $fname = $row[3] . ' (' . $row[2] . ')';
          }
          else {
            $fname = $row[2];
          }
        }
        elsif (defined($row[3])) {
          $fname = $row[3];
        }
      }
      print "\t$row[13]\t$fname\t$lname\t$row[5]\t$row[6]\t$row[7]\t$row[8]\t$row[9]\t$row[10]\t$row[11]\t$row[12]\n";
    }
  }
}
else {
  print << "EOF";
content-type: text/tab-separated-values; charset=UTF-8
content-disposition: attachment; filename="all_oip.tsv"

EOF
  $result = $conn->exec("select games.gameid, cname_web.areaid, to_char(crate.touched, 'FMYYYY-MM-DD'), games.title, lname, fmname, aname, coalesce(genlab, to_char(gen, 'FMRN')), displayid from cname_web, crate, games where cname_web.areaid = crate.areaid and crate.gameid = games.gameid and frq = 0 order by title, games.gameid, lower(lname), lower(coalesce((aname || ' ') || fmname, fmname, aname)), gen, genlab, cname_web.areaid");
  if ($result->resultStatus != PGRES_TUPLES_OK) {
    print "Unable to retrieve other interested player information from database.\n";
  }
  else {
    print "Game ID\tAREA ID\tActive Date\tGame Title\tFirst Name\tLast Name\n";
    while (@row = $result->fetchrow) {
      if (!defined($row[4])) {
        $lname = 'Withheld';
        $fname = '';
      }
      else {
        $lname = $row[4];
        if (defined($row[7])) {
          $lname .= ' ' . $row[7];
        }
        $fname = '';
        if (defined($row[5])) {
          if (defined($row[6])) {
            $fname = $row[6] . ' (' . $row[5] . ')';
          }
          else {
            $fname = $row[5];
          }
        }
        elsif (defined($row[6])) {
          $fname = $row[6];
        }
      }
      print "$row[0]\t$row[8]\t$row[2]\t$row[3]\t$fname\t$lname\n";
    }
  }
}
