#!/usr/bin/env perl
# $Id: roapmux.pl,v 1.4 2012/11/05 14:51:32 ksb Exp $
# The road (remote op authorization daemon) relies on this service.	(ksb)
# We accept a client which must send us the login:groups:[netgroups]
# for the proposed escalation.  We send back a list of possible
# authorization tokens.  E.g. MAY_START_TIGER, MAY_STOP_PUMA=test, etc.
# The stamp(7l) jacket treats these as a local authorization tableau, so
# it acts as the jacket for this service as well.  This looks a whole
# lot like msrcmux, because it is pretty much exactly parallel.

use Getopt::Std;
use Socket;
use Sys::Syslog qw(:standard :macros);
use IO::Socket;
use IO::Handle qw(autoflush);
use strict;
use File::Temp qw/ mkdtemp /;

my($progname, %opts, $defConfig, $Xconfig, $Zconfig, $bin, $hxmd_dir);
$progname = $0;
$progname =~ s/.*\///;
#Getopt::Long::Configure ('no_ignore_case');
#http://www.vromans.org/johan/articles/getopt.html
getopts("VhzdMxC:E:L:R:X:Z:", \%opts);
if (exists $opts{'C'} and $opts{'C'} =~ m/(.*)/o) {
	$defConfig = $1;
} else {
	$defConfig = 'auto.cf';		# local site policy, change me
}
my(@config_list) = ();
if (exists $opts{'X'} and $opts{'X'} =~ m/(.*)/o) {
	push @config_list, "-X$1";
}
if (exists $opts{'Z'} and $opts{'Z'} =~ m/(.*)/o) {
	push @config_list, "-Z$1";
}
if (exists $opts{'L'} and $opts{'L'} =~ m/(.*)/o) {
	$ENV{'HXMD_LIB'} = $1;
} else {
	$ENV{'HXMD_LIB'} = '.:/usr/local/lib/hxmd:/usr/local/lib/distrib:/usr/local/lib/roapmux';
}
if (exists $opts{'E'} and $opts{'E'} =~ m/(.*)/o) {
	$bin = $1;
} else {
	$bin = '/usr/local/sbin/hxmd';
}

my($prefix) = 1;
my(@child) = ();
foreach (@ARGV) {
	if ($prefix and $_ =~ m/([^=]+)=(.*)/o) {
		$ENV{$1} = $2;
		next;
	}
	if ($prefix) {
		$prefix = 0;
		next if ($_ =~ m/^--$/o);
	}
	next unless ($_ =~ m/(.*)/o);
	push(@child, $1);
}

if ($opts{'V'}) {
	print "$progname: ", '$Id: roapmux.pl,v 1.4 2012/11/05 14:51:32 ksb Exp $', "\n";
	print "$progname: process: ", join(' ', @child), "\n" if (0 != scalar(@child));
	exit 0;
}

if ($opts{'h'}) {
	print "$progname: [-xM] [-C configs] [-E hxmd] [-L hxmd-libs] [-R reverse] [-X ex-config] [-Z zero-config] [envs] [generator]\n",
		"$progname: usage -h\n",
		"$progname: usage -V [envs] [generator]\n",
		#"d             debug on a terminal, use with -x to debug\n",
		"C configs     specified config, else \"$defConfig\"\n",
		"E hxmd        the path to hxmd, else `$bin'\n",
		"h             show this help message\n",
		"L hxmd-lib    set an explicit \$HXMD_LIB\n",
		"M             radiate less information in client replies\n",
		"R reverse     mk rule file to reverse IP addresses\n",
		"V             show only version information\n",
		"x             send trace information to stderr\n",
		"X ex-config   as in hxmd, but only once\n",
		"Z zero-config as in hxmd, but only once\n",
		"envs          env=value pairs for the process environment\n",
		"generator     hxmd command-line specification\n";
	exit 0;
}

autoflush STDOUT 1;

my($mask) = "-no\r\n";	# -M mask for informational failure messages
my($host) = 'localhost';
my($remoteIP) = '127.0.0.1';
my($peer_name) = undef;
if ($opts{'d'}) {
	# Undocumented -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 (!defined($host = $hostent[0])) {
		$host = '@';
	}
	$remoteIP = inet_ntoa($inaddr);
} else {
	print $opts{'M'} ? $mask : "-getpeername hates you\r\n";
	exit 0;
}

# 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 0;
}

# Spiff up the environment for -T/-R, just in case.  If we set a path
# where the first component is not absolute we replace it.
if ($ENV{'PATH'} =~ m|^(/.*)(:?)$|o) {
	$ENV{'PATH'} = "$1:/usr/local/sbin:/usr/local/bin$2";
} else {
	$ENV{'PATH'} = "/usr/bin:/usr/local/sbin:/usr/local/bin:/bin";
}
$ENV{'PATH'} =~ s/::/:/go;
$ENV{'PATH'} =~ s/:*$//o;
$ENV{'PATH'} =~ s/^:*//o;
$ENV{'SHELL'} = '/bin/sh';
delete $ENV{'ENV'};
umask 0077;		# Same as the inetd default, actually.

# The -R file must map a hostname (marker) + IP (submarker) to the correct
# name in the given configuration file ($CONFIG).  If the reverse filename
# is '.' map it to the configuration file.  This is a minor issue if the
# client might have access to build a configuration file with an embedded
# marked line "# $hostname(IP): arbitrary-command"		--ksb
my($reverse) = $opts{'R'};
if (defined($reverse) and '.' ne $reverse) {
	my($mapped);
	$mapped = `mk -sl0 "-m$host" "-d$remoteIP" "$reverse"`;
	chomp($mapped);
	if (0 != $? || '' eq $mapped || $mapped =~ m/\s/o) {
		print $opts{'M'} ? $mask : "-map: $reverse: $host($remoteIP): no such host ($?)\r\n";
		exit 0;
	}
	$host = $mapped;
}

# Our Go string
print $opts{'M'} ? "+Go\r\n" : "+$host\r\n";

# A literal dot (.) or empty string unsets the credential
my($creds) = Line("creds");
# convert tab to space
$creds =~ s/\t/ /g;
if ($creds !~ m|^\s*(\w*):\s*([\w ,]*):\s*([\w ,]*):\s*([-\w.]*)\s*:\s*([-\s!#%+,./\w:=@^{}]*)$|o) {
	print $opts{'M'} ? $mask : "-creds usage login:groups:netgroups:domain:query\r\n";
	exit 0;
}
my($login,$groups,$netgroups,$domain,$query) = ($1, $2, $3, $4, $5);
my(@credlist) = ("-D!ROAP_HOST=$host", "-D!ROAP_IP=$remoteIP");
if ('.' ne $login and '' ne $login) {
	push(@credlist, "-D!ROAP_LOGIN=$login");
}
$groups =~ s/\s+/ /g;		# compact multiple spaces
$groups =~ s/\s+$//;
if ('.' ne $groups and '' ne $groups) {
	push(@credlist, "-D!ROAP_GROUPS=$groups");
}
$netgroups =~ s/\s+/ /g;	# compact multiple spaces
$netgroups =~ s/\s+$//;
if ('.' ne $netgroups and '' ne $netgroups) {
	push(@credlist, "-D!ROAP_NETGROUPS=$netgroups");
}
				# already trimmed of spaces
if ('.' ne $domain and '' ne $domain) {
	push(@credlist, "-D!ROAP_DOMAIN=$domain");
}
$query =~ s/\s+$//;		# trim training spaces for generator
push(@credlist, "-D!ROAP_QUERY=$query");
if ($opts{'M'}) {
	$mask =~ m/^[-]*([^\r\n]*).*$/o;
	push(@credlist, "-D!ROAP_MASK=$1");
}

# Ready to rock, show any errors from hxmd to the client
open(STDERR, ">&1");
my(@cmd) = ($bin, '-G', "$host", "-C$defConfig", @credlist,
	@config_list, "--", @child);

# When a command-line parameter has a [\r\n] in it we may choke the client
print $opts{'M'} ? "#generator" : '#'.join(' ', map { my($d) = "$_"; $d =~ y/\t\r\n/   /s; $d }  @cmd), "\r\n" if ($opts{'d'});
if (-1 == system @cmd) {
	print $opts{'M'} ? $mask : "-$cmd[0]: $!\r\n";
	openlog($progname, 'ndelay', 'auth');
	syslog('err', "failed exec %s: %s", $bin, $!);
	closelog();
	exit 0;
}
# Try to tell someone we did something good or bad
openlog($progname, 'ndelay', 'auth');
syslog(0 == $? ? 'info' : 'warn', "%s: %s: %s: %s: %s", $bin, 0 == $? ? 'issues' : 'fails', $host, $creds, $?);
closelog();
exit 0;