#!/usr/local/bin/perl -Tw

#  Copyright (c) 2000 River of Stars, LLC.  All rights reserved.
#  
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#  3. All advertising materials mentioning features or use of this software
#     must display the following acknowledgement:
#       This product includes software developed by River of Stars, LLC.
#  4. The name of the author may not be used to endorse or promote products
#     derived from this software without specific prior written permission.
#  
#  THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
#  IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
#  OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
#  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
#  INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
#  NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
#  DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
#  THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
#  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
#  THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

my $DEBUG = 1;

#####
# password script
#####


use strict;
use CGI qw/:standard/;
use Sys::Syslog;

BEGIN {
    push(@INC, '/usr/local/libexec/authhb', '/home/rjohnson/hb/');
}
use hbu;


#####
# setup/constants
#####

my @parml = ('key', 'pw');			# valid parameter name and type list
my $u = "https://$hbu::sip/cgi-bin/hb.pl?key=";	# heartbeat base URL
my $t = 1;					# timeout for base refresh so back works
if ( $DEBUG ) { $t += 7; }			# boost timeout for debug info
my %authprog = ();				# authentication binaries
$authprog{'ltu'} = '/usr/local/libexec/authhb/authhb-bsdauth';
$authprog{'stu'} = '/usr/local/libexec/semnah/authhb-semnah.pl';
my %authclass = ();				# authentication classes for user types
$authclass{'ltu'} = 'tisauth';
$authclass{'stu'} = 'semnah';


#####
# var declarations
#####

my($q, $ip, $er, $key, $okey, $kv, $un, $ut, $pw, @authargs, $ar);


#####
# prototypes predeclarations to avoid screwing up line number reports
#####

sub refreshing ($$$);


#####
# main
#####


openlog('webhb-pw', 'pid', 'local6');		# set specialized options for syslog
$q = new CGI;
if ( $ip = $ENV{'REMOTE_ADDR'} ) {
    if ( ! ($ip = ip4v($ip)) ) {
        syslog ('info', 'invalid remote ip %s', $ip);
        failbail ($q, $ip, "invalid remote ip $ip");
    }
} else {
    $ip = '192.168.1.1';			# stub for testing script standalone
}
syslog ('info', 'connection from %s for pw', $ip);
if ( $er = parmv($q, @parml) ) {		# is someone monkeying with our params?
    syslog ('err', 'parameters from %s unrecognized: %s', $ip, $er);
    failbail ($q, $ip, "parameters from $ip unrecognized: $er");
}
$okey = $q->param('key');
($un, $ut, my @tr) = parsekey ($okey);	# pull username & type off front of key
$kv = keyv ($ip, $okey);			# does provided key match what's in db?
if ( $kv ne '1' ) {
    $er = keyr ($ip);				# make sure any bogus key & rule goes away
    syslog ('warning', '%s: browser at %s gave nonmatching key "%s" for user "%s"', $kv, $ip, $okey, $un);
    failbail ($q, $ip, "$kv: browser at $ip gave nonmatching key \"$okey\" for user \"$un\"");
}
if ( $q->param('pw') ) {
    $pw = $q->param('pw');
} else {
    $pw = '';
}
unless ( ($ut eq 'stu') || ($ut eq 'ltu') ) {	# user types are constrained
    syslog ('warning', 'improper user type "%s" for username "%s"', $ut, $un);
    failbail ($q, $ip, "improper user type \"$ut\" for username \"$un\"");
}
# authenticate the username with the password
# (challenge-response/token support still needs to be written)
@authargs = ('-u', $un, '-p', $pw, '-c', $authclass{$ut});
syslog('debug', 'authargs: %s', join(@authargs));
$ar = 256;
unless ( $ar = system($authprog{$ut}, @authargs) == 0) {
    $ar = $ar/256;
    syslog ('notice', 'authentication failure %d for username "%s"', $ar, $un);
    failbail ($q, $ip, "authentication failure $ar for username \"$un\"");
}
syslog ('notice', 'authentication successful for (%s) "%s" on %s', $ut, $un, $ip);
$key = keyl($un, $ut, $ip);			# generate and store new key
if ( $key =~ m/^ERRKEY/ ) {			# did storage of new key work?
    syslog ('err', '%s: new key generation or storage failure for %s', $key, $ip);
    failbail ($q, $ip, "$key: new key generation or storage failure for $ip");
}
$er = ruleset ($ip, 'ADD');			# add rule to allow traffic from user's IP
if (defined($er) and ($er =~ m/^ERRRULE/)) {	# did rule change work?
    syslog ('err', '%s: rule addition failure for %s', $er, $ip);
    failbail ($q, $ip, "$er: rule addition failure for $ip");
}
refreshing ($q, $ip, $key);			# no problems, so start refreshing hb

closelog ();
exit 0;


sub refreshing ($$$) {
#####
# redirect via refresh to heartbeat cgi
#####
    my $q = shift @_;
    my $ip = shift @_;
    my $key = shift @_;
    
    print $q->header(-Refresh=>"$t; URL=$u$key"),
        $q->start_html(-title=>"Refreshing Momentarily", -bgcolor=>"white", -text=>"black");
        if ( $DEBUG ) {
            print $q->p("Here is some debugging information for the test."),
#                $q->p("The argument list on the previous fetch was"),
#                $q->dump,
                $q->p("The username was recognized as: $un"),
                $q->p("The password was recognized as: (no, we will not show it to that shoulder-surfer behind you :-)"),
                $q->p("The usertype was recognized as: $ut"),
                $q->p("You connected from IP address: $ip"),
                $q->p("The HTTP refresh header on this page tells your browser to fetch <a href=\"$u$key\">URL=$u$key</a> after $t seconds.");
        }
    print $q->end_html;
}