#!/usr/bin/perl -wT
# System administration
#
package TDL::Admin;

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

our ($adminCheckRun, $isAdminIP, $isAdminUser, $VERSION);
$VERSION = "1.0";
$isAdminUser = 0;
$isAdminIP = 0;
$adminCheckRun = 0;

use strict;
use CGI;
use CGI::Carp qw ( fatalsToBrowser );

########################################################################################################################
# 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;

        open HTA,$fName or die "Unable to open the access file: $!<n>";
        my @htaccess = <HTA>;
        close HTA;

        my $line;
        foreach $line (@htaccess)
        {
            my @words = split(' ', $line);
            if (scalar(@words) == 4 && $words[0] eq "#\$#")
            {
                if ($words[1] =~ m/^allow$/i)
                {
                    if ($words[2] =~ m/^user$/i)
                    {
                        $adminUser += tryAllow($remote_user, $words[3]);
                    }
                    elsif ($words[2] =~ m/^from$/i)
                    {
                        $adminIP += tryAllow($remote_addr, $words[3]);
                    }
                }
            }
        }

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

########################################################################################################################
# determine if the current user or IP address has administrator privileges
BEGIN
{
    doAdminCheck();
}

########################################################################################################################
# Simple access to the isAdministrator variable
sub isAdmin
{
    if ($adminCheckRun == 0)
      { doAdminCheck(); }

    return $isAdminUser || $isAdminIP;
}

########################################################################################################################
# Generate a report about the check
sub adminReport
{
    my ($q) = @_;
    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;

        open HTA,$fName or die "Unable to open the access file: $!<n>";
        my @htaccess = <HTA>;
        close HTA;

        my $line;
        foreach $line (@htaccess)
        {
            my @words = split(' ', $line);
            if (scalar(@words) == 4 && $words[0] eq "#\$#")
            {
                if ($words[1] =~ m/^allow$/i)
                {
                    if ($words[2] =~ m/^user$/i)
                    {
                        if (tryAllow($remote_user, $words[3]))
  			    { print $q->p("$remote_user matches " . $words[3]); $adminUser++; }
                        else
  			    { print $q->p("$remote_user does not match " . $words[3]); }
                    }
                    elsif ($words[2] =~ m/^from$/i)
                    {
                        if (tryAllow($remote_addr, $words[3]))
  			    { print $q->p("$remote_addr matches " . $words[3]); $adminIP++; }
                        else
  			    { print $q->p("$remote_addr does not match " . $words[3]); }
                    }
                }
            }
        }

        print $q->p("Matched user " . $adminUser . " times; setting says " . $isAdminUser);
        print $q->p("Matched address " . $adminIP . " times; setting says " . $isAdminIP);
        print $q->p("Admin check run: " . $adminCheckRun);
    }
    else
    {
        print $q->p("$fName is not readable");
    }
}

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

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

    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
    my $q = new CGI;
    my @rows;

    my $envCount = 0;
    foreach my $envName ($q->param)
    {
	$envCount++;
	push(@rows, "<tr valign=top><td>$envName</td><td>", $q->param($envName), "</td></tr>\n");
    }

    if ($envCount > 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";
	print F @rows;
	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";
	foreach my $envName ($q->param)
	{
            print F "Form field: $envName<br>\n";
            print F "<textarea name=\"", $envName, "\" rows=4 cols=80>", $q->param($envName), "</textarea><p>\n";
	}
        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
{
    $ENV{DOCUMENT_ROOT} =~ m/^(.*)$/;
    my $dumpDir = $1;
    $dumpDir =~ s/\/htdocs/\/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;

    $! = 0;
    open F, ">$file";
    return if 0 != $!;

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

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

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