/Webface2.5/perl-lib/Webface/uniwrap.pm

package Webface::uniwrap;
use strict;
use IPC::PerlSSH;
use POSIX;
use Error qw(:try);
use Sys::Hostname;
use Webface::error;

use vars qw/$config/;
BEGIN { 
	use JSON::Parse 'json_file_to_perl';
	our $config = json_file_to_perl('/configs/webface_config.json');
}

my @sshopt = ('-o', 'PasswordAuthentication no', '-o', 'KbdInteractiveDevices no');

# resources ================================================================
my $resources = $config->{'server_resources'};

sub new
{
	my $class = shift;
	my $self  = {};
	bless($self, $class);
	my %opt = @_;
	$self->{retries}   = $opt{retries}   || 2;
	$self->{sleeptime} = $opt{sleeptime} || 2;
	$self->{user}      = $opt{user}      || $ENV{USER};
	$self->{server} = $opt{server} if exists $opt{server};
	$self->{arch}   = $opt{arch}   if exists $opt{arch};
	$self->{tmpdir} = $opt{tmpdir} || $ENV{TMPDIR} || '/tmp';
	$self->{host} = hostname();
	throw WebfaceSystemError(-text => "Specify server or arch") unless (exists $opt{server} or exists $opt{arch});
	throw WebfaceSystemError(-text => "Specify server OR arch")
	  if (defined $self->{server} and defined $self->{arch});

	if (defined $self->{server}) {
		throw WebfaceSystemError(-text => "Resource $self->{server} unavailable")
		  unless ($self->testserver($self->{server}) == 1);
	} else {
		$self->{server} = $self->findserver() unless defined $self->{server};
	}
	return $self;
}

sub execute
{
	my $self = shift;
	my @args = @_;

	throw WebfaceSystemError(-text => "No arguments to uniwrap") unless (@args);

	# connect it ===============================================================
	my $st = -1;
	if ($self->{server} eq $self->{host}) {
		$st = system(@args);
	} else {
		try {
			$st = $self->client(@args);

			#warn("$self->{server}: process(@args) returned '$st'\n");
		  }
		  otherwise {
			my $e = shift;
			warn("Exception in execution on $self->{server}: $e\n");
			$st = -1;
		  };
	}
	exit($st);
}

# run it =======================================================================
sub client
{
	my $self = shift;
	my @args = @_;
	my $st;
	
	# warn("run '" . join(' ', @args) . "' as $self->{user}\@$self->{server}\n");
	$self->open(Host => $self->{server}, User => $self->{user});
	$self->{ips}->use_library("IO", qw( open pclose getline ));
	
	# IPC::PerlSSH 'store' breaks for old perl, so we circumvent it below.
	#  but lets ensure it works. To be expanded with compatible versions.
	throw WebfaceSystemError(-text => "IPC::PerlSSH incompatible version") unless ($IPC::PerlSSH::VERSION eq '0.16');
	
	# IPC::PerlSSH open pipe breaks for old perl, this is more portable.
	#  (and actually more elegant!)
	$self->{ips}->eval('
	$stored_procedures{"popen"}= sub {
		use IO::Pipe;
		my $fh=new IO::Pipe();
		$fh->reader(@_);
		$fh->autoflush;
		$IPC::PerlSSH::Library::IO::handles{$fh->fileno}=$fh;
		return $fh->fileno;
	}
	');
	$self->{ips}->{stored}{popen} = 1;
	$st = $self->{ips}->eval("chdir('$self->{tmpdir}')")
	  or throw WebfaceSystemError(-text => "Could not chdir('$self->{tmpdir}') on $self->{server}");

	my $fd = $self->{ips}->call('popen', @args);
	throw WebfaceSystemError(-text => "Could not popen(@args) on $self->{server}")
	  if (not defined $fd);
	throw WebfaceSystemError(-text => "Could not popen(@args) on $self->{server}")
	  if ($fd < 0);

	while (1) {
		my $line;
		throw WebfaceSystemError(-text => "Lost connection") unless (defined $self->{ips});
		try {
			$line = $self->{ips}->call("getline", $fd);
		}
		catch WebfaceSystemError with {
			my $e = shift;
			throw WebfaceSystemError(-text => "Interrupted");
		}
		otherwise {
			# Unfortunately readline does not return empty as
			#  stated in the manual, but throws an exception at EOF
		};
		last unless (defined $line);
		last if ($line eq "");
		print STDOUT "$line";
	}
	
	throw WebfaceSystemError(-text => "Lost connection to $self->{server}") unless exists $self->{ips};
	
	# warn("$self->{server}: closing\n");
	$st = $self->{ips}->call('pclose', $fd);
	$st = WEXITSTATUS($st);
	$self->close();
	
	return $st;
}

# utility =========================================================================
sub testserver
{
	my $self = shift;
	my $serv = shift;
	my $st;

	if ($serv eq $self->{host}) {
		warn("test $serv (local)");
		$st = chdir($self->{tmpdir});
	} else {
		try {
			warn("test $self->{user}\@$serv (remote) : chdir('$self->{tmpdir}')\n");
			my $ips = IPC::PerlSSH->new(Host => $serv, User => $self->{user});
			throw WebfaceSystemError(-text => "Unable to connect") unless $ips;
			$st = $ips->eval("chdir('$self->{tmpdir}')");
			throw WebfaceSystemError(-text => "Could not chdir('$self->{tmpdir}') on $serv") unless ($st);
		  }
		  otherwise {

			# silently mark error
			my $e = shift;
			warn("Exception in test of $serv: $e");
			$st = -1;
		  };
	}
	warn("testserver($serv) returned '$st'\n");
	return $st;
}

sub findserver
{
	my $self = shift;

	throw WebfaceSystemError(-text => "Unknown source host: $self->{host}") unless exists $resources->{ $self->{host} };
	throw WebfaceSystemError(-text => "Source host $self->{host} has no way to execute architecture $self->{arch}")
	  unless exists $resources->{ $self->{host} }->{ $self->{arch} };
	my @serv    = @{ $resources->{ $self->{host} }->{ $self->{arch} } };
	my $retries = $self->{retries};
	while ($retries) {

		# choose server
		foreach my $serv (@serv) {
			if ($self->testserver($serv) == 1) {
				return $serv;
			}
		}
		warn("zzz $self->{sleeptime} / $retries");
		sleep($self->{sleeptime});
		$retries--;
	}

	throw WebfaceSystemError(-text => "Unable to locate online resource (" . join(',', @serv) . ")");
	return undef;
}

sub open
{
	my $self = shift;
	$self->{ips} = IPC::PerlSSH->new(@_, SshOptions => \@sshopt)
	  or throw WebfaceSystemError(-text => "Cannot connect to $self->{server}");
	$self->{pgrp}    = $self->{ips}->eval('getpgrp()');
	$self->{version} = $self->{ips}->eval('"$] $^X"');
	warn("remote perl version: $self->{version}");
}

sub close
{
	my $self = shift;
	delete $self->{ips};
	delete $self->{pgrp};
}

sub interrupt
{
	my $self = shift;
	$self->kill();
	$self->close();
}

sub kill
{
	my $self = shift;
	try {
		if (defined $self->{ips} && defined $self->{pgrp}) {
			warn("Closing remote process $self->{pgrp}\@$self->{server}\n");
			my $ips = IPC::PerlSSH->new(Host => $self->{server}, User => $self->{user}, SshOptions => \@sshopt);
			throw WebfaceSystemError(-text => "Unable to connect") unless $ips;
			$ips->eval("kill(-2,$self->{pgrp})");
		} else {
			warn("No remote proc to kill at $self->{server}\n");
		}
	  }
	  otherwise {
		my $e = shift;
		warn("Exception killing remote proc $self->{pgrp}\@$self->{server}: $e");
	  };
}

# static method
sub args
{
	my %opts;
	my @args;
	my $prog;
	while (@_) {
		my $opt = shift @_;
		if ($opt eq '-wraparch') {
			$opts{arch} = shift @_;
		} elsif ($opt eq '-wrapprog') {
			$prog = shift @_;
		} elsif ($opt eq '-wrapserv') {
			$opts{server} = shift @_;
		} elsif ($opt eq '-wrapuser') {
			$opts{user} = shift @_;
		} else {
			push @args, $opt;
		}
	}

	throw WebfaceConfigError(-text => "-wrapprog needed") unless (defined $prog);
	unshift @args, $prog;

	throw WebfaceConfigError(-text => "-wraparch or -wrapserv needed")
	  unless (exists $opts{arch} or exists $opts{server});
	throw WebfaceConfigError(-text => "-wraparch OR -wrapserv") if (exists $opts{arch} and exists $opts{server});

	$opts{args} = \@args;
	return %opts;
}