#!/usr/bin/perl -T
###
###              analog 4.11             http://www.analog.cx/
### This program is copyright (c) Stephen R. E. Turner 1995 - 2000 except as
### stated otherwise. Distribution, usage and modification of this program is
### subject to the conditions of the Licence which you should have received
### with it. This program comes with no warranty, expressed or implied.
### Remember: Even the most carefully-designed CGI programs can accidentally
### have serious security bugs! See docs/form.html for notes on security
### design.
###
### anlgform.pl; the cgi front end for analog

# 1) uncomment (remove everything before $analog) and edit one of the next two
#    lines to give the location (full pathname) of the analog executable.
$analog = '/Local/Applications/analog-4.11/analog';
#       Windows: $analog = 'C:\program files\analog 4.11\analog.exe';
# 2) If you're on Unix, edit the first line in this file to give the location
#    of Perl (don't remove the #! though).
# 3) You also need to edit anlgform.html if you want to use the form.
# 4) Add to the forbidden commands below if you want.

@forbidden = qw(LOGFORMAT APACHELOGFORMAT DEFAULTLOGFORMAT
		APACHEDEFAULTLOGFORMAT HEADERFILE FOOTERFILE UNCOMPRESS
		OUTFILE CACHEOUTFILE ERRFILE DNS CGI SETTINGS LANGFILE);
# Forbidden commands: sysadmin can add more (must be in upper case!)
# Other commands you might consider adding, because they allow users to
# specify which files to use for the analysis, are LOGFILE and DOMAINSFILE.
# There is a discussion of all this in docs/form.html.

require 5.001;
use CGI;

# 1) INITIALISATION
$ENV{PATH} = '';
$query = new CGI;
$|=1;
$lt = localtime;
$progname = $0 || 'anlgform.pl';
if (($^O =~ /win32/i || $^O =~ /^win/i) && Win32::GetShortPathName($analog)) {
    $analog = Win32::GetShortPathName($analog);
}

# coerce query keys to caps in a new (key, pointer to array) hash called args
# also remember the order the keys arrived in, as far as possible
foreach $p ($query->param) {
    foreach $a ($query->param($p)) {
	checkchars($a);
	push(@order, "\U$p") unless ($args{"\U$p"});
	push(@{$args{"\U$p"}}, $a);
    }
}

# check LOGFILE and CACHEFILE only contain safe chars (see comments below)
checkfilechars("LOGFILE");
checkfilechars("CACHEFILE");

# 2) OPEN THE ANALOG PROCESS
# qv=1 causes args to go straight to stdout, not program
if (${$args{'QV'}}[-1] && !grep('QV' eq $_, @forbidden)) {
    print "Content-Type: text/plain\n\n";
    open(ANALOG, ">-");
}
elsif (!$analog) {
    badreq(500, "Program Incorrectly Configured",
	   "Can't run analog because anlgform.pl not set up properly.\n",
	   "See the server's error log for more details.");
    print STDERR "[$lt] $progname: Can't run analog because the variable \$analog was not set: read the setup instructions!\n";
    die;
}
elsif (!(-x $analog)) {
    badreq(500, "Program Incorrectly Configured", "Can't run analog.",
	   "See the server's error log for more details.");
    print STDERR "[$lt] $progname: Can't run analog because \"$analog\" not found or not executable";
    print STDERR ": $!" if ($!);
    print STDERR ".\n";
    die;
}
else {
    open (ANALOG, "|$analog +g-");  # errors here will get caught on close
}

# 3) PRINT ALL THE COMMANDS
# Special cases: must come first
printargs('CG', 'CONFIGFILE') unless grep('CG' eq $_, @forbidden);
print ANALOG "CGI ON\nDNS NONE\nWARNINGS FL\n";
printargs('WARNINGS') unless grep('WARNINGS' eq $_, @forbidden);
printargs('LOGTIMEOFFSET') unless grep('LOGTIMEOFFSET' eq $_, @forbidden);
foreach $k (@order) {
    printargs($k)
        unless($k eq 'QV' || $k eq 'CG' || $k eq 'CM' || $k =~ /FLOORB$/ ||
	       $k =~ /2$/ || $k =~ '^LOGTIMEOFFSET' || $k =~ '^WARNINGS' ||
               # commands dealt with elsewhere
               $k =~ /[^A-Z12]/ || $k eq '' ||
	       grep($k =~ /^$_.?$/, @forbidden) ||
	       $k =~ /^IGNORE/); # other stuff not wanted
}
# Special case: must come last
printargs('CM', 'CONFIGFILE') unless grep('CM' eq $_, @forbidden);
print ANALOG "OUTFILE stdout\n";

# 4) WAIT FOR PROCESS TO FINISH. THAT'S IT.
unless (close(ANALOG)) {
    badreq(500, "Program Failure", 
	   "Analog failed to run or returned an error code.",
	   "Maybe your server's error log will give a clue why.");
    print STDERR "[$lt] $progname: \"$analog\" failed to run or returned an error code";
    print STDERR ": $!" if ($!);
    print STDERR ".\n";
    die;
}

# A) PRINT ONE COMMAND
sub printargs {
    my($is_floora) = 0;
    my($is_12) = 0;
    my($name) = $_[1] || $_[0];
    if ($name =~ /FLOORA$/) {
	chop($name);
	$is_floora = 1;
	$b = ${$args{$name . 'B'}}[-1];
    }
    elsif ($name =~ /1$/) {
	chop($name);
	$is_12 = 1;
	$b = ${$args{$name . '2'}}[-1];
    }
    foreach $a (@{$args{$_[0]}}) {
	if ($a ne '') {
	    if ($is_floora) {
		print ANALOG ("$name $a$b\n") if ($b ne '');
	    }
	    elsif ($is_12) {
		print ANALOG ("$name ", bracket($a), " ", bracket($b), "\n")
		    if ($b ne '');
	    }
	    else {
		print ANALOG ("$name ", bracket($a), "\n");
		print ANALOG ("DNS READ\n") if ($name eq 'DNSFILE');
	    }
	}
    }
}

# B) PUT APPROPRIATE DELIMITERS ROUND AN ARGUMENT CONTAINING SPACES
sub bracket {
    local $_ = $_[0];
    return $_ unless (/[\s\#]/ || /^['"\(]/);
    return "\"$_\"" unless (/"/);
    return "'$_'" unless (/'/);
    return "($_)";
    # analog has no syntax if string contains ) as well as space, ' and "
}

# C) CHECK ONLY SAFE CHARACTERS in LOGFILEs and CACHEFILEs. See docs/form.html.
sub checkfilechars {
    local ($_);
    foreach (@{$args{$_[0]}}, @{$args{$_[0] . '1'}}) {
	if (m([^\w\. /\\:-]) || m(\W-|^-|-\W|-$)) { # NB \w includes underscore
	    badreq(403, "Illegal Request", "Unsafe characters in $_[0].");
	    printf STDERR "[$lt] $progname: Unsafe characters in \"$_[0] $_\" on request from %s\n", $ENV{REMOTE_HOST}?$ENV{REMOTE_HOST}:($ENV{REMOTE_ADDR}?$ENV{REMOTE_ADDR}:"unknown host");
	    die;
	}
    }
}

# D) CHECK ONLY SAFE CHARACTERS IN OTHER COMMANDS. Again, see docs/form.html.
sub checkchars {
    local $_ = $_[0];
    if (/[\x00-\x1F\x7F-\x9F]/) {
	badreq(403, "Illegal Request", "Unsafe characters in \U$p.");
	printf STDERR "[$lt] $progname: Unsafe characters in \"\U$p\E $_\" on request from %s\n", $ENV{REMOTE_HOST}?$ENV{REMOTE_HOST}:($ENV{REMOTE_ADDR}?$ENV{REMOTE_ADDR}:"unknown host");
	die;
    }
}

# E) PRINT OUT ERROR MESSAGE
sub badreq {
    my($i);
    print "Content-Type: text/html\n";
    print "Status: $_[0] $_[1]\n\n";
    print '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">';
    print "\n<html><head><title>$_[0] $_[1]</title></head>\n";
    print "<body><h1>$_[1]</h1>\n";
    for ($i = 2; defined($_[$i]); $i++) {
	print "<br>" if ($i >= 3);
	print "$_[$i]\n";
    }
    print "</body></html>\n";
}