#!/usr/bin/perl
#
# Copyright (C) 1993-1996 Olivetti Research Limited, Cambridge, England.
#
# THERE IS NO WARRANTY FOR THIS SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE
# LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
# OTHER PARTIES PROVIDE THIS SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND,
# EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  NO
# GUARANTEE IS MADE THAT THIS SOFTWARE IS FREE OF SOFTWARE VIRUSES.  THE ENTIRE
# RISK AS TO THE QUALITY AND PERFORMANCE OF THIS SOFTWARE IS WITH YOU.  SHOULD
# THIS SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY
# SERVICING, REPAIR OR CORRECTION.
#
# IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL
# ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE
# THIS SOFTWARE AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
# GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE
# OR INABILITY TO USE THIS SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA
# OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES
# OR A FAILURE OF THIS SOFTWARE TO OPERATE WITH ANY OTHER SYSTEMS), EVEN IF
# SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
# DAMAGES.
#
#
# tpwatch - perl script to control the teleporting proxy server. Listens on a
#           TCP port for commands from the teleport script. Sends commands to
#           stdout and gets replies from stdin in a form suitable to be piped
#           to tpproxy. Tpwatch shouldn't be executed directly, but invoked
#           using the teleport command. This version also contains hooks where
#           the code to use Active Badge and/or Speech Recognition controlled
#           teleporting can be added.
#
# T J Richardson
#

###############################################################################
#
# THINGS YOU MAY WANT TO CONFIGURE:
#

#
# If "domainname" doesn't return the internet domain name, you could specify
# it here (otherwise IP addresses may be used instead of names).
#
# $DOMAIN_NAME = "...";
#

#
# Get constants needed for TCP sockets. If sys/socket.ph doesn't exist then
# we use some hard-coded values. Note that these hard-coded values are
# not valid for all architectures (e.g. Solaris 2.x).
#

eval 'require "sys/socket.ph"';
if ($@) {			# couldn't find sys/socket.ph
    $AF_INET = 2;
    $SOCK_STREAM = 1;
} else {
    $AF_INET = &AF_INET;
    $SOCK_STREAM = &SOCK_STREAM;
}

#
# Specify the directories to search for commands.  You can add directories here
# to make it work even for people with broken paths.
#

@commandSearchPath = (split(/:/,$ENV{PATH}),"/bin","/usr/bin","/usr/ucb",
		      "/usr/local/bin","/usr/local/X11R5/bin","/usr/bin/X11");

#
# Files associated with the user's session ($infoFile must correspond with
# value in teleport).
#

$infoFile = "$ENV{HOME}/.tpinfo";
$logFile = "$ENV{HOME}/.tpwatchlog";
$mtlFile = "$ENV{HOME}/.tpmtl";

#
# Timeouts (in seconds) waiting for the teleport command to respond and waiting
# for tpproxy to respond to commands.
#

$teleportTimeout = 30;
undef($tpproxyTimeout);		# infinite


###############################################################################

#
# Do some initialisation...
#

&InitialiseLogFile();
&InitialiseGlobalVariables();
&CatchSignals();


#
# Check for certain essential commands.  If a command isn't found then a
# warning is printed and the script may fail when it attempts to execute the
# command.
#

$hostnameBin = &FindCommand("hostname",@commandSearchPath);
if (!defined($DOMAIN_NAME)) {
    $domainnameBin = &FindCommand("domainname",@commandSearchPath);
}
$xauthBin = &FindCommand("xauth",@commandSearchPath);


&ParseCommandLine();
&GetProxyCookie();
$tcpPort = &ListenOnTcpPort(TELEPORT_CMD);
&WriteInfoFile($tcpPort);
if (defined &ACTIVE_BADGE) {
    &ABTeleportInitialise();
}

if (defined &SPEECH) {
    &SpTeleportInitialise();
}

#
# Main loop - wait for input from a teleport command or the proxy server.
#

while (1)
{
    undef $timeout;
    $fds = "";
    vec($fds,fileno(STDIN),1) = 1;
    vec($fds,fileno(TELEPORT_CMD),1) = 1;

    if (defined &ACTIVE_BADGE) {
	($fds,$timeout) = &ABTeleportAddFDs($fds,$timeout);
    }
    if (defined &SPEECH) {
	($fds,$timeout) = &SpTeleportAddFDs($fds,$timeout);
    }


    $i = select($fds,undef,undef,$timeout);
    &Die("$0: select failed: $!\n") if ($i < 0);

    if ($i == 0) {			# timeout
	if (defined &ACTIVE_BADGE) {
	    &ABTeleportProcessTimeout();
	}
	if (defined &SPEECH) {
	    &SpTeleportProcessTimeout();
	}
	next;
    }

    if (vec($fds,fileno(STDIN),1)) {
	&ProcessMessageFromProxy();
    }

    if (vec($fds,fileno(TELEPORT_CMD),1)) {
	&ProcessTeleportCommand();
    }

    if (defined &ACTIVE_BADGE) {
	&ABTeleportProcessFDs($fds);
    }

    if (defined &SPEECH) {
	&SpTeleportProcessFDs($fds);
    }
}


#
# Initialise global variables.
#

sub InitialiseGlobalVariables
{
    $| = 1;
    $waitFh = "";
    $proxyDisplay = "";
    $currentDisplay = "";
    $proxyCookie = "";
}


#
# ProcessMessageFromProxy - there is only one message we expect from the proxy
# server (except for replies), and that is a message to say that it detected a
# server crash and managed to dematerialise.
#

sub ProcessMessageFromProxy
{
    $_ = <STDIN>;

    if (length($_) == 0) {
	&TerminateNicely();
    }

    chop;
    if ($_ eq "dematerialised") {
	&Warn("Proxy server detected server crash\n");
	&Materialise("");
    } else {
	&Warn("Unexpected message from proxy server: '$_'\n");
    }
}


#
# ProcessTeleportCommand reads a command from a teleport command over the
# TCP socket.
#

sub ProcessTeleportCommand
{
    local ($fh,$sockaddr,$command,$reply,$cookie,$display);

    $fh = &NewFileHandle();
    $sockaddr = accept($fh,TELEPORT_CMD);
    &Die("$0: accept failed: $!\n") unless ($sockaddr);

    select($fh); $| = 1; select(STDOUT);

    if (!&WaitForInput($fh,$teleportTimeout)) {
	&Warn("Timed out waiting for teleport command\n");
	close($fh);
	return;
    }

    $cookie = <$fh>;
    $cookie =~ tr/\r\n//d;

    if ($cookie ne $proxyCookie) {
	print $fh "rejected\n";
	close($fh);
	return;
    }
    print $fh "accepted\n";

    if (!&WaitForInput($fh,$teleportTimeout)) {
	&Warn("Timed out waiting for teleport command\n");
	close($fh);
	return;
    }

    $command = <$fh>;
    $command =~ tr/\r\n//d;
    if ($command =~ /^display (\S+)( wait)?$/) {
	$display = &FullyQualifyDisplayName($1);
	$reply = &Materialise($display);
	print $fh "$reply\n";
	if (($reply eq "ok") && $2) {
	    $waitFh = $fh;
	    return;
	}
    } elsif ($command eq "nodisplay") {
	$reply = &Materialise("");
	print $fh "$reply\n";
    } elsif ($command eq "rematerialise") {
	$reply = &Materialise($currentDisplay);
	print $fh "$reply\n";
    } elsif ($command eq "currentdisplay") {
	print $fh "$currentDisplay\n";
    } elsif ($command eq "reset") {
	if (defined &ACTIVE_BADGE) {
	    &ABTeleportReset();
	}
	if (defined &SPEECH) {
	    &SpTeleportReset();
	}
	close(TELEPORT_CMD);
	close($fh);
	exec $0, $proxyDisplay, $currentDisplay;
    } elsif ($command eq "kill") {
	&Materialise("");
	&TerminateNicely("kill command");
    } elsif ($command ne "") {
	$reply = &ProxyCommand($command);
	&Warn("Proxy command '$command' reply '$reply'\n");
	print $fh "$reply\n";
    }

    close($fh);
}


#
# Materialise sends a command to the proxy server to tell it to materialise
# on the given display, or dematerialise if given an empty string.
#

sub Materialise
{
    local ($display) = @_;
    local ($reply, $rreply, $pid);

    if ($display && &SameDisplay($display, $currentDisplay)) {
	&Warn("Teleporting away and back to $display\n");
	$reply = &ProxyCommand("nodisplay");
	if ($reply ne "ok") {
	    &Warn("Teleporting away failed - reply '$reply'\n");
	}
    } else {
	if ($currentDisplay) {
	    $reply = &ProxyCommand("remap $currentDisplay");
	    if ($reply ne "ok") {
		&Warn("remapping windows failed on $currentDisplay - reply '$reply'\n");
	    }
	}

	if ($display) {
	    &Warn("Trying to teleport to display $display\n");
	    $reply = &ProxyCommand("unmap $display");
	    if ($reply ne "ok") {
		&Warn("unmapping windows failed on $display - reply '$reply'\n");
		&Warn("teleporting aborted\n");
		return $reply;
	    }
	} else {
	    &Warn("Trying to teleport to nowhere\n");
	}
    }

    if ($display) {
	$reply = &ProxyCommand("display $display pseudoroot");
    } else {
	$reply = &ProxyCommand("nodisplay");
    }

    if ($waitFh) {
	close($waitFh);
	$waitFh = "";
    }

    if ($reply ne "ok") {
	&Warn("Teleporting failed - reply '$reply'\n");
	if ($display) {
	    $rreply = &ProxyCommand("remap $display");
	    if ($rreply ne "ok") {
		&Warn("remapping windows failed on $display - reply '$rreply'\n");
	    }
	}
	$currentDisplay = $display = "";
	return $reply;
    }

    &Warn("Teleporting succeeded\n");

    if ($display) {
	if (defined &ACTIVE_BADGE) {
	    &ABTeleportRememberDisplay($display);
	}

	if (-x $mtlFile) {
	    $ENV{PHYSICALDISPLAY} = $display;
	    system("$mtlFile >>$logFile 2>&1 </dev/null");
	}
    }

    $currentDisplay = $display;
    return "ok";
}


#
# ProxyCommand sends the given command to tpproxy.
#

sub ProxyCommand
{
    local ($command) = @_;
    local ($reply);

    print("$command\n") || &TerminateNicely();

    if (!&WaitForInput(STDIN,$tpproxyTimeout)) {
	&Warn("Timed out waiting for tpproxy to reply\n");
	return "timeout error";
    }

    chop($reply = <STDIN>);
    $reply;
}


#
# Catch termination signals so we can clean up properly.
#

sub CatchSignals
{
    $SIG{'TERM'} = 'TerminateNicely';
    $SIG{'INT'} = 'TerminateNicely';
    $SIG{'QUIT'} = 'TerminateNicely';
    $SIG{'PIPE'} = 'IGNORE';
}


#
# TerminateNicely closes down gracefully.
#

sub TerminateNicely
{
    local ($sig) = @_;

    if ($sig eq "kill command") {
	&Warn("tpwatch terminating - received kill command\n");
    } elsif ($sig) {
	&Warn("tpwatch terminating (signal $sig)\n");
    } else {
	&Warn("tpwatch terminating - proxy server has died\n");
    }

    if ($waitFh) {
	close($waitFh);
    }

    if ($currentDisplay) {
	print("remap $currentDisplay\n");
    }
    exit;
}


#
# ListenOnTcpPort sets up a listening socket on any TCP port and returns the
# port number.
#

sub ListenOnTcpPort
{
    local ($fh) = @_;
    local ($sockaddr,$proto,$port,$z);

    ($z, $z, $proto) = getprotobyname("tcp");
    &Die("$0: getprotobyname failed\n") unless ($proto);

    socket($fh, $AF_INET, $SOCK_STREAM, $proto)
	|| &Die("$0: socket failed: $!\n");

    $sockaddr = pack('S x14', $AF_INET);

    bind($fh, $sockaddr) || &Die("$0: bind failed: $!\n");

    $sockaddr = getsockname($fh);
    $port = unpack('x2 n x12', $sockaddr);

    listen($fh, 5) || &Die("$0: listen failed: $!\n");

    &Warn("Listening for teleport command connections on port $port\n");

    $port;
}


#
# Usage prints out a usage message.
#

sub Usage
{
    &Die("usage: tpwatch [proxy-display [current-display]]\n");
}


#
# ParseCommandLine reads the command line arguments.
#

sub ParseCommandLine
{
    &Usage() if ((@ARGV < 1) || ($ARGV[0] =~ /^-/) || (@ARGV > 2));

    $proxyDisplay = &FullyQualifyDisplayName(shift(@ARGV));
    $currentDisplay = &FullyQualifyDisplayName(shift(@ARGV)) if (@ARGV);
}


#
# InitialiseLogFile simply removes the old log file.
#

sub InitialiseLogFile
{
    unlink($logFile);
}


#
# Warn prints a message to the log file.
#

sub Warn
{
    local ($message) = @_;
    local ($hr,$min,$sec,$day,$mth,$yr,$time);

    ($sec,$min,$hr,$day,$mth,$yr) = localtime;

    $time = sprintf("%02d/%02d/%02d %02d:%02d:%02d",
		    $day,$mth+1,$yr,$hr,$min,$sec);

    open(LOG,">>$logFile") || die "$0: cannot open $logFile for writing\n";
    print LOG "$time $message";
    close(LOG);
}


#
# Die prints a message to the log file then exits.
#

sub Die
{
    local ($message) = @_;
    &Warn($message);
    exit 1;
}


#
# FullyQualifyDisplayName returns a fully qualified version of the given
# display name.
#

sub FullyQualifyDisplayName
{
    local ($display) = @_;
    local ($host,$z,$serverNo,$screenNo);

    return "" if (!$display);

    ($host,$z,$serverNo,$z,$screenNo)
	= ($display =~ /^([^:]+)?(:(\d+)(\.(\d+))?)?/);
    $host = &FullHostName($host);
    $serverNo = 0 unless $serverNo;
    $screenNo = 0 unless $screenNo;

    "$host:$serverNo.$screenNo";
}


#
# FullHostName takes a host name and returns a fully-qualified version of that
# host. It does this by trying to add the domain name, if possible, or as a
# last resort it will simply return the IP address.
#

sub FullHostName
{
    local ($host) = @_;
    local (@hostEntry,@fqHostEntry);

    return $host if ($host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/);

    unless ($host) {
	unless (defined($_THIS_HOST)) {
	    chop($_THIS_HOST = `$hostnameBin`);
	}
	$host = $_THIS_HOST;
    }

    @hostEntry = gethostbyname($host);
    &Die("No such host '$host'\n") unless (@hostEntry);

    return $host if ($host =~ /\./);	# already fully-qualified

    if (!defined($DOMAIN_NAME)) {
	chop($DOMAIN_NAME = `$domainnameBin`);
    }

    if (defined($DOMAIN_NAME)) {
	@fqHostEntry = gethostbyname("$host.$DOMAIN_NAME");
	return "$host.$DOMAIN_NAME" if (@fqHostEntry);
    }

    return &HostToIPAddr($host,@hostEntry);
}


#
# HostToIPAddr turns a host name into an IP address in dotted decimal notation.
#

sub HostToIPAddr
{
    local ($host,@hostEntry) = @_;
    local ($ip1,$ip2,$ip3,$ip4);

    return $host if ($host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/);

    unless (@hostEntry) {
	@hostEntry = gethostbyname($host);
	&Die("No such host '$host'\n") unless (@hostEntry);
    }

    ($ip1,$ip2,$ip3,$ip4) = unpack('C4', $hostEntry[4]);

    return "$ip1.$ip2.$ip3.$ip4";
}


#
# SameDisplay compares if two display names are the same.
#

sub SameDisplay
{
    local ($display1,$display2) = @_;
    local ($host1,$serverNo1,$screenNo1,@hostEntry1,
	   $host2,$serverNo2,$screenNo2,@hostEntry2,$z);

    if (($display1 eq "") || ($display2 eq "")) {
	return 1 if (($display1 eq "") && ($display2 eq ""));
	return 0;
    }

    ($host1,$z,$serverNo1,$z,$screenNo1)
	= ($display1 =~ /^([^:]+)?(:(\d+)(\.(\d+))?)?/);
    $host1 = &FullHostName($host1);

    ($host2,$z,$serverNo2,$z,$screenNo2)
	= ($display2 =~ /^([^:]+)?(:(\d+)(\.(\d+))?)?/);
    $host2 = &FullHostName($host2);

    return 0 if ($screenNo1 != $screenNo2);
    return 0 if ($serverNo1 != $serverNo2);
    return (&HostToIPAddr($host1) eq &HostToIPAddr($host2));
}


#
# FindCommand searches for the given command in the given directories,
# returning the first match found.
#

sub FindCommand
{
    local ($cmd,@dirs) = @_;

    for (@dirs) {
	if (-x "$_/$cmd") {
	    return "$_/$cmd";
	}
    }
    &Warn("$0: couldn't find \"$cmd\".\n");
    return $cmd;
}


#
# NewFileHandle returns a new string which can be used as a file handle.
#

sub NewFileHandle
{
    "FH".++$_fileHandleIndex;
}


#
# WaitForInput waits for input on a given filehandle for a given amount of
# time (in seconds). Returns 1 if input is ready, 0 if a timeout occurred.
#

sub WaitForInput
{
    local ($fh,$timeout) = @_;
    local ($fds,$i);

    $fds = "";
    vec($fds,fileno($fh),1) = 1;
    $i = select($fds,undef,undef,$timeout);
    &Die("$0: select failed: $!\n") if ($i < 0);
    return $i;
}


#
# Get the magic cookie for the proxy server - we'll use it as our authorisation
# mechanism on connections from the teleport command.
#

sub GetProxyCookie
{
    open(COOKIE,"$xauthBin list $proxyDisplay|")
	|| &Die("Cannot execute $xauthBin\n");
    chop($_ = <COOKIE>);
    close(COOKIE);

    ($proxyCookie) = /(\S+)$/;
    &Die("Cannot get cookie for display '$proxyDisplay'\n")
	unless ($proxyCookie);
}


#
# Write details of proxy display name and our TCP port for teleport command
# connections out to .tpinfo.
#

sub WriteInfoFile
{
    local ($tcpPort) = @_;

    open(INFOFILE,">$infoFile")
	|| &Die("$0: cannot open $infoFile for writing\n");
    print INFOFILE "$proxyDisplay ".&FullHostName()." $tcpPort\n";
    close(INFOFILE);
}
