#!/usr/bin/env perl
# $Id: xdisplay.pl,v 1.12 2012/10/19 20:21:43 ksb Exp $
# $Source: /usr/msrc/usr/local/libexec/jacket/RCS/xdisplay.pl,v $
#
# Copy the customer's X credentials to the target user.  Note that this
# is running tainted.  We are going to open two xauths, one to pull the
# creds from the real uid, one to install them in the new effective's
# ~/.Xauthority file.

use strict;
use Getopt::Std;
# 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,.*/,,;

# A good path to find sh, xauth, and sed mostly
$ENV{'PATH'} = "/bin:/usr/bin:/usr/local/bin:/usr/openwin/bin:/usr/X11/bin:/usr/X11R6/bin";

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

if ($opts{'V'}) {
	print "$progname: ", '$Id: xdisplay.pl,v 1.12 2012/10/19 20:21:43 ksb Exp $', "\n",
		"$progname: X server from: \$DISPLAY\n";
	exit 0;
}

if ($opts{'h'}) {
        print   "$usage\n",
                "$progname: usage -h\n",
                "$progname: usage -V\n",
		"P pid       process that is going to get use the X display\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: forward X display to escalated process\n",
		"DISPLAY  the X display to copy\n",
		"HOME=\$H  the target login's home directory allows xauth to find its database\n",
		"         also uses both real and effective uid\n";
	exit 0;
}

# Untaint our params, common code to most jackets. --ksb
shift @ARGV if ($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;		# USAGE
}
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;		# USAGE
}
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;		# USAGE
}
my($PROGRAM) = $1;
if ($ARGV[2] !~ m/^([^:]*):([^:]*)$/o) {
	print STDERR "$progname: euid:egid $ARGV[2] missing colon\n";
	print "65\n" if $opts{'P'};
	exit 65;		# DATAERR
}
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;		# PROTOCOL
}

# If they have the same $HOME we are in trouble (or done depending)
my($our_name, $our_uid, $our_gid, $our_home);
($our_name, undef, $our_uid, $our_gid, undef, undef, undef, $our_home) = getpwuid($<);
if (!defined($our_home) || '' eq $our_home) {
	print STDERR "$progname: getpwuid: $<: $!\n";
	print "67\n" if $opts{'P'};
	exit 67;		# NOUSER
}

# We could pass $LOGNAME in the env from op to get the right name in
# the case where more than 1 login has the same uid.  But you are in
# trouble if you do that anyway, so I'm not going to help you.  --ksb
my($her_uid, $her_gid, $her_name, $her_home);
($her_name, undef, $her_uid, $her_gid, undef, undef, undef, $her_home) = getpwuid($EUID);
if (!defined($her_home) || '' eq $her_home) {
	print STDERR "$progname: getpwuid: $EUID: $!\n";
	print "67\n" if $opts{'P'};
	exit 67;		# NOUSER
}

if (!exists $ENV{'DISPLAY'} || $ENV{'DISPLAY'} !~ m/^([-_A-Za-z0-9.]*:[0-9.]+)/) {
	print STDERR "$progname: invalid or unset \$DISPLAY\n";
	print "69\n" if $opts{'P'};
	exit 69;		# UNAVAILABLE (no display)
}
my($display) = $1;

my($kid, $status);

# When they are the same file we can't do much to help.
my(@hers) = stat("$her_home/.Xauthority");
my(@ours) = stat("$our_home/.Xauthority");
if ($her_home eq $our_home || ($hers[0] == $ours[0] && $hers[1] == $ours[1])) {
	# XXX chown, chmod, or chgrp the .Xauthority file, then put it back?
	print "# no need to move display\n";
	$status = 0;
	if ($opts{'P'}) {
		open STDOUT, ">/dev/null";
		$kid = waitpid $opts{'P'}, 0;
		$status = $? < 256 ? $? : ($? >> 8);
	}
	exit $status;
}

# Open up a communication channel between each user's xauth
if (! pipe TARG, CALL) {
	print STDERR "$progname: pipe: $!\n";
	print "71\n" if $opts{'P'};
	exit 71;		# OSERR
}

my($call_pid, $her_pid);
# Start reading the calling user's authority file using their own privlages
# if the real user reads their .Xauthority file by virtue of some group
# other than their login group we may fail here.  We'd need the grouplist
# from an initgroups (but we may still have their group).
# building "xauth nextract - $display |xauth nmerge -", with checks
if (0 == ($call_pid = fork())) {
	($<, $>) = ($<, $<);
	($(, $)) = ($(, $();
	open STDOUT, ">&CALL" or do {
		print STDERR "$progname: dup: $!\n";
		print "71\n" if $opts{'P'};
		exit 71;	# OSERR
	};
	close CALL;
	$ENV{"USER"} = $our_name;
	$ENV{"HOME"} = $our_home;
	# The grep for . fails if we didn't find any data.
	exec "xauth nextract - '$display' 2>/dev/null|exec grep ." or do {
	print STDERR "$progname: exec: $!\n";
	print "72\n" if $opts{'P'};
	exit 72;		# OSFILE
	}
}
if (-1 == $call_pid) {
	print STDERR "$progname: fork: $!\n";
	print "71\n" if $opts{'P'};
	exit 71;		# OSERR
};
close CALL;

# Put the creds in the target user's authority file
if (0 == ($her_pid = fork())) {
	($<, $>) = ($her_uid, $her_uid);
	($(, $)) = ($her_gid, $her_gid);
	open STDIN, "<&TARG" or do {
		print STDERR "$progname: dup: $!\n";
		print "71\n" if $opts{'P'};
		exit 71;	# OSERR
	};
	close TARG;
	$ENV{"USER"} = $her_name;
	$ENV{"HOME"} = $her_home;
	exec "[ -w '$her_home/.Xauthority' ] || [ ! -e '$her_home/.Xauthority' -a -w '$her_home' ] && exec xauth nmerge -" or do {
	print STDERR "$progname: exec: xauth: $!\n";
	print "71\n" if $opts{'P'};
	exit 71;		# OSERR
	}
}
if (-1 == $her_pid) {
	print STDERR "$progname: fork: $!\n";
}
close TARG;

# Wait for the "xauth | xath" and remember, fail if either didn't work.
my($code_from, $code_to);
$code_from = -1 == (waitpid $call_pid, 0) ? 66 : $?;
$code_to   = -1 == (waitpid $her_pid, 0) ? 67 : $?;
print "# xdisplay from $call_pid exits $code_from, to $her_pid exits $code_to\n";
if (0 != $code_to) {
	print STDERR "$progname: target xauth failed\n";
	print "67\n" if $opts{'P'};
	exit 67;		# NOHOST
}
if (0 != $code_from) {
	print STDERR "$progname: display $display not found by xauth\n";
	print "66\n" if $opts{'P'};
	exit 66;		# NOINPUT
}

# Release the process that wants the X display, with a debug comment for op
print STDOUT "\$DISPLAY=$display\n";
if (! $opts{'P'}) {
	exit 0;			# go go go...
}

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

# Remove the X credentials?  Not really a great idea (they could have
# copied them in anycase).  So we might as well let them alone, really.
if (0 == ($her_pid = fork())) {
	($<, $>) = ($her_uid, $her_uid);
	($(, $)) = ($her_gid, $her_gid);
	$ENV{"USER"} = $her_name;
	$ENV{"HOME"} = $her_home;
	exec "exec xauth remove '$display'" or do {
	print STDERR "$progname: exec: xauth: $!\n";
	print "71\n" if $opts{'P'};
	exit 71;		# OSERR
	}
}
waitpid $her_pid, 0;

# Exit with her exit code.
exit $status;