#!/usr/bin/perl -w

# Copyright (C) 2000 Gavin Brock - This library is free software; you can
# redistribute it and/or modify it under the same terms as Perl itself.

print "********************************************************\n";
print "* Gavin & Jon's Perl/Tk AppServer for Ascend Pipelines *\n";
print "* Version 0.92 - Feb 2000     Use '-h' option for help *\n";
print "********************************************************\n";

my $profile  = 'profile';         # The profile for the pipline to use
my $user     = 'user';            # Your username >> CHANGE THIS <<
my $pipeline = '192.168.0.1';     # The IP of the pipeline
my $pipeport = 7001;              # The UDP port on which the pipline listens
my $pingto   = '192.168.1.1';     # An IP of a machine, across the pipline


#==============================================================================#
# Revison History
#
# 0.92 - 00/02/19 - Gavin Brock
#   Decided that this module needs a revison history.
#
#==============================================================================#

#==============================================================================#
# No user servicable parts from here down....
#

require 5.004;

use strict;
use Net::Ping;
use IO::Socket;
use IO::Select;
use Getopt::Long;
use Sys::Hostname;

my $notk      = 0;
my $verbose   = 0;
my $password  = '';
my $lineup    = 0;
my $sessup    = 0;
my $authfail  = 0;
my $authwin   = 0;
my $action    = '';
my $nofork    = 0;
my $braindead = ($^O =~ /Win32/);
my $challenge_magic = 0;

# The message types
my $msg_challenge = 1;
my $msg_password  = 2;
my $msg_up        = 3;
my $msg_down      = 4;

# Check command line
{
	local @ARGV = @ARGV;
	GetOptions(
		"profile|f=s"  => \$profile,
		"user|u=s"     => \$user,
		"pipeline|p=s" => \$pipeline,
		"pipeport|t=s" => \$pipeport,
		"pinghost|g=s" => \$pingto,
		"notk|n"       => \$notk,
		"verbose|v"    => \$verbose,
		"nofork|k"     => \$nofork,
		"c"            => \$challenge_magic, ## Magic force challenge flag
		"up|u"         => sub { $action = "U" },
		"down|d"       => sub { $action = "D" },
		"help|h"       => sub {
			print "\nUsage:\n\n";
			print "    -u or --up\n";
			print "       Send line up\n";
			print "    -d or --down\n";
			print "       Send line down\n";
			print "    -f or --profile profile_name\n";
			print "       Set the name of profile to use\n";
			print "    -u or --user username\n";
			print "       Set the user to log in as\n";
			print "    -p or --pipeline pipeline_address\n";
			print "       IP, or name of pipeline to talk to\n";
			print "    -t or --pipeport pipeline_port\n";
			print "       Pipeline port to talk to\n";
			print "    -n or --notk\n";
			print "       Don't even try to bring up the gui\n";
			print "    -g or --pinghost hostname\n";
			print "       Host to ping to check if line is up\n";
			print "    -k or --nofork\n";
			print "       Do not detach GUI\n";
			print "    -v or --verbose\n";
			print "       See what the code is doing\n";
			print "    -h or --help\n";
			print "       This screen\n";
			print "\n";
			exit;
		},
	);
	print "WARNING: The following arguments were ignored [@ARGV]\n" if @ARGV;
}



#==============================================================================#
# Main stuff
#

# Shall we use TK??
my $tk = 0;
unless ($notk) {
	eval 'use Tk';
	if ($@) {
		print $@ if $verbose;
		print "Using command line interface (Install Tk for gui).\n";
	} else {
		print "Tk loaded ok\n" if $verbose;
		eval '$tk = MainWindow->new()';
		if ($@) {
			print $@ if $verbose;
			print "WARNING: Can't open tk window.. using command line\n";
		}
		&detach unless ($nofork);
	}
}

## Text mode, can we hide passwords
my $readkey = 0;
my $stty = 0;
if ($notk) {
	eval 'use Term::ReadKey';
	if ($@) {
		print $@ if $verbose;
		print "Can't find Term::ReadKey module\n" if $verbose;
		foreach my $dir (split /[ :;]+/, $ENV{PATH}) {
			if (-x "$dir/stty") {
				print "Using $dir/stty instead" if $verbose;
				$stty="$dir/stty";
				last;
			}
		}
		print "Can't find Term::ReadKey module or stty, so your ".
			"password may be visible!!\n" if !$stty;
	} else {
		print "Term::ReadKey loaded ok\n" if $verbose;
		$readkey=1;
	}
}


my $sock = IO::Socket::INET->new(
	Proto => 'udp',
	LocalPort => $pipeport,
	Reuse => 1,
);
my $pipeaddr = sockaddr_in($pipeport, inet_aton($pipeline));

if ($tk) {
	&mainwin();
} else {
	&textmenu();
}



#==============================================================================#
# shared routines
# 

sub detach {
	## This is real OS specific
	if (!$braindead) {
		eval ' $tk->destroy; exit if fork;
			$tk = MainWindow->new(); ';
	} else {
		eval ' use Win32::Process qw(DETACHED_PROCESS);
			Win32::Process::Create($_, $^X, "perl $0 -k @ARGV",
			0,DETACHED_PROCESS,".") and exit; ';
	}
	print "Detach failed:\n$@" if ($@);
}


my $ping = 0;
sub ping {
	my $pingto=shift;
	my $time = shift;
	my $ping = Net::Ping->new("udp") unless $ping;
	my $res = $ping->ping($pingto,$time/1000);
	return $res;
}

sub checkline {
	my $time = @_ ? shift : 2000;
	if (&ping($pingto,$time)) {
		print "Line to [$pingto] is up.\n" if $verbose;
		$lineup = 1;
	} else {
		print "Line to [$pingto] is down.\n" if $verbose;
		$lineup = 0;
	}
}

sub encode {
	my ($type,$msg,$id) = @_;
	my $ip = inet_aton(hostname);
	my $port = $sock->sockport;
	my $pro_len = length($profile) + 1;
	my $msg_len = length($msg) + 1;
	my $tot_len = $msg_len+$pro_len+12;
	my $raw = pack("CCS", $type, $id, $tot_len).$ip.
		pack("SC",$port,$pro_len).
		$profile."\0".pack("C",$msg_len).$msg."\0";
	return $raw;
}

sub decode {
	my $data = shift;
	my $head = substr($data,0,11);
	my ($type,$id,$tot_len,$ip,$port,$pro_len) = unpack("CCSLSC",$head);
	## Could check here for stuff, but whoreally cares
	return { 
		type => $type,
		id   => $id,
	};
}
	
sub send_line_up {
	print "Bringing session up...\n" if $verbose;
	my $msg = &encode($msg_up,"",0);
	if (defined($_=$sock->send($msg,0,$pipeaddr))) {
		print "Sent [$_] bytes..\n" if $verbose;
	} else {
		print "ERROR: Can't send : $!\n";
	}
}

my %msgcache;
sub send_auth {
	my $id = shift;
	my $msg;
	if (defined $msgcache{$id}) {
		$msg = $msgcache{$id};
	} else {
		print "Sending auth [$password.$user] id [$id]...\n" if $verbose;
		$msg = &encode($msg_password,$password.'.'.$user,$id);
		$msgcache{$id} = $msg;
		$password='';
	}
	if (defined($_=$sock->send($msg,0,$pipeaddr))) {
		print "Sent [$_] bytes..\n" if $verbose;
	} else {
		print "ERROR: Can't send : $!\n";
	}
}

sub send_line_down {
	print "Taking line down...\n" if $verbose;
	my $msg = &encode($msg_down,"",0);
	if (defined($_=$sock->send($msg,0,$pipeaddr))) {
		print "Sent [$_] bytes..\n" if $verbose;
	} else {
		print "ERROR: Can't send : $!\n";
	}
}

sub handle_input {
	my $buf = '';
	my $hispaddr = $sock->recv($buf, 256, 0) || die "recv: $!";
	print "Read [",length($buf),"] bytes..\n" if $verbose;
	my $msg = &decode($buf);
	return $msg;
}


#==============================================================================#
# Test menu routines
#

sub textmenu {
	&checkline();
	$|=1;
	unless ($action) {
		$action = $lineup?'D':'U';
		print "Take line (U)p, (D)own or (Q)uit? [$action]: ";
		my $key;
		if ($readkey) {
			&ReadMode('cbreak');
			$key = &ReadKey(0);
			exit if $key eq "\004";
			print "$key\n";
		} else {
			defined($key = <STDIN>) || exit; chomp $key;
		}
		$action = uc $key if ($key =~ /^[udq]$/i);
		exit if $action eq "Q";
	}

	my $count = 5;
	if ($action eq "D") {
		print "Dropping line for [$profile] to [$pipeline]...\n";
		while (--$count) {
			&send_line_down();
			sleep 2;
			&checkline();
			last unless $lineup;
		}

		if (!$count) { print "WARNING: Line did not appear to drop\n"; exit }
		print "Line Dropped.\n";
	} else {
		my $id;
		print "Sending up request for [$profile] to [$pipeline]...\n";
		my $count = 10;
		my $sel = IO::Select->new($sock);
		while (!$sessup && --$count) {
			&send_line_up();
			$sessup = 1 if $challenge_magic;
			if ($sel->can_read(2)) {
				my $msg = &handle_input();
				if ($msg) {
					if ($msg->{type} == $msg_challenge) {
						$sessup=1;
						&tk_auth($msg->{id});
					} else {
						print "WARNING: Unknown message type..\n";
					}
				}
			}
		}
		if (!$count) { print "Session did not come up\n"; exit }

		print pack("C",7)."Password:";
		if ($readkey) {
			&ReadMode('noecho');
			$password = &ReadLine(0);
			&ReadMode('normal');
			print "\n";
		} else {
			system($stty,'-echo') if ($stty);
			$password = <>;
			chomp $password;
			system($stty,'echo') if ($stty);
			print "\n" if ($stty);
		}

		$count = 10;
		while (--$count && !$lineup) {
			&send_auth($id);
			sleep(1);
			&checkline();
		}
		if (!$count) { print "Line never came up\n"; exit }
		print "Line up.\n";
	}
	exit 0;
}


#==============================================================================#
# TK routines
#

sub mainwin {
	my $tk_up_b = $tk->Button(
	 	-text=>"UP",
		-underline=>0,
		-command => \&tk_send_line_up
	);
	my $tk_dn_b = $tk->Button(
	 	-text=>"DOWN",
		-underline=>0,
		-command => \&tk_send_line_down
	);
	my $tk_led=$tk->Label(-text => "  ");
		

	if (!$braindead) {
		$tk->fileevent($sock,'readable',\&tk_handle_input);
	} else {
		## Yuck, fileevents don't work on win32, but select does,
		## so we have to poll!! Spin fast!!
		my $sel = IO::Select->new($sock);
		$tk->repeat(1000, sub { &tk_handle_input if $sel->can_read(0.001) });
	}
	$tk_up_b->grid($tk_led,$tk_dn_b,-sticky => 'n,s,e,w');
	$tk->gridRowconfigure(0,-weight=>1);
	$tk->gridColumnconfigure(0,-weight=>1);
	$tk->gridColumnconfigure(1,-weight=>1);
	$tk->gridColumnconfigure(2,-weight=>1);


	{
		no strict;
		*tk_ledcolor = sub {
			my $color = shift;
			$tk_led->configure(-background=>$color);
			if ($color eq "red") {
				$tk_up_b->configure(-relief => "raised");
				$tk_dn_b->configure(-relief => "sunken");
			} elsif ($color eq "green") {
				$tk_up_b->configure(-relief => "sunken");
				$tk_dn_b->configure(-relief => "raised");
			}
					
		};
	}

	if ($action eq "U") {
		$tk_up_b->invoke();
	} elsif ($action eq "D") {
		$tk_dn_b->invoke();
	}

	die $@ if $@;
	$tk->repeat(60000,sub { &tk_checkline(10000) });
	&tk_checkline();
	MainLoop();
}

	
my %ignore;
sub tk_send_line_up {
	$sessup=0;
	$authfail=0;
	%ignore=();
	&send_line_up;
	my $count = 10;
	my $sub;
	&tk_auth(0) if $challenge_magic;
	$sub = sub {
		if ($sessup || $lineup) {
			print "Line up done\n" if $verbose;
		} else {
			if (--$count) {
				print "Line still not up\n" if $verbose;
				&send_line_up;
				$tk->after(1000, $sub);
			} else {
				print "Line never came up\n";
			}
		}
	};
	$tk->after(3000, $sub);
}


sub tk_send_line_down {
	$authwin->destroy() if(Exists($authwin));
	&send_line_down;
	my $count = 10;
	my $sub;
	$sub = sub {
		&tk_checkline();
		if (!$lineup) {
			print "Line down done\n" if $verbose;
		} else {
			if (--$count) {
				print "Line still not down\n" if $verbose;
				&send_line_down;
				$tk->after(1000, $sub);
			} else {
				print "Line never came down\n";
			}
		}
	};
	$tk->after(3000, $sub);
}

sub tk_handle_input {
	my $msg = &handle_input;
	if ($msg) {
		if ($msg->{type} == $msg_challenge) {
			$sessup=1;
			&tk_auth($msg->{id});
		} else {
			print "WARNING: Unknown message type..\n";
		}
	}
}

sub tk_checkline {
	my $was = $lineup;
	&checkline();
	$tk->bell() if ($was != $lineup);
	if ($lineup) {
		&tk_ledcolor("green");
		$tk->iconname("Up - $0");
		$tk->iconbitmap("gray50");
	} else {
		&tk_ledcolor("red");
		$tk->iconname("Down - $0");
		$tk->iconbitmap("error");
	}
}

sub tk_auth {
	my $id = shift;
	return if defined $ignore{$id};
	$authfail=1;
	if(!Exists($authwin)) {
		$authwin = $tk->Toplevel(-title => "Challenge");
		$authwin->positionfrom("user");
		my $f1 = $authwin->Frame()->pack(-expand=>1);
		my $f2 = $authwin->Frame()->pack(-expand=>1);
		my($p,$u,$w);
		$f1->Label(-text => "Profile",-justify=>'right')->grid(
			($p = $f1->Entry(-textvariable=>\$profile)),
			-sticky=>"nsew",
		);
		$f1->Label(-text => "User",-justify=>'right')->grid(
			($u = $f1->Entry(-textvariable=>\$user)),
			-sticky=>'nsew',
		);
		$f1->Label(-text => "Password",-justify=>'right')->grid(
			($w=$f1->Entry(-textvariable=>\$password,-show=>'#')),
			-sticky=>'nsew',
		);
		$w->focus;
		$p->bind("<Return>" => sub { $u->focus });
		$u->bind("<Return>" => sub { $w->focus });
		$w->bind("<Return>" => sub { 
			$authfail = 0;
			&tk_send_auth($id);
		});
		$authwin->bind("<Escape>" => sub {
			$ignore{$id}++;
			$authwin->destroy;
		});
		$f1->gridRowconfigure(0,-weight=>1);
		$f1->gridRowconfigure(1,-weight=>1);
		$f1->gridRowconfigure(2,-weight=>1);
		$f1->gridColumnconfigure(0,-weight=>1);
		$f1->gridColumnconfigure(1,-weight=>1);

		$f2->Button(
			-text=>"Authenticate",
			-underline=>0,
			-command => sub {
				&tk_send_auth($id);
				$authfail=0;
			}
		)->grid(
			$f2->Button(
				-text=>"Cancel",
				-underline=>0,
				-command => sub {
					$ignore{$id}++;
					$authwin->destroy;
				}
			),
			-sticky=>'nsew',
		);
		$f2->gridRowconfigure(0,-weight=>1);
		$f2->gridColumnconfigure(0,-weight=>1);
		$f2->gridColumnconfigure(1,-weight=>1);

	} else {
		$authwin->deiconify();
		$authwin->raise();
	}
}

sub tk_send_auth {
	my $id = shift;
	return if defined $ignore{$id};
	$authwin->destroy() if(Exists($authwin));
	&send_auth($id);
	my $count = 10;
	my $sub;
	$sub = sub {
		return if ($authfail);
		&tk_checkline();
		if ($lineup) {
			print "Authenticate done\n" if $verbose;
			$tk->after(30000, sub {
				%ignore = ();
				%msgcache = ();
				print "Clearing caches..\n" if $verbose;
			});
		} else {
			if (--$count) {
				print "Still no auth\n" if $verbose;
				&send_line_up;
				$tk->after(1000, $sub);
			} else {
				print "Auth never returned\n";
			}
		}
	};
	$tk->after(3000, $sub);
}