#!/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 = 0;


#####
# web heartbeat system utilities
#####


package hbu;
require 5.000;
require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw(ip4v keyg keyv keyl concatkey parsekey julsec secjul stalekey namecode keyr ruleset parmv failbail);
@EXPORT_OK = qw($sip $reapt $t $e $w);

use strict;
use Sys::Syslog;

BEGIN {
    push(@INC, '/usr/local/libexec/authhb');
}


#####
# external constants must be visible
#####
use vars '$sip';
use vars '$reapt';
use vars '$t';
use vars '$e';
use vars '$w';
use vars '$dr';
$sip = '128.117.128.1';                         # ip of heartbeat web server
$reapt = 91;                                    # ips reapable after this many secs dead
$t = int ($reapt / 4);                          # normal refresh period in seconds
$e = "https://$sip/login.html";                 # error/timeout redirect URL
$w = 45;                                        # view time before error/timeout redirect
$dr = '/var/authhb/db';                         # database directory


#####
# setup/constants
#####
my $r = '< /dev/arandom';                       # random number device
my $kl = 4;                                     # key random number length in bytes
my $maxun = 16;                                 # max username length in bytes
my $maxut = 3;                                  # max usertype length in bytes
my $julsecl = 9;                                # length of timestamp on key
my $sep = '-';                                  # separator for key parts
my $filt = '/usr/local/sbin/sipf';              # filter binary for adding/removing rules
my $nat = '/usr/local/sbin/sipnat';             # filter binary for adding/removing rules
my %rules = ();                                 # the actual filter rules
$rules{0} = 'log in on xl1 proto tcp from USERIP/32 to any flags S';
$rules{1} = 'pass in quick on xl1 proto tcp/udp from USERIP/32 to any keep state keep frags';
$rules{2} = 'pass in quick on xl1 proto icmp from USERIP/32 to any keep state';
$rules{3} = 'pass in quick on xl1 proto ah from USERIP/32 to any';
$rules{4} = 'pass in quick on xl1 proto esp from USERIP/32 to any';
$rules{5} = 'pass in quick on xl0 proto ah from any to USERIP/32';
$rules{6} = 'pass in quick on xl0 proto esp from any to USERIP/32';
my %nats = ();
$nats{0} = 'rdr xl1 from USERIP/32 to any port = 80 -> 128.117.128.1 port 80 tcp';
$nats{1} = 'rdr xl1 from USERIP/32 to any port = 443 -> 128.117.128.1 port 443 tcp';
$nats{2} = 'rdr xl1 from USERIP/32 to any port = 53 -> 128.117.128.1 port 50053 udp';
my $authbin = '/usr/local/libexec/authhb/login';


$ENV{'PATH'} = '/usr/bin:/usr';


sub ip4v ($@) {
#####
# check provided dotted quad ip for syntax validity, optional subnet restrictions
#####
    my $ip = shift @_;
    my @snets = @_;
    my($x, @p, $nip);
    
    chomp $ip;
    if ( $ip =~ m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ ) {
        @p = ($1, $2, $3, $4);
        for ($x=0; $x<4; $x++) {
            if ( ($p[$x] > 255) || ($p[$x] < 0) ) {
                $ip = join ('.', @p);
                syslog ('err', 'octet out of range in IP %s', $ip);
                return 0;
            }
        }
        $nip = join ('.', @p);
#        if () {                                # need to write subnet restrictions
#            
#        }
        return $nip;
    } else {
        syslog ('err', 'DOH!  supposed IPv4 address was not dotted quad');
        return 0;
    }
}


sub keyg ($) {
#####
# get key for a particular ip
#####
    my $ip = shift @_;
    
    my ($path, $k, $rl);

    if ( $ip ) {
        $path = "<" . $dr . "/" . $ip;
        if ( ! open (KEY, $path) ) {
            return 'ERRKEYG-1';
        }
        $rl = $maxun * 2 + $maxut * 2 + $kl * 2 + $julsecl;
        if ( ! read (KEY, $k, $rl) ) {
            close (KEY);
            return 'ERRKEYG-2';
        }
        close (KEY);
#        syslog ('debug', "read old key for %s: %s", $ip, $k);
        return $k;
    } else {
        return 'ERRKEYG-9';
    }
}


sub keyv ($$) {
#####
# check provided key for match with the one in the db
#####
    my $ip = shift @_;
    my $k = shift @_;
    my $o;
    
    $o = keyg ($ip);
    if ( $k =~ m/ERRKEY/ ) {
        return $k;
    }
    if ( $o eq $k ) {
        return 1;
    } else {
        return 'ERRKEYV-3';
    }
}


sub keyl ($$$) {
#####
# generate and store new random key for next time, replacing any old key
#####
    my $un = shift @_;          # usename
    my $ut = shift @_;          # usertype
    my $ip = shift @_;          # user's current ip address
    
    my(@s, $c, $tim, $path, $k);
    
    if ( ! $ip ) {
        syslog ('err', 'DOH!  cannot create key without ip');
        return 'ERRKEYL-9';
    } else {
        if ( ! open (RAND, $r) ) {              # create random key
            return 'ERRKEYL-1';
        }
        if ( ! read (RAND, $c, $kl) ) {
            close (RAND);
            return 'ERRKEYL-2';
        }
        close RAND;
        @s = unpack ('h*', $c);                 # present random in hex
        $c = join ('', @s);
        $tim = julsec (time);
#        syslog ('debug', 'key parts: %s, %s, %s %s', $un, $ut, $c, $tim);
        $k = concatkey ($un, $ut, $c, $tim);
#        syslog ('debug', 'concatenated key: %s', $k);
        # save it for later
        $path = ">" . $dr . "/" . $ip;
        if ( ! open (KEY, $path) ) {
            return 'ERRKEYL-3';
        }
        if ( ! print (KEY $k) ) {
            close (KEY);
            return 'ERRKEYL-4';
        }
        close (KEY);
        return $k;
    }
}


sub julsec ($) {
#####
# julian date epoch this year with secs since midnight gmt, from seconds
#####
    my $tim = shift @_;
    my ($jul, $sec);
    
    my @bunch;
    
    @bunch = gmtime($tim);
    $jul = $bunch[7];
    $sec = $bunch[0] + $bunch[1]*60 + $bunch[2]*3600;
    return $jul . "." . $sec;
}


sub secjul ($) {
#####
# seconds, from julian date epoch this year with secs since midnight gmt
#####
    my $js = shift @_;
    
    my ($jul, $sec);
    
    if ( defined $js ) {
        ($jul, $sec) = split (/\./, $js);
        $sec += $jul * 86400;
        return $sec;
    } else {
        return 0;
    }
}


sub stalekey ($) {
#####
# is the key stale?
#####
    my $k = shift @_;
    
    my ($un, $ut, $r, $js, $window, $now, $left);
    
    ($un, $ut, $r, $js) = parsekey ($k);    # pull timestamp out of key
    $window = secjul ($js) + $reapt;		# adjust for lifetime
    $now = secjul (julsec (time));          # current time in seconds, this epoch
    $left = $window - $now;					# the lifetime left
    if ( $left < 0 ) {
        return abs ($left);					# no life left, return time of death
    } else {
        return 0;
    }
}


sub namecode ($$) {
#####
# encode or decode username
#####
    my $un = shift @_;          # username
    my $encode = shift @_;      # do we encode or decode?
    
    if ( defined $un ) {
        if ( $encode ) {
            $un = unpack ('h*', $un);
        } else {
            $un = pack ('h*', $un);
        }
        return $un;
    } else {
        return 'NULL';
    }
}


sub keyr ($) {
#####
# remove an old set of rules and key, if it exists
#####
    my $ip = shift @_;
    my ($removed, $er, $path);
    
    if ( $ip ) {
        $path = $dr . "/" . $ip;
        # remove rules, log failures but continue to remove db entries
        if ( $er = ruleset ($ip, 'RMV') ) {
            syslog ('info', '%s: rule removal failure for %s', $er, $ip);
        }
        $removed = unlink($path);
        if ( $removed ) {
            syslog ('info', 'removed key file "%s" for IP %s', $path, $ip);
        } else {
            syslog ('info', 'no key file "%s" to remove for IP %s', $path, $ip);
        }
        return undef;
    } else {
        syslog ('err', 'DOH!  no key specified for removal');
        return 'ERRKEYR-1';
    }
    return undef;
}


sub concatkey ($$$$) {
#####
# build key out of parts
#####
    my ($un, $ut, $r, $j) = @_;
    
    my $k;
    
    $un = namecode ($un, 1);
    $ut = namecode ($ut, 1);
    $k = join ($sep, $un, $ut, $r, $j);
    return $k;
}


sub parsekey ($) {
#####
# split key into decoded parts
#####
    my $k = shift @_;
    
    my ($un, $ut, $r, $j);
    
    ($un, $ut, $r, $j) = split (/$sep/o, $k);
    $un = namecode ($un, 0);
    $ut = namecode ($ut, 0);
    return ($un, $ut, $r, $j);
}


sub ruleset ($$) {
#####
# add or remove filter/nat rules
#####
    my $ip = shift @_;
    my $ar = shift @_;
    my ($ipr, $ipn, $resp, $command, $rule, $num, $an);
    
    if ( $ar eq 'ADD' ) {
        $ar = '';
        $an = '-r';
    } else {
        $ar = '-r';
        $an = '';
    }
    foreach $rule ( sort (keys (%rules)) ) {
        $ipr = $rules{$rule};
        $ipr =~ s/USERIP/$ip/;
        $command = "echo \"$ipr\" | $filt $ar -f -";
#        syslog ('debug', 'DEBUG: generated filter line "%s"', $command);
        $resp = `$command`;
#        syslog ('debug', 'output from filter application "%s"', $resp);
    }
    foreach $rule ( sort (keys (%nats)) ) {
		$ipn = $nats{$rule};
        $ipn =~ s/USERIP/$ip/;
        $command = "echo \"$ipn\" | $nat $an -f -";
        syslog ('debug', 'DEBUG: generated nat line "%s"', $command);
        $resp = `$command`;
#        syslog ('debug', 'output from nat application "%s"', $resp);
    }
    # clear lingering RDR from state table to accomodate linux resolver
    # which reuses the same source port for subsequent queries
    $command = "$nat -F";
    $resp = `$command`;
#    syslog ('info', 'DEBUG: flush system %s returned %s', $command, $resp);
    
    return undef;
    
    #####################################
    # NOTE -- after secure setuid rule addition application is written (and example
    # rules above moved there), this routine will be redone so it returns an error
    # code if the rule sets fail.
    #####################################
    return $resp;
}


sub parmv ($@) {
#####
# validate parameters: number, name, and type of each
#####

# CGI must be included by routines using this package

    my $p = shift @_;
    my @parml = sort (@_);
    
    my @parms = sort ($p->param);
    
    return undef;               # stub: anything goes for now due to 'submit' problem
    
    # make sure all expected parameters are present, and no others
#    if ( @parml != @parms ) {
#        return 'ERRPARM-1';
#    } else {
#        # still need to write type checking
#        return undef;
#    }
}


sub failbail ($$$) {
#####
# heartbeat failure, bailout
#####

# CGI must be included by routines using this package

    my $q = shift @_;
    my $ip = shift @_;
    my $message = shift @_;
    
    print $q->header(-Refresh=>"$w; URL=$e"),
        $q->start_html(-title=>"Error Report", -bgcolor=>"white", -text=>"black"),
        $q->h2("Error Report"),
        $q->p("The system reports the following error:"),
        $q->p("<font color=\"red\">$message</font>"),
        $q->p("You may be able to use the back button on your browser to correct the problem.  If that does not help, you might try <a href=\"$e\">logging in</a> again from the top.");
        if ( $DEBUG ) {
            print $q->hr,
                $q->p("Here is some debugging information for the test."),
                $q->p("The argument list on the previous fetch was"),
                $q->dump,
                $q->p("You connected from IP address: $ip"),
                $q->p("The HTTP refresh header on this page tells your browser to fetch <a href=\"$e\">URL=$e</a> after $w seconds.");
        }
        print $q->end_html;
    closelog ();
    exit 0;
}


1;