#!/usr/bin/env perl
# $Id: wrope.pl,v 1.6 2012/10/19 19:58:21 ksb Exp $
# $Source: /usr/msrc/usr/local/libexec/jacket/RCS/wrope.pl,v $
#
# wrope - wrap (an) op environment to allow a diffrent uid access to all the
# wrapped services passed through the escalated environment.  This is really
# good for gtfw and sshw.
# We build the path down to the socket, start a wrapw on the socket as
# the originial login, it tells us it is up, and we chown the socket
# to the target login.  It finsihes and we rm the socket in cleanup.

use strict;
use Socket;
use Getopt::Std;
use File::Temp qw/ mkdtemp mktemp /;
use POSIX qw(:sys_wait_h setsid);
require 'sysexits.ph';
# Auto-flush standard out, we need the child to see it ASAP
select STDERR; $| = 1;
select STDOUT; $| = 1;

my($progname, $usage, %opts);
($progname = $0) =~ s,.*/,,;

# Untaint our environment
$ENV{'PATH'} = "/bin:/usr/bin:/usr/local/bin:/usr/local/sbin:/usr/sbin";
$ENV{SHELL} = '/bin/sh' if exists $ENV{SHELL};
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};

# Document the parameters you expect in the rule-provided environment
my($WTempl) = 'WROPE_TO';
my($Reveal) = 'WROPE_REVEAL';
# ZZZ WROPE_OPTS  -E
my($DefTemplate) = '/tmp/wropeXXXXXX/wp0';


$usage = "$progname: usage -P pid [helmet-opts] -- mnemonic program euid:egid cred_type:cred";
getopts("VhHP:u:g:f:j:m:R:C:", \%opts);

if ($opts{'V'}) {
	print "$progname: ", '$Id: wrope.pl,v 1.6 2012/10/19 19:58:21 ksb Exp $', "\n";
	exit 0;
}

if ($opts{'h'}) {
        print   "$usage\n",
                "$progname: usage -h\n",
                "$progname: usage -V\n",
		"P pid       process that we jacket\n",
                "h           print only this help message\n",
                "V           show only version info\n",
                "helmet-opts arguments to any op helmet program\n",
		"mnemonic    the requested op mnemonic\n",
		"program     client application\n",
		"euid:egid   target login and group uids\n",
		"cred_type   the credential type that granted access (groups, users, or netgroups)\n",
		"cred        the matching group, login, or netgroup\n";
	exit 0;
}
if ($opts{'H'}) {
	print	"$progname: extend a wrapped environment escalated process\n",
		"$WTempl\tnew proxy socket mktemp template (default $DefTemplate)\n",
		"$Reveal\tstandard reveal logic\n";
	exit 0;
}
if (! $opts{'P'}) {
	print STDERR "$progname: may only used as a jacket\n";
	exit 64;
}

# Keep track the the directories we built so we can untmp them, we put them
# in the correct order (deepest first) to make the cleanup below work.
my(@cleanup) = ();
sub UnTmpDirs {
	#print STDERR "untmp: ", join(', ', @cleanup), "\n";
	foreach (@cleanup) {
		rmdir $_;
	}
}


# Untaint our params, common code to most jackets. --ksb
shift @ARGV if (scalar(@ARGV) && $ARGV[0] =~ m/^--$/o);
if (scalar(@ARGV) != 4) {
	print STDERR "$progname: exactly 4 positional parameters required\n";
	print "64\n" if $opts{'P'};
	exit 64;
}
if ($ARGV[0] !~ m|^([-/\@\w.]+)$|o) {
	print STDERR "$progname: mnemonic is zero width, or spelled badly\n";
	print "64\n" if $opts{'P'};
	exit 64;
}
my($MNEMONIC) = $1;
if ($ARGV[1] !~ m|^([-/\@\w.]+)$|o) {
	print STDERR "$progname: program specification looks bogus\n";
	print "64\n" if $opts{'P'};
	exit 64;
}
my($PROGRAM) = $1;
if ($ARGV[2] !~ m/^(\d+):(\d+)$/o) {
	print STDERR "$progname: euid:egid format error (wants digits:digits)\n";
	print "65\n" if $opts{'P'};
	exit 65;
}
my($EUID, $EGID) = ($1, $2);
if ($ARGV[3] !~ m/^([^:]*):([^:]*)$/o) {
	print STDERR "$progname: cred_type:cred $ARGV[3] missing colon\n";
	print "76\n" if $opts{'P'};
	exit 76;
}

# Modify the escalated process with "~prefix", "-ENV", "$ENV=value", or
# "$ENV=value" here, remove the reveal code if you must.
if (exists $ENV{$Reveal} and $ENV{$Reveal} =~ m/(.*)/o) {
	print "-$Reveal\n~$1\n";
}

my($kid, $status);
$kid = undef;
$status = 0;

my(@wrapenv) = grep(m/^\w+_d$/ || m/^\w+_link$/o || m/^\w+_\d+=/o, keys(%ENV));
# There is no environment to wrap, so don't build one.  How would it
# be useful to build a bridge to nowhere? --ksb
if (0 == scalar(@wrapenv)) {
	open StdinWrite, ">/dev/nul";
	goto empty;
}

for $_ (@wrapenv) {
	print "-$_\n";
}

my($her_agent) = $DefTemplate;
if (exists $ENV{$WTempl} && $ENV{$WTempl} =~ m!(/.+)!o) {
	$her_agent = $1;
	print "-$WTempl\n";
}
$her_agent =~ s!//+!/!g;	# compress out redundant slashes
my($tail, $r);
my(@comps) = split(m!/!, $her_agent);
while ('' eq ($tail = pop(@comps))) {
	;
}

# We will not build the top level directory with mkdtemp, nor will we
# build the chroot either.  Sanity really works.
if (scalar(@comps) < 1) {
	die "$progname: will not build a socket in /\n";
}
if (exists $opts{'R'} && $opts{'R'} =~ m!^(/.+?)/*$!o) {
	$opts{'R'} = $1;
	$her_agent = "$1/".shift @comps;
} else {
	delete $opts{'R'};
	$her_agent = shift @comps;
}
foreach $_ (@comps) {
	$her_agent .= "/$_";
	if ($her_agent !~ m/XX+$/o) {
		if (-d $her_agent) {
			next;
		}
		if (! mkdir($her_agent, 0700)) {
			my($keep) = $!;
			UnTmpDirs();
			die "$progname: mkdir: $her_agent: $keep\n";
		}
		chown $EUID, $EGID, $her_agent;
		unshift(@cleanup, $her_agent);
		next;
	}
	if (!($r = mkdtemp($her_agent))) {
		my($keep) = $!;
		UnTmpDirs();
		die "$progname: mkdtemp: $her_agent: $keep\n";
	}
	$her_agent = $r;
	chown $EUID, $EGID, $her_agent;
	unshift(@cleanup, $her_agent);
}
my($her_dir) = $her_agent;
chown $<, -1, $her_dir;		# client needs to make the socket
$her_agent .= "/$tail";
if ($her_agent =~ m!(.*)/([^/]*[X]+)$!o) {
	$r = mktemp($her_agent) or die "$progname: mktemp: $her_agent: $!\n";
	$her_agent = $r;
}

# We have the path to build, make a wrapw for them.  Run as their
# original login
if (! socketpair(StdinRead, StdinWrite, AF_UNIX, SOCK_STREAM, PF_UNSPEC)) {
	die "$progname: socketpair: $!\n";
}
if (! socketpair(StdoutRead, StdoutWrite, AF_UNIX, SOCK_STREAM, PF_UNSPEC)) {
	die "$progname: socketpair: $!\n";
}
my($wrapper) = undef;
if (0 == ($wrapper = fork())) {
	chdir('/');
	close StdoutRead;
	close StdinWrite;
	open STDIN , "<&StdinRead";
	open STDOUT , ">&StdoutWrite";
	close StdoutWrite;
	close StdinRead;
	($<, $>) = ($<, $<);
	setsid();	# try to aviod job control interactions.
	exec 'wrapw', '-mE', '-N', $her_agent, '--',
		'/bin/sh', '-c', "wrapw -Wt $her_agent -R -;exec 1>&-;read x";
}
close StdoutWrite;
close StdinRead;
delete $ENV{@wrapenv};

# fetch "size\nsocket\nsize\nvar1=value\000var2=other\000...=last\000 from
# wrapw. I'm sure I could do better in perl, but I'm not sure how.
my($check, $l, $socksize, $envsize);
my($newenv) = '';
while (0 != ($l = sysread(StdoutRead, $check, 8192))) {
	$newenv .= $check;
}
close StdoutRead;


if ($newenv !~ m!^([0-9]+)\n(/.*)\n([0-9]+)\n(.*)!so) {
	print STDERR "$progname: wrapw output garbled\n";
	print "70\n";

	print StdinWrite "end!\n";
	close StdinWrite;
	waitpid $wrapper, 0;
	UnTmpDirs();
	exit 70;
}
$socksize = $1;
$check = $2;
$envsize = $3;
$newenv = $4;
$check = substr($check, 0, $socksize-1);	# strip nul
if ($her_agent ne $check) {
	print STDERR "$progname: failed to start the wrapw on $her_agent\n";
	print StdinWrite "die!\n";
	print "66\n";

	print StdinWrite "end!\n";
	close StdinWrite;
	waitpid $wrapper, 0;
	UnTmpDirs();
	exit 66;
}
while ($newenv =~ m/([^\000]+)\000(.*)/so) {
	($check, $newenv) = ($1, $2);
	print "\$$check\n" if ($check =~ m/^\w+_d=/ || $check =~ m/^\w+_link=/o || $check =~ m/^\w+_\d+=/o);
}
chown $EUID, -1, $her_dir;		# client made socket, put modes back
chown $EUID, $EGID, $her_agent;		# clinet needs to see the socket

empty:
if ($opts{'P'}) {
	open STDOUT, ">/dev/null";
	$kid = waitpid $opts{'P'}, 0;
	$status = $? < 256 ? $? : ($? >> 8);
}

print StdinWrite "end!\n";
close StdinWrite;
waitpid $wrapper, 0;
UnTmpDirs();

# Exit with (a function of) her exit code
exit $status;