#!/usr/bin/perl

#######################################################################
# ttyd.pl
#
# This program is a perl implementation of a program we used to use
# at Computone called Iservd.  It maps pseudo ttys on a UNIX system
# to a remote serial ports on terminal servers that can support the
# simple system of TCP -> Serial. This program can not send 
# serial settings such as speed and parity to the remote.  There is no
# way in UNIX that I know of to do that via a pseudo without using
# a real character driver and implementing RFC2217 in the driver or
# some user space program the driver uses.  It might be possible
# to create a protocol that the application uses with this program 
# and then this program could implement RFC2217.  The problem with
# that is that this program should be used when you can not modify your
# serial application.  In my test I had a terminal server in Alpharetta
# attached to a serial console of a Linux server.  I then pointed this
# progarm to it and use Minicom on my laptop to log into the console
# of the Linux server.  Works great.
#
# Many things you may want to do are not possible with this method.
# Many people who use Iservd wanted a terminal server to act like 
# a real serial port on their UNIX box.  Since hardware settings can
# not be sent this does help their cause.  Also beware of DTR/DCD behavior.
# In some terminal server implementations if the remote serial device drops
# DTR and the TS  see's loss of carrier they will also drop the socket to
# signal to us that the remote has dropped carrier.  Our reaction should
# be to close the pseudo tty.  If your program works correctly and you
# are using -clocal then you should see a hangup on the pseudo.  This simulates
# loss of carrier in this implemenation.  You'll want to read the
# manual of your terminal server to see how it behaves.
# Likewise there should be a method where when your app closes the pseudo
# we detect it and close the socket to the TS.  The TS should see that and
# toggle DTR on the serial port.  I do not think I've programmed ttyd.pl to
# do this but you can test and make modifications as you see fit.
# In iservd these features were part of the config for each tty.
#
# YMMV!
# Questions?  cfowler@outpostsentinel.com
#######################################################################

use IO::Socket::INET;
use IO::Pty;
use IO::Select;
use XML::Simple;
use Getopt::Std;
use vars qw/$opt_c $opt_d $opt_k/;
use strict;

#######################################3
# Constants
#######################################3
# The following are states that are not
# currently used but could be used in the future
use constant DISCONNECTED        => 0;
use constant CONNECT_IN_PROGRESS => 1;
use constant CONNECTED           => 2;


#######################################3
# Globals
#######################################3
my %remotes = ();
my $select_timeout = 30;

$opt_c = "config.xml"; # Config File
$opt_d = 0; # run as a daemon
$opt_k = 0; # kill running ttyd process

# Function will read config data.
# File should be in XML format and look like this:
# <config>
#  <remote>
#   <address></address>
#   <port></port>
#   <device_name></device_name>
#   <log_file></log_file>
#  </remote>
# </config>
#
# Now I'm using XML::Simple and it does provide
# an easy way to parse XML data but you should now
# a bit of how it creates data.  In the function I
# assume that you will have at least two <remote> elements
# in the file.  If you do then XML::Simple places those
# elements in an array.  If not it places them in a hash.  Maybe
# there is a universal way to deal wiht either a hash or
# an array in this case but I simply wrote the code to
# work when XML::Simple provides me with an array of
# <remote> objects.
# If you want to support 1 or many you'll need to modify
# this function to be smarter.
sub config {
	my $data = "";
	my $ready = undef;

	# Yea I know that XML::Simple will handle
	# file.  There may be a case where we want to
	# do some pre-parsing of the data to verify before
	# even giving it to the XML parser.
	open D, "< $opt_c" or return undef;
	while(<D>) { $data .= "$_"; }
	close D;

	# Like here
	return undef unless $data =~ m/<remote>/;

	my $xml = XMLin($data);

	foreach my $ref (@{$xml->{'remote'}}) {
		# Check for required values
		# Hard to make a connection if we do not know the
		# address and port.  We need a device name to create the
		# symbolic link.
		next unless defined $ref->{'address'};
		next unless defined $ref->{'port'};
		next unless defined $ref->{'device_name'};
		$ready = 1; # We have at least one remote in our config
		$remotes{$ref->{'device_name'}}{'device_name'} = $ref->{'device_name'};
		$remotes{$ref->{'device_name'}}{'port'} = $ref->{'port'};
		$remotes{$ref->{'device_name'}}{'address'} = $ref->{'address'};
		if(defined $ref->{'log_file'}) {
			$remotes{$ref->{'device_name'}}{'log_file'} = $ref->{'log_file'};
			
		}
	}

	return $ready;
}

# Function will setup a socket and start the connect
# process.
# Caller should place the returned file handle and place
# in a select writers list.  If the write can happen then
# it means that something has changed in regards to the
# connecting process.  Maybe we were able to connect maybe
# not.  Caller needs to validate that we are connected
# before placing the file handle in the readers select
# list
sub setup {
	my ($addr, $port) = @_;
	my $sock = IO::Socket::INET->new(Proto => 'tcp', Blocking => 0);
	my $iaddr   = inet_aton($addr) or return undef;         
	my $paddr   = sockaddr_in($port, $iaddr);
	my $ret = connect($sock, $paddr);
	if (!$ret && ! $!{EINPROGRESS}) {
		close $sock;
		return undef;
	}

	return $sock;
}


sub main {
	my $readers = new IO::Select;
	my $writers = new IO::Select;

	$| = 1;

	# Process Command line arguments
	getopts("c:dk");
	
	# simple way to look for a program and kill it.
	if($opt_k) {
		open PID_FILE, "< /var/run/ttyd.pid" or die "No ttyd process running?\n";
		my $pid = <PID_FILE>;
		print "Killing ttyd process at $pid\n";
		kill 15,($pid);
		exit 0;
	}

	# Become a daemon and do "the right thing"(tm) 
	if($opt_d) {
		my $pid = fork();
		exit 0 if $pid; # Parent

		chdir "/tmp";

		# We are now in the child
		# Redirect these so there are no lingering
		# ttys.
		open STDOUT, "> /dev/null";
		open STDERR, "> /dev/null";
		open STDIN,  "</dev/null";

		# Create a pid file so we can kill it with ease
		# and have a status.  I think that the redhat startup
		# scripts look at this when you do a /etc/init.d/service stat
		open PID_FILE, "> /var/run/ttyd.pid";
		print PID_FILE "$$";
		close PID_FILE;
		$SIG{'TERM'} = sub {
			unlink "/var/run/ttyd.pid";
			exit 0;
		};
	}

	# Load up the config
	config() or die "Failed to parse config!\n";

	foreach my $ref (keys %remotes) {
		$ref = $remotes{$ref};
		my $sock = setup($ref->{'address'}, $ref->{'port'});
		if($sock) {
					$ref->{'socket'} = $sock;
					$writers->add($sock);
					$ref->{'state'} = CONNECT_IN_PROGRESS;
		}
	}

	while(1) {
			my $buffer = "";
			my $n_read = 0;
			my ($rr, $rw, $er) = IO::Select->select($readers, $writers, $readers, $select_timeout) ;

			# Check our readers
			foreach my $fh (@$rr) {
				foreach my $ref (keys %remotes) {
					$ref = $remotes{$ref};
					if(defined $ref->{'pty'} and $fh == $ref->{'pty'}) {
							if(($n_read = sysread($fh, $buffer, 1024)) > 0) {
								syswrite($ref->{'socket'}, $buffer, $n_read);
							} else {
								$readers->remove($ref->{'pty'});
								$readers->remove($ref->{'socket'});
								close $ref->{'pty'};
								close $ref->{'slave'};
								close $ref->{'socket'};
								delete $ref->{'pty'};
								delete $ref->{'slave'};
								delete $ref->{'socket'};
								$ref->{'state'} = DISCONNECTED;
							}
					}

					if(defined $ref->{'socket'} and $fh == $ref->{'socket'}) {
							if(($n_read = sysread($fh, $buffer, 1024)) > 0) {
								syswrite($ref->{'pty'}, $buffer, $n_read);
								if(defined $ref->{'log_file'}) {
									open F, ">> $ref->{'log_file'}";
									syswrite(F, $buffer, $n_read);
									close F;
								}
							} else {
								print "Lost Connection: $ref->{'address'}:$ref->{'port'}\n";
								$readers->remove($ref->{'pty'});
								$readers->remove($ref->{'socket'});
								close $ref->{'pty'};
								close $ref->{'slave'};
								close $ref->{'socket'};
								delete $ref->{'pty'};
								delete $ref->{'slave'};
								delete $ref->{'socket'};
								$ref->{'state'} = DISCONNECTED;
							}
					}
				}
			}


			# check our writers
			foreach my $fh (@$rw) {
				foreach my $ref (keys %remotes) {
					$ref = $remotes{$ref};
					if(defined $ref->{'socket'} and ($fh == $ref->{'socket'})) {
						my $peername = $ref->{'socket'}->peername();
						if($peername) {
							print "Connection to $ref->{'address'}:$ref->{'port'} ";
							$ref->{'socket'}->blocking(1);
							my $pty = new IO::Pty;
							my $slave = $pty->slave();
							$pty->autoflush();
							$slave->set_raw();
							$pty->set_raw();
							print "success -> /dev/$ref->{'device_name'} (".$pty->ttyname(),")\n";
							unlink "/dev/$ref->{'device_name'}";
							symlink $pty->ttyname(), "/dev/$ref->{'device_name'}";
							$ref->{'pty'} = $pty;
							$ref->{'slave'} = $slave;
							# Add it to the selector;
							$readers->add($pty);
							$readers->add($ref->{'socket'});

							# No need to block on write capability anymore
							$writers->remove($ref->{'socket'});
							$ref->{'state'} = CONNECTED;
						} else {
							$writers->remove($ref->{'socket'});
							close $ref->{'socket'};
							delete $ref->{'socket'};
							$ref->{'state'} = DISCONNECTED;
						}

					}
				}
			}

			# Now that we have reading out of the way
			# we need to go through the list of all sockets
			# that are not connected.  Allow setup() to do
			# the connect() on a non-blocking socket and
			# add it to the writers list.
			foreach my $ref (keys %remotes) {
				$ref = $remotes{$ref};
				next if defined $ref->{'socket'};

				# If out OS gives us a EHOSTUNREACH each time we 
				# try to connect to a host that is unreachable then it
				# is possible that we could consume many cycles.  We setup
				# the connect() here and then the minute we get back to select()
				# we can read and we have a EHOSTUNREACH.  We then come back
				# here an repeat the process.  This could keep this program
				# going and provide no sleep time.  This value could be
				# customized but what it does is look at the last time
				# we did a connect() for the remote and if it is >= 30s then
				# we try again.  Equivalent of init throttling runway getty processes.
				next if (time() - $ref->{'last_connect_attempt'} < 30);

				$ref->{'last_connect_attempt'} = time();
				my $sock = setup($ref->{'address'}, $ref->{'port'});
				# We have a connect() in progress.  Add it to the writers
				if($sock) {
					$ref->{'socket'} = $sock;
					$writers->add($sock);
					$ref->{'state'} = CONNECT_IN_PROGRESS;
				} else {
					# We might want to log why we were unable to get a socket
					# to a log file to fix in the future.
				}
			}
		}

	return 0;
}

exit main;

# vi: set ts=2 sw=2  #