package TDL::Admin;
# System administration

# Export the isAdmin subroutine
use Exporter;
@ISA = "Exporter";
@EXPORT = qw(isAdmin adminReport formatCGI printEnvironment dumpEnvironment);

our ($adminCheckRun, $isAdminIP, $isAdminUser, @notify, $q, $VERSION);
$VERSION = "2.0";
$isAdminUser = 0;
$isAdminIP = 0;
$adminCheckRun = 0;
@notify = undef;
$q = undef;

use strict;

########################################################################################################################
# Determine if an allow condition has been matched
sub tryAllow
{
  my ($value, $wantToMatch) = @_;

  my $match = "^$wantToMatch\$";
  $match =~ s/\./\\./g;
  $match =~ s/\?/./g;
  $match =~ s/\*/\.*/g;
  return 0 unless $value =~ m/$match/i;

  return 1;
}

########################################################################################################################
sub doAdminCheck
{
  my $fName = $ENV{"DOCUMENT_ROOT"} . "/.htaccess";
  if (-r $fName)
  {
    $adminCheckRun = 1;
    my $remote_user = defined($ENV{REMOTE_USER}) ? $ENV{REMOTE_USER} : "nobody";
    my $remote_addr = defined($ENV{REMOTE_ADDR}) ? $ENV{REMOTE_ADDR} : "0.0.0.0";
    my $adminUser = 0;
    my $adminIP = 0;

    if (open(HTA,$fName))
    {
      foreach my $line (<HTA>)
      {
        if ($line =~ m/^\#\$\#\s+allow\s+user\s+(\w+)\s*(?:\#|$)/)
        {
          $adminUser += tryAllow($remote_user, $1);
        } elsif ($line =~ m/^\#\$\#\s+allow\s+from\s+(\S+)\s*(?:\#|$)/) {
          $adminIP += tryAllow($remote_addr, $1);
        } elsif ($line =~ m/^\#\$\#\s+notify\s+([^\@]+\@\S+)\s*(?:\#|$)/) {
          push @notify, $1;
        }
      }
      close HTA;
    }

    $isAdminUser = 1 if $adminUser > 0;
   	$isAdminIP = 1 if $adminIP > 0;
  }
}

########################################################################################################################
# Simple access to the isAdmin* variables
sub isAdmin
{
  doAdminCheck() unless $adminCheckRun;
  return $isAdminUser || $isAdminIP;
}

########################################################################################################################
# Simple access to the notify variable
sub adminNotify
{
  doAdminCheck() unless $adminCheckRun;
  return @notify;
}

########################################################################################################################
# Generate a report about the check
sub adminReport
{
  print "Admin check previously run: $adminCheckRun<br>";
  doAdminCheck();

  my $fName = $ENV{"DOCUMENT_ROOT"} . "/.htaccess";
  if (-r $fName)
  {
    my $remote_user = defined($ENV{REMOTE_USER}) ? $ENV{REMOTE_USER} : "nobody";
    my $remote_addr = defined($ENV{REMOTE_ADDR}) ? $ENV{REMOTE_ADDR} : "0.0.0.0";
    my $adminUser = 0;
    my $adminIP = 0;

    if (open(HTA,$fName))
    {
      foreach my $line (<HTA>)
      {
        chomp $line;
        print "<font color=blue>$line</font><br>\n" if $line =~ m/^\#/;
        if ($line =~ m/^\#\$\#\s+allow\s+user\s+(\w+)\s*(?:\#|$)/)
        {
          my $user = $1;
          if (tryAllow($remote_user, $user))
          {
            print "$remote_user matches $user<br>";
            $adminUser++;
          } else {
            print "$remote_user does not match $user<br>";
          }
        } elsif ($line =~ m/^\#\$\#\s+allow\s+from\s+(\S+)\s*(?:\#|$)/) {
          my $ip = $1;
          if (tryAllow($remote_addr, $ip))
          {
            print "$remote_addr matches $ip<br>";
            $adminIP++;
          } else {
            print "$remote_addr does not match $ip<br>";
          }
        }
      }

      print "Matched user $adminUser times; setting is $isAdminUser<br>";
      print "Matched address $adminIP times; setting is $isAdminIP<br>";
      close HTA;
    } else {
      print "Unable to open $fName: $!<br>";
    }
  } else {
    print "$fName is not readable<br>";
  }
}

########################################################################################################################
# Generate a table of the CGI environment variables
sub formatCGI
{
  (local *F) = @_;

  my %ENV_INFO = (
  	AUTH_TYPE            => "authentication method",
  	CONTENT_LENGTH       => "length of the request body",
  	CONTENT_TYPE         => "media type of the data",
  	DOCUMENT_ROOT        => "server document root directory",
    GATEWAY_INTERFACE    => "CGI specification revision",
  	HTTP_ACCEPT          => "media types the client accepts",
  	HTTP_COOKIE          => "cookie(s) the client sent",
  	HTTP_REFERER         => "URL of the referring page",
  	HTTP_USER_AGENT      => "browser the client is using",
  	PATH_INFO            => "extra path information",
  	PATH_TRANSLATED      => "extra path information (translated)",
  	QUERY_STRING         => "query string",
  	REMOTE_ADDR          => "IP address of the client",
  	REMOTE_HOST          => "hostname of the client",
  	REMOTE_IDENT         => "remote user (RFC 931)",
  	REMOTE_USER          => "authenticated username",
  	REQUEST_METHOD       => "HTTP request method",
  	SCRIPT_NAME          => "script name",
  	SERVER_NAME          => "server hostname or IP address",
  	SERVER_PORT          => "port number for the server",
  	SERVER_PROTOCOL      => "server protocol name",
  	SERVER_SOFTWARE      => "server software"
  );

  my $name;

  # Add additional variables defined by web server or browser
  foreach $name ( keys %ENV )
  {
    $ENV_INFO{$name} = "." unless exists $ENV_INFO{$name};
  }

  print F "<h1>CGI Environment Variables</h1>\n";
  print F "<table border=1>\n";
  print F "<tr><th>Variable Name</th><th>Description</th><th>Value</th></tr>\n";
  foreach $name ( sort keys %ENV_INFO )
  {
    my $info = $ENV_INFO{$name};
    my $value = $ENV{$name} || "<i>undefined</i>";
    print F "<tr valign=top><td><b>$name</b></td><td>$info</td><td>$value</td></tr>\n";
  }
  print F "</table>\n";
}

########################################################################################################################
# Print the environment
sub printEnvironment
{
  (local *F) = @_;

  # First, print the CGI environment
  formatCGI(*F);

  # Next, look for parameters
  unless (defined($q))
  {
    # print "<br><font color='red'>Looking for CGI variable</font><br>\n";
    if (%CGI::)
    {
      eval
      {
        eval("use Devel::Symdump");
        my $main = Devel::Symdump->new("main");
        map {
          unless (m/::(?:_<|\$|\@|\"|\\)/)
          {
            unless (defined($q))
            {
              # print "<font color='red'>Try $_</font><br>\n";
              eval("\$q = \$$_") if ref(eval("\$$_")) eq "CGI";
              # print "<font color='red'>Found it in $_</font><br>\n" if defined($q);
            }
          }
        } $main->scalars;
      };
    }
  }
  return unless defined($q);

  if (scalar($q->param) > 0)
  {
    print F "<h1>Parameters</h1>\n";
    print F "<table border=1>\n";
    print F "<tr valign=top><th>Parameter</th><th>Value</th></tr>\n";
    map { print F "<tr valign=top><td>$_</td><td>",($q->param($_) || "&nbsp;"), "</td></tr>\n" }
      $q->param();
    print F "</table>\n";

    print F "<h1>Form contents</h1>\n";
    print F "<form method=\"post\" action=\"http://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}\">\n";
    map {
      print F "Form field: $_<br>\n";
      print F "<textarea name=\"$_\" rows=4 cols=80>", $q->param($_), "</textarea><p>\n";
    } $q->param();
    print F "<input type=\"submit\" value=\"POST again\"> to ", $ENV{SCRIPT_NAME}, "</form>\n";

    print F "<h1>Raw</h1><pre>\n";
    $q->save(*F);
    print F "</pre>\n";
  }
}

########################################################################################################################
# Dump the environment for later analysis by the administrator
sub dumpEnvironment
{
  my ($dumpDir) = $ENV{DOCUMENT_ROOT} =~ m/^(.*)\/[^\/]+$/;
  $dumpDir .= "/dump";

  my $nTries = 0;
lookAgain:
  $nTries++;
  opendir DUMP, $dumpDir;
  my $n = 1;
  my $file;
  while ($file = readdir DUMP)
  {
    if ($file =~ m/^dump_(\d+).html$/)
    {
	    my $v = eval($1) + 1;
	    $n = $v if $v > $n;
	  }
  }
  closedir DUMP;
  $file = "$dumpDir/dump_$n.html";
  goto lookAgain if -f $file && $nTries < 10;
  return if -f $file;

  if (open(F, ">$file"))
  {
    print F "<html><head>\n";
    print F "<title>Dump from $ENV{SERVER_NAME}$ENV{SCRIPT_NAME}</title>\n";
    print F "</head><body>\n";
    print F "<font color=red>", @_, "</font><br>\n" if @_;
    printEnvironment(*F);
    print F "</body></html>";
    close F;

    chmod 0444, "$file";
    return $n;
  }
}

########################################################################################################################
# End of TDL::Admin
1;