#!/usr/bin/env perl
# $Id: acctmux.pl,v 1.6 2013/09/02 18:14:32 ksb Exp $
# $Install: ${install:-install} %f ${TOP:-/usr/local}/libexec/%F
# Note we live with the jackets:
#	$Source: /usr/msrc/usr/local/libexec/jacket/RCS/acctmux.pl,v $
#
# Script to fetch keys from a client who ran "op acct authkeys", we are a (ksb)
# tcpmux service, usually called key-pickup, see the op rule "acct submit".
# the stamp for the login name up the customer.  Then we run trigger op
# "acct recover" rule to fetch a tar stream of the file(s).
use Getopt::Std;
use Socket;
use IO::Socket;
use IO::Handle ('autoflush');
use strict 'refs';
require 'sysexits.ph';

my($progname, %opts, $bin, $remote);
$progname = $0;
$progname =~ s/.*\///;
getopts("VhdMRx", \%opts);

# Hey, local site policy: the replace acct below with a client-side account, %%
# or replace with a double-precent to force a run-time error if not set locally.
my($remote_as) = 'acct';
if ($remote_as =~ /[%][%]/o) {
	print STDERR "$progname: remote login unconfigured\n";
	exit EX_CONFIG();
}
if ($opts{'V'}) {
	print "$progname: ", '$Id: acctmux.pl,v 1.6 2013/09/02 18:14:32 ksb Exp $', "\n";
	exit EX_OK();
}

if ($opts{'h'}) {
	print "$progname: [-dMx] [env=values]\n",
		"$progname: usage -h\n",
		"$progname: usage -V\n",
		"d          do not force peer to have a reverse IP mapping\n",
		"h          show this help message\n",
		"M          radiate less information in client replies\n",
		#"R reverse  mk rule file to reverse IP addresses",
		"V          show only version information\n",
		"x          send trace information to stderr\n",
		"env=value  add to the process environment\n";
	exit EX_OK();
}

# Hey, local site policy: force reverse map of all hosts see msrcmux.pl %%
if ($opts{'R'}) {
	print "-option -R not supported here\r\n";
	print STDERR "$progname: -R copy the code from msrcmux\n";
	exit EX_SOFTWARE();
}

'STDOUT'->autoflush(1);

foreach my $e (@ARGV) {
	next unless ($e =~ m/(\w+)=(.*)/o);
	$ENV{$1} = $2;
}

# OK, let's rock out!  With our dad... yeah.
my($mask) = "-no\r\n";	# -M default to mask informational failure messages
if (not exists $ENV{HOME} or not chdir $ENV{HOME}) {
	print $opts{'M'} ? $mask : "-missing acounting HOME\r\n";
	exit EX_CONFIG();
}
my($host) = 'localhost';
my($remoteIP) = '127.0.0.1';
my($peer_name) = undef;
if ($opts{'d'}) {
	# As documented -dx: debug with a terminal session --ksb
} elsif (defined($peer_name = getpeername STDIN)) {
	my($port, $inaddr) = sockaddr_in($peer_name);
	my(@hostent) = gethostbyaddr($inaddr, AF_INET());
	# ($name,$aliases,$addrtype,$length,@addrs)
	if (not defined($host = $hostent[0])) {
		$host = '@';
	}
	$remoteIP = inet_ntoa($inaddr);
} else {
	print $opts{'M'} ? $mask : "-getpeername hates you\r\n";
	exit EX_PROTOCOL();
}

# read the requests from client
sub Line(@)
{
	my($error) = shift;
	my($in, $c);
	$in = '';
	while (0 != read(STDIN, $c, 1)) {
		if ("\n" eq $c) {
			$in =~ s/\r$//o;
			print STDERR "$in\n" if $opts{'x'};
			return $in;
		}
		$in .= $c;
	}
	print "-end of input $error\r\n";
	exit EX_PROTOCOL();
}

# Read the stamp control socket name.
print $opts{'M'} ? "+Go\r\n" : "+stamp\r\n";
my($stamp_name) = Line("stamp path");
open(STDIN, '</dev/null');

if (not $stamp_name =~ m|^/|) {
	print $opts{'M'} ? $mask : "-service rejects non-absolute stamps\r\n";
	exit EX_NOPERM();
}
if ($stamp_name =~ m|^[.][.]/|o or $stamp_name =~ m|/[.][.]/|) {
	print $opts{'M'} ? $mask : "-service rejects dot-dot in stamp names\r\n";
	exit EX_NOPERM();
}
if (not $stamp_name =~ m/^([^\s]*)$/o) {
	print $opts{'M'} ? $mask : "-service rejects white-space in stamp names\r\n";
	exit EX_NOPERM();
}

delete $ENV{ENV};
umask 0077;		# Same as the inetd default, actually.
$ENV{SHELL} = '/bin/sh';
my($fh, $keep, $login);

# We could inject the request into a batch queue, xapply process, or
# the the atq.  Or we could just do it.  Yay for feedback to the Customer!
# We use stampctl here (we could use op) to check that the stamp is a
# socket we can read.  That makes it a little harder suborn us, actually.
# If opening a unix socket as a mortal is a hazard, you have bigger issues.
# Hey, local site policy: options to ssh -anT, hostkey check, DNS keys %%
unless ($login = `ssh -anT -o \"VerifyHostKeyDNS yes\" $remote_as\@$remoteIP /usr/local/sbin/stampctl -Q $stamp_name Who 2>/dev/null` and 0 == $?) {
	print $opts{'M'} ? $mask : "-ssh $remote_as\@$remoteIP stampctl exit code $?\r\n";
	exit EX_NOPERM();
}
# Hey, local site policy: login names alpha + up to 15 alpha-numerics %%
$login =~ s/\r?\n$//;
if (not $login =~ m/^(\w[\w\d]{0,15})$/o) {
	print $opts{'M'} ? $mask : "-invalid login name \"$login\"\r\n";
	exit EX_NOPERM();
}
$login = $1;

# Find a place to stash the tar file.
unless (open($keep, ">userkeys/$login.tar")) {
	print $opts{'M'} ? $mask : "-no space available for $login\r\n";
	exit EX_NOPERM();
}

# Open the command to capture the file.
my($a) = '&';
unless (open($fh, "exec </dev/null $a$a ssh -nT $remote_as\@$remoteIP . /usr/local/lib/distrib/local.defs \\$a\\$a op -u $login -f $stamp_name acct recover \\$a\\$a exec /usr/local/sbin/stampctl -k $stamp_name|")) {
	print $opts{'M'} ? $mask : "-ssh $remoteIP recover: $!\r\n";
	exit EX_NOPERM();
}

# Release the client and finish the download async.
print "+$login\r\n";
open(STDOUT, ">/dev/null");

# Hey, local site policy: a size check for a disk space consumption attack? %%
# In the loop below, read 512 byte records and count'm, as you like.
# If it gets `too large', then remove the file and exit failure.
# I've never needed this, when a Customer hoses me they loose a lot. --ksb
while (<$fh>) {
	print $keep;
}
close $fh;
close $keep;
exit EX_OK();