#!/usr/bin/perl -w
# keepalive - keep slip connection running
# tchrist@perl.com
#
# inspired by Larry Wall's slipup.
# hacked up by Tom Christiansen
# then rewritten by Drew Eckhardt.
# then re-hacked up by Tom Christiansen again

use strict;
use Carp;

# GLOBALS for this program
use vars qw{
    $PING_COUNT
    $PING_INTERVAL
    $PING_TIMEOUT
    $PING_SLEEP
    $KILL_TIMEOUT
    $START_RETRY_MAX
    $START_RETRY_INITIAL
    $DIAL_SLEEP_MAX
    $DIAL_TIMEOUT 
    $REQUIRED_PING_PERCENTAGE
    $DIAL_SLEEP_INITIAL 
    $DTR_DROP

    $PID_FILE
    $LOCK_PREFIX
    %SUPRA_ERRORS

    $PROGNAME

    $verbose
    $debug
    $no_daemon
    $state

    $am_supra
    $use_modules

    $PID_FILE
    $LCK_PREFIX

}; 


$PROGNAME = $0;

# i don't like these globals
use vars qw{
    $timeout
    $str

    $start_retry_current
    $have_started 
    $forked
    $known_alive
    $tty

};

# GLOBALS from /etc/keepalive.conf
use vars qw{
    $PHONE
    $ACCOUNT
    $PASSWORD
    $LOCAL
    $REMOTE
    $NETMASK
    $MTU
    $DEVICE
    $RATE
    $MODE
};

# Configuration defaults; in seconds


$PING_COUNT = 10;		# How many ping packets to send
$PING_INTERVAL = 1;		# How frequently should we send a new packet
# How long is too long to have had no response;  ping will wait for 10 seconds
# after it sends out its last packet.  We'll give it 50 extra beyond that, 
# because for some reason it seems to require this.  ping takes a non-deterministic
# time to timeout!!  this is a bug.
$PING_TIMEOUT = 60 + ($PING_COUNT * (1+$PING_INTERVAL)); 
$PING_SLEEP = 60;		# How long should we sleep between bings
$REQUIRED_PING_PERCENTAGE = 40;  # should be 90?

$KILL_TIMEOUT = 5;		# How long should kill_pid wait before using 
				# the next signal
$START_RETRY_MAX = 600;		# Maximum time for exponential backoff for 
				# establishing the SLIP connection.
$START_RETRY_INITIAL = 15;	# Starting value for same.
$DIAL_SLEEP_MAX = 600;		# Maximum time for exponential backoff
    	    	    	    	# for dialing in.
$DIAL_TIMEOUT = 60;
$DIAL_SLEEP_INITIAL = 15;	# Initial value for same
$DTR_DROP = 2;			# How long to drop DTR for to get modem

# $verbose    = "";
$verbose    = 1;
# $debug	    = "";
$debug	    = 1;
$no_daemon  = 1;
# $have_started = "";

$str        = "";

$| = 1;

#require 'syscall.ph';
#require 'sys/file.ph';
#require 'termios.ph';

use FileHandle;
use Fcntl;
sub TIOCEXCL() { 0x540C }

$SIG{ALRM} = 'DEFAULT';

# Various 'constants'
$PID_FILE = '/var/run/keepalive.pid';
$LCK_PREFIX = '/var/spool/uucp/LCK..';		# Lock file prefix

# S86 error codes for SUPRA (and presumably other Rockwell chipset 
# based modmes)
%SUPRA_ERRORS = (
     0 => 'Normal hangup initiated by local',
     4 => 'Carrier loss',
     5 => 'No error correction at other end',
     6 => 'No response to feature negotiation',
     7 => 'This modem is ASYNC only, other is SYNC',
     8 => 'No framing technique in common',
     9 => 'No protocol in common',
     10 => 'Bad response to feature negotiation',
     11 => 'No sync information from remote',
     12 => 'Normal hangup initiated by remote',
     13 => 'Retransmission limit reached',
     14 => 'Protocol violation occured'
);

# Globals
use vars qw(%have_lck $ping_pid %added_modules);
%have_lck = ();
$ping_pid = 0;
%added_modules = ();

# FUNCTIONS
    sub configure_serial($$);
    sub debug($);
    sub fatal_signal($);
    sub get_char();
    sub get_error($);
    sub get_lck($);
    sub get_pid;
    sub have_module($);
    sub is_reachable($);
    sub kill_pid($);
    sub logger($);
    sub mysleep($);
    sub pass_lck($$);
    sub pass_pid($);
    sub release_lck($);
    sub release_pid();
    sub remove_modules(@);
    sub require_modules(@);
    sub send_modem($);
    sub set_state($);
    sub start_slip($$$$$$$$);
    sub stop_slip();
    sub timeout_handler($);
    sub wait_for($);
    sub wait_pat($);

#logger($message) - loggers $message as coming from $serivce.  Returns
#-1 on failure, 0 on success.
# TESTED

sub logger($) {
    my($message) = @_;
    print STDERR localtime() . " LOG: " . $message . "\n";
    open(LOG, "|/usr/bin/logger -t $0") || return -1;
    print LOG $message;
    close(LOG);
    return 0;
}

sub set_state($) {
    $state = shift;
    $0 = "$PROGNAME [$state]";
    # print STDERR "[STATE => $state]\n" if $verbose;
} 

sub debug($) {
    if ($debug) { 
	my $msg = shift;
	$msg .= "\n" unless $msg =~ /\n$/;
	print STDERR localtime() . " DEBUG: " . $msg;
    }
} 

sub verbose($) {
    if ($verbose) { 
	my $msg = shift;
	$msg .= "\n" unless $msg =~ /\n$/;
	print STDERR $msg;
    }
} 

sub mysleep($) {
    my $sex = shift;
    # debug("sleeping $sex");
    unless($SIG{ALRM} eq 'DEFAULT') {
	confess("SLEEPING WHILE AWAITING ALARM $SIG{ALRM}");
    } 
    sleep($sex);
}

sub vsystem($) {
    verbose($debug && "SYSTEM " . "@_") if $verbose;
    return system(@_);
} 

# Handle fatal signal by doing clean shutdown
# TESTED
sub fatal_signal($) {
    logger("got SIG$_[0]");
    logger("killing $ping_pid") if ($debug && $ping_pid);
    kill_pid($ping_pid) if ($ping_pid);
    logger("removing modules") if ($debug);
    remove_modules(keys %added_modules);
    release_lck($DEVICE);
    release_pid();
    exit;
} 

# Handle timeout on ping(ALRM) by killing PING process.  Pending read in
# while (<PING>) should return -1 errno = EPIPE causing that loop to terminate.

sub timeout_handler($)  {
    logger("TIMEOUT");
    kill_pid($ping_pid) if $ping_pid;
}

# Kill process using increasingly insistant signals.
# kill_pid($pid)  returns undef on failure; non-zero on success.
# TESTED

sub kill_pid($) {
    my($pid) = @_;
    local $timeout;
    my $signal;
    logger("Attempting to kill $pid");
    if ($$ == $pid) {
    	logger("I'm $$; committing suicide\n");
    	return 0;
    } elsif ($pid < 0) {
    	logger("I'm $$; trying to kill process group $pid\n");
    	return 0;
    } elsif ($pid == 0) {
    	logger("I'm $$; trying to kill all my processes\n");
    	return 0;
    }
ZAP:  foreach $signal ( qw(TERM INT HUP KILL) )  {
	logger("zapping $pid with $signal");
    	kill($signal, $pid);
	my $time = time();
    	for ($timeout = $KILL_TIMEOUT; $timeout > 0; --$timeout) {
    	    kill(0, $pid) || last ZAP;
	    ###########################################
    	    ### sleep(1);  CANNOT SLEEP IN HANDLER  ###
	    ###########################################
	    1 until time() > (1 + $time);
    	}
    }
    logger("zapped $pid");
    return kill(0, $pid);
}

sub is_reachable($) {
    my($host) = @_;
    set_state("pinging $host");

    my $ret = 0;

    # need the exec because the 2> causes a shell to get in the way of the ping pid!
    # print STDERR "ping -i $PING_INTERVAL -c $PING_COUNT $host\n" if $debug;
    $ping_pid = 
        open(PING, "exec ping -i $PING_INTERVAL -c $PING_COUNT $host 2>&1 |");

    unless (defined $ping_pid) {
        logger("can not fork ping");
    } else {
	local $_;
	local $SIG{ALRM} = \&timeout_handler;
	# debug("alarm $PING_TIMEOUT");
        alarm($PING_TIMEOUT);
        while (<PING>) {
	    # debug("PING LINE: $_");
            if (/(\d+) packets transmitted, (\d+)/) {
		my $percent = sprintf "%d", 100 * ($2/$1) + 0.001;
		if ($percent != 100) {
		    my $time = localtime;
		    verbose("$time: PINGED $percent% of $PING_COUNT packets");
		} 
		if ($percent < $REQUIRED_PING_PERCENTAGE) { 
		    logger("only pinged $percent (want $REQUIRED_PING_PERCENTAGE)");
		    $ret = 0;
		} else {
		    $ret = 1;
		} 
		last;
            } elsif (/Network is unreachable/) {
		logger("Network down");
		$ret = 0;
		last;
	    } 
        }
	kill(9, $ping_pid);
	alarm(0);
	# debug("alarm CLEARED");
	close(PING);
        $ping_pid = 0;
    }
    set_state("running slip");
    return $ret;
}

# get_lck(device) gets the lock file for device, returning 0 on success,
# -1 on failure.  Note that $have_lck{$device} will be modified on 
# success.
# TESTED
sub get_lck($) {
    my($device) = @_;
    my($lck, $file, $pid, $is_stale);
    $file = $LCK_PREFIX.$device;
    # FIXME : should probably do something to avoid an infinite loop here
    while (1) {
    	if (defined sysopen(LCK, $file, O_CREAT|O_WRONLY|O_EXCL, 0644)){ 
    	    # To start with, we will set it up so that the current process
    	    # owns the lock file.  When we fork, we'll reopen the lock
    	    # file and write the child's PID into it.
    	    $pid = pack('L', $$);
    	    # FIXME - should be atomic here w.r.t signals
    	    print LCK $pid;
    	    $have_lck{$device} = 1;
    	    close(LCK);
    	    return 0;
    	# FIXME - we should look at errno here too; and see WHY the open
    	# failed.  EEXIST is OK; EPERM, etc. would be bad.
    	} elsif (open(LCK, "<$file")) {
    	    $pid = '';
	    if (sysread(LCK, $pid, 4) == 4) {
	    	$pid = unpack('L', $pid);
    	    	kill(0, $pid) || ($is_stale = 1);
    	    } else {
    	    	$is_stale = 1;
    	    }
    	    if ($is_stale) {
    	    	logger("removing stale lock file $file");
    	    	if (!unlink($file)) {
    	    	    logger("can not remove stale lock file $file $!");
    	    	    return -1;
    	    	}
    	    } else {
    	    	logger("lockfile $file owned by process $pid exists");
    	    	return -1;
    	    }
    	}
    }
}

# pass_lck ($device, $newpid) changes ownership of the lock file; ie when 
# we have a daemon which forks and the child should inherit the file.  Returns
# 0 on success, -1 on error.
sub pass_lck($$) {
    my($device, $newpid) = @_;
    my($file) = $LCK_PREFIX.$device;
    $newpid = pack('L', $newpid);
    open(LCK, ">$file") || return -1;
    print LCK $newpid;
    close(LCK);
    return 0;
}

# release_lck(device) releases the lock file for the named file.
sub release_lck($) {
    my($device) = @_;
    my($lock_file);
    if($have_lck{$device}) {
    	$lock_file = $LCK_PREFIX.$device;
    	unlink $lock_file;
    	$have_lck{$device} = 0;
    }
}

sub get_pid {
}

sub pass_pid($) {
    my($newpid) = @_;
    open(PID, ">$PID_FILE") || return -1;
    print PID "$newpid\n";
    close(PID);
    return 0;
}

sub release_pid() {
    unlink $PID_FILE;
}

# have_module($module) returns non-zero if we have the module
# TESTED
sub have_module($) {
    my($search_for) = @_;
    my($have_it) = 0;
    open(MODULES, "</proc/modules") ||
    	die "$0 can't open /proc/modules : $!\n";
    $have_it = -1;
    while(<MODULES>) {
    	if(/^$search_for/) {
	    $have_it = 0;
    	    last;
    	}
    }
    close(MODULES);
    return $have_it;
}

# nuke_modules(@modules) removes the named modules, returning a 
# list of the modules we could not remove.  The global variable added_modules
# is updated to reflect the modules currently loaded. 
sub remove_modules(@) {
    my($module, @failures);
    foreach $module (@_) {
    	vsystem("/sbin/rmmod $module");
    	if (have_module($module) == -1) {
    	    push(@failures, $module);
    	} else {
    	    delete $added_modules{$module};
    	}
    }
    return sort @failures;
}

# require_modules(@modules) adds the named modules, returning -1 on failure,
# 0 on success.  The global variable added_modules is updated to reflect the 
# modules currently loaded.
sub require_modules(@) {
    my($module);
    foreach $module (@_) {
    	if(have_module($module) == -1) {
    	    vsystem("/sbin/modprobe $module");
    	    if (have_module($module) != -1) {
    	    	$added_modules{$module} = 1;
    	    } else {
    	    	return -1;
    	    }
    	}
    }
    return 0;
}

# configure_serial($device, $bps) configures the named device in a manner
# compatable with a SLIP connection (rts/cts flow control, no soft flow,
# 8 data bits, no parity) at the selceted data rate.  Returns -1 on failure,
# 0 on success.

sub configure_serial($$) {
    my($device, $bps) = @_;
    vsystem("/bin/stty raw -echo -echonl cs8 -clocal crtscts $bps < /dev/$device") == 0;
}

# start_slip($device, $phone, $account, $password, $local,
#	$remote, $netmask, $mtu).  Returns undef on failure, MODEM on success.
sub start_slip($$$$$$$$) {
    my($device, $phone, $account, $password, $local, $remote, 
	$netmask, $mtu) = @_;
    set_state('initial');
    local($timeout);
    my($redial_timeout) = $DIAL_SLEEP_INITIAL;

    my(%initial) = (
	'TIMEOUT' 	=> 'reset',
	'OK' 	   	=> 'dial',
	'ERROR'	   	=> 'reset',
    );
    $initial{'regex'} = join('|', keys(%initial));

    my(%dial) = (
	'CONNECT'	=> 'connect',
	'NO CARRIER'	=> 'disconnect',
	'NO ANSWER' 	=> 'redial',
	'NO DIAL TONE' 	=> 'redial',
	'NO DIALTONE' 	=> 'redial',
	'BUSY' 		=> 'redial',
    	'OK' 		=> 'dial',
	'ERROR' 	=> 'reset',
	'TIMEOUT' 	=> 'reset',
    );
    $dial{'regex'} = join('|', keys(%dial));

    my(%connect) = (
	'login:' 	=> 'login',
	'NO CARRIER' 	=> 'disconnect',
	'ERROR' 	=> 'reset',
	'TIMEOUT' 	=> 'reset',
    );
    $connect{'regex'} = join('|', keys(%connect));

    my(%login) = (
	'Password:' 	=> 'password',
	'NO CARRIER' 	=> 'disconnect',
	'ERROR' 	=> 'reset',
	'TIMEOUT' 	=> 'reset',
    );
    $login{'regex'} = join('|', keys(%login));

    my(%password) = (
	'SL/IP session' => 'slip',
	'Packet mode enabled' => 'slip',
	'NO CARRIER' 	=> 'disconnect',
	'ERROR' 	=> 'reset',
	'TIMEOUT' 	=> 'reset',
    );
    $password{'regex'} = join('|', keys(%password));

    my(%disconnect) = (
	'^\d+' 	    	=> 'got_answer',
	'ERROR' 	=> 'reset',
	'TIMEOUT' 	=> 'reset',
    );
    $disconnect{'regex'} = join('|', keys(%disconnect));

    while (1) {
	if ($state eq 'initial') {
    	    $timeout = 10;
	    open(STDOUT, "+>/dev/$device") || do {
		logger("cannot open /dev/$device : $!");
    	    	die ;
		return undef;
	    };
    	    $| = 1;
	    unless (open(STDIN, "+<&STDOUT")) {
		logger("cannot DUP $tty STDOUT to STDIN : $!");
    	    	die;
		# NOT REACHED
		return undef;
	    }
    	    send_modem("atz\r");
	    set_state ( $initial{ wait_pat("($initial{'regex'})") } );
	} 
	if ($state eq 'dial') {
    	    $timeout = $DIAL_TIMEOUT;
	    send_modem("atdt$phone\r");
	    set_state ( $dial{wait_pat("($dial{'regex'})")} );
	} 
	if ($state eq 'redial') {
	    $redial_timeout *= 2 if ($redial_timeout < $DIAL_SLEEP_MAX);
	    mysleep($redial_timeout);
	    set_state ('dial');
	}
	if ($state eq 'connect') {
	    $redial_timeout = $DIAL_SLEEP_INITIAL;
    	    $timeout = 10;
	    set_state ($connect{wait_pat("($connect{'regex'})")} );
	}
	if ($state eq 'login') {
    	    $timeout = 10;
	    send_modem ("$account\n");
	    set_state( $login{wait_pat("($login{'regex'})")} );
	}
    	if ($state eq 'password') {
    	    $timeout = 10;
	    send_modem("$password\n");
	    set_state($password{wait_pat("($password{'regex'})")});
	} 
	if ($state eq 'slip') {

	    vsystem("/sbin/slattach -e -p cslip /dev/$device");
	    #vsystem("/sbin/ifconfig sl0 pointopoint $remote mtu $mtu $local");
	    vsystem("/sbin/ifconfig sl0 mtu $mtu $local");
	    #vsystem("/sbin/route add -host $remote gw $local dev sl0");
	    vsystem("/sbin/route add -net default sl0");

	    last;
	}
	if ($state eq 'disconnect') {
	    if (defined $am_supra)
	    {
		$timeout = 10;
		send_modem("ats86?\r");
		my $answer = wait_pat("($disconnect{'regex'})");
		if ($answer =~ /\d+/) {
		    set_state('got_answer');
		} else {
		    set_state($disconnect{$answer});
		}
	    }
	    else
	    {
		set_state('dial');
	    }
	}
	if ($state eq 'got_answer') {
	    logger('connection failed: $SUPRA_ERRORS{$answer+0}');
	    set_state('dial');
	}
	if ($state eq 'reset') {#
	    slip_close();
	    set_state('initial');
	}
    }
    return "MODEM";
}

sub wait_for($) {
	my($pattern) = @_;
	debug("WAITING FOR STRING:\n\t$pattern\n");

	while (1) {
	    if ($str =~ /\Q$pattern\E/) {
		$str = $';
		return $&;
	    }
	    return 'TIMEOUT' unless defined get_char();
	}
}

sub wait_pat($) {
	my($pattern) = @_;
	debug("WAITING FOR PATTERN:\n\t$pattern\n");

	while (1) {
	    if ($str =~ /$pattern/) {
		debug("GOT PATTERN $1");
		$str = $';
		return $&;
	    }
	    get_char();
	}
}

sub get_char() {
  my($rmask, $nfound, $timeleft, $thisbuf, $endtime);
  $endtime = time + $timeout;
  $rmask = "";
  vec($rmask,fileno(STDIN),1) = 1;
  ($nfound, $timeleft) = select($rmask, undef, undef, $endtime - time);
  if ((0 + $endtime - time) <= 0) {
	return undef;
  }
  if ($nfound) {
    my $nread = sysread(STDIN, $thisbuf, 1024);
    if (defined($nread)) {
      print STDERR $thisbuf if $debug;
      $str .= $thisbuf;
      return "" if $nread == 0; # eof
    }
  } else {
    return undef; # timeout ?
  }
}

sub send_modem($) {
    my $string = $_[0];
    debug("SENDING MODEM: \n\t$string\n\n");
    print $string;
}

sub stop_slip() {
    close (STDIN);
    close(STDOUT);
    mysleep($DTR_DROP);
}

sub get_error($) {
    my($device) = @_;
    my($match, $char);
    local $timeout;
    stop_slip();
    $tty = "/dev/$device";
    open (STDOUT, "+>$tty") || do {
	logger("cannot open $tty: $!");
	die ;
	return undef;
    };
    $| = 1;
    open(STDIN, "+<&STDOUT") || do {
	logger("cannot DUP STDOUT to STDIN : $!");
	die ;
	return undef;
    };
    mysleep(1);
    $timeout = 1;
    send_modem("ats86?\r");
    $match = wait_pat('(ERROR|TIMEOUT|^\d+)');
    stop_slip();
    return($match =~ /\d+/) ? $SUPRA_ERRORS{$match+0} : 'Unknown reason';
}

# main program
do '/etc/keepalive.conf' || do {
    logger('can not source /etc/keepalive.conf');
    exit 1;
};


{
    my $sig;
    foreach $sig (qw/INT HUP TERM/) {
	$SIG{$sig} = \&fatal_signal;
    }
}

if (get_lck($DEVICE) == -1) {
    logger('can not get lock; aborting');
    exit 1;
}

if (defined $use_modules)
{
    if (require_modules('slhc', 'slip') == -1) {
	logger ('can not install slhc and slip kernel modules; aborting');
	remove_modules(keys %added_modules);
	exit 1;
    }
}

if (configure_serial($DEVICE, $RATE) == -1) {
    logger("can not configure $DEVICE; aborting");
    remove_modules(keys %added_modules);
    exit 1;
}

$start_retry_current = $START_RETRY_INITIAL;
$have_started = 0;
$forked = 0;
$known_alive = 0;

while (1) {
    if (!$have_started || (is_reachable($REMOTE) == 0)) {
    	if ($have_started) {
    	    my $terminated = get_error($DEVICE);
    	    logger("slip connection died at ".localtime()."$terminated");
	    stop_slip();
    	    $known_alive = 0;
    	}
    	for ($start_retry_current = $START_RETRY_INITIAL; 
    	     !defined(start_slip($DEVICE, $PHONE, $ACCOUNT, 
				 $PASSWORD, $LOCAL, $REMOTE, 
				 $NETMASK, $MTU));
	     # VOID continue clause
				 ) 
	{
    	    $start_retry_current *= 2 
    	    	if ($start_retry_current < $START_RETRY_MAX);
    	}
    	debug("started slip");
    	$have_started = 1;
    	next;
    }
    if (! $known_alive) {
    	logger("$REMOTE is alive, will send $PING_COUNT $PING_INTERVAL-second pings every $PING_SLEEP seconds");
    	$known_alive = 1;
    }
    if (!$no_daemon && !$forked++) {
    	logger("Can't ioctl(TIOCEXCL) on STDOUT: $!")
	    unless ioctl(STDOUT, &TIOCEXCL, 0);
	my $child_pid;
    	unless (defined ($child_pid = fork)) {
    	    logger('can not fork; aborting');
    	    exit 1;
    	} elsif ($child_pid) {
    	    if (pass_lck($DEVICE, $child_pid) == -1) {
    	    	logger("can not pass lock for $tty to pid $child_pid");
    	    	exit 1;
    	    }
    	    logger("now in daemon mode, pid is $child_pid");
    	    exit 0;
    	}
    }
    mysleep($PING_SLEEP);
} 

#Use of uninitialized value at /usr/local/sbin/keepalive line 573.
#Use of uninitialized value at /usr/local/sbin/keepalive line 582.
#Use of uninitialized value at /usr/local/sbin/keepalive line 599.
#Use of uninitialized value at /usr/local/sbin/keepalive line 603.
#Use of uninitialized value at /usr/local/sbin/keepalive line 531.
#Use of uninitialized value at /usr/local/sbin/keepalive line 548.
##Use of uninitialized value at /usr/local/sbin/keepalive line 553.