#!/usr/local/bin/perl
# $Xorg: dtcm,v 1.3 2000/08/17 19:54:57 cpqbld Exp $
# CGI script to launch dtcm
#

# define every program we are going to use
$project_root = "XPROJECT_ROOT";
$command = "CGIBINDIR/dtcm.sh";
$xfindproxy = $project_root . "/bin/xfindproxy";
$xauth = $project_root . "/bin/xauth";

# address of our proxy manager
$proxymngr = "XPROXYMNGR";

# make stderr and stdout unbuffered so nothing get lost
select(STDERR); $| = 1;
select(STDOUT); $| = 1;

# print out header to content httpd no matter what happens later on
print "Content-type: text/plain\r\n\r\n";

# let's try not to leave any file behind us if things go really wrong
sub handler {  # 1st argument is signal name
    local($sig) = @_;
    # send error code first and error msg then
    print "1\n";
    print "Error: Caught a SIG$sig -- Oops!\n";
    system "rm -f /tmp/*$$";
    exit(0);
}

$SIG{'INT'} = 'handler';
$SIG{'QUIT'} = 'handler';
$SIG{'TERM'} = 'handler';
$SIG{'KILL'} = 'handler';
$SIG{'STOP'} = 'handler';
# this one is perhaps the most important one, since this is what we should get
# when the user interrupts the GET request
$SIG{'PIPE'} = 'handler';


######################
# sub procedures
######################

# parse an url param of the form: proto:display[;param]
sub parse_url {
    local($input, *proto_ret, *display_ret, *param_ret) = @_;

    # extract param first
    ($sub_url, $param_ret) = split(/;/, $input, 2);
    # then extract proto and display
    ($proto_ret, $display_ret) = split(/:/, $sub_url, 2);
    
}

# parse an auth param of the form: auth=name:key
sub parse_auth {
    local($input, *name_ret, *key_ret) = @_;

    if ($input) {
	($param_name, $param_value) = split(/=/, $input, 2);
	if ($param_name eq "auth") {
	    ($name_ret, $key_ret) = split(/:/, $param_value, 2);
	}
    }
}

# parse an LBX param of the form: either NO or YES[;auth=...]
sub parse_lbx_param {
    local($input, *lbx_ret, *lbx_auth_name_ret, *lbx_auth_key_ret) = @_;

    ($lbx_ret, $lbxparam) = split(/;/, $input, 2);
    if ($lbx_ret eq "YES") {
	# look for an authentication auth in param
	&parse_auth($lbxparam, *lbx_auth_name_ret, *lbx_auth_key_ret);
    }
}

# setup proxy with possible auth, change display parameter when succeeding
sub setup_lbx_proxy {
    local(*display, $auth_name, $auth_key) = @_;

    # setup auth file for xfindproxy
    if ($auth_name && $auth_key) {
	$proxy_input = "/tmp/xlbxauth.$$";
	open(PROXYINPUT, ">$proxy_input");
	print PROXYINPUT "$auth_name\n$auth_key\n";
	close(PROXYINPUT);
	$findproxy_param = " -auth <$proxy_input";
    } else {
	$findproxy_param = "";
    }

    # remove screen number specification if there is one
    ($host, $tmp) = split(/:/, $display);
    ($dpy, $screen) = split(/\./, $tmp);
    $server = $host . ":" . $dpy;

    # let's get an LBX proxy
    open(PROXY, "$xfindproxy -manager $proxymngr -server $server -name LBX $findproxy_param|");
    # get the proxy address from xfindproxy output
    while (<PROXY>) {
	chop;
	($proxy_dpy, $proxy_port) = split(/:/, $_);
	if ($proxy_dpy && $proxy_port) {
	    # build up the new display name
	    $display = $proxy_dpy . ":" . $proxy_port;
	    if ($screen) {
		$display .= "." . $screen;
	    }
	    last;
	}
    }
    close(PROXY);

    if ($proxy_input) {
	system "rm -f $proxy_input";
    }
}

# add entry in authority file
sub add_auth {
    local($display, $auth_name, $auth_key) = @_;

    system "$xauth add $display $auth_name $auth_key";
}


######################
# the main thing now
######################


# handle both ways of getting query
if ($ENV{'QUERY_STRING'})
{
    $query = $ENV{'QUERY_STRING'};
} else {
    $query = $ARGV[0];
}

if ($query)
{
    $cleanup = "";

    # parse params
    %params = split(/\?/, $query);
    foreach $param (split(/\?/, $query)) {

	($name, $value) = split(/=/, $param, 2);
	if ($name eq "WIDTH") {
	    $width = $value;
	} elsif ($name eq "HEIGHT") {
	    $height = $value;
	} elsif ($name eq "UI") {
	    # look at what we got for the UI parameter, it should be of the
	    # form: x11:hostname:dpynum[.screen][;auth=...]
	    &parse_url($value, *proto, *display, *ui_param);
	    if ($proto eq 'x11') {
		$xdisplay = $display;
	    } else {
		# unknown UI protocol!!
	    }
	    # look for an authentication auth in param
	    &parse_auth($ui_param, *xui_auth_name, *xui_auth_key);

	} elsif ($name eq "X-UI-LBX") {
	    &parse_lbx_param($value, *xui_lbx,
			     *xui_lbx_auth_name, *xui_lbx_auth_key);
	} elsif ($name eq "PRINT") {
	    # look at what we got for the PRINT parameter, it should be of the
	    # form: xprint:[printer@]hostname:dpynum[;auth=...]

	    &parse_url($value, *proto, *display, *prt_param);
	    if ($proto eq 'xprint') {
		$xprint = $display;
	    } else {
		# unknown PRINT protocol!!
	    }
	    # look for an authentication auth in param
	    &parse_auth($prt_param, *xprt_auth_name, *xprt_auth_key);

	} elsif ($name eq "X-PRINT-LBX") {
	    &parse_lbx_param($value, *xprt_lbx,
			     *xprt_lbx_auth_name, *xprt_lbx_auth_key);
	}
    }

    # set a common authority file for X and XPrint
    $ENV{'XAUTHORITY'} = "/tmp/xauth.$$";
    # and define its related cleanup command
    $cleanup = "rm -f $ENV{'XAUTHORITY'}";

    # process params
    # Note: we want to process printing first so if for some reason we end up
    # with a conflict between the two authorizations, the display one wins
    if ($xprint) {
	# extract print server from printer specification (xpress@foo:0)
	($xprt_printer, $xprt_display) = split(/\@/, $xprint, 2);
	if (! $xprt_display) {
	    # printer not specified
	    $xprt_display = $xprt_printer;
	    $xprt_printer = "";
	}
	    
	if ($xprt_lbx eq "YES") {
	    &setup_lbx_proxy(*xprt_display,
			     $xprt_lbx_auth_name, $xprt_lbx_auth_key);
	    # rebuild printer specification with new xprt_display
	    $xprint = $xprt_printer . "@" . $xprt_display;
	}
	if ($xprt_auth_name && $xprt_auth_key) {
	    &add_auth($xprt_display, $xprt_auth_name, $xprt_auth_key);
	}
	# specify printer via the environment
	$ENV{'XPRINTER'} = $xprint;
	$ENV{'XPSERVERLIST'} = $xpr_display;
    }
    if ($xdisplay) {

	if ($xui_lbx eq "YES") {
	    &setup_lbx_proxy(*xdisplay, $xui_lbx_auth_name, $xui_lbx_auth_key);
	}
	if ($xui_auth_name && $xui_auth_key) {
	    &add_auth($xdisplay, $xui_auth_name, $xui_auth_key);
	}
	# add display specification to the command line
	$command .= " -display $xdisplay";
	# and put it in the environment too for good measure.
	$ENV{'DISPLAY'} = $xdisplay;
    }
    if ($width && $height) {
	# add geometry specification to the command line
	$command .= " -geometry ${width}x${height}";
    }

    # Start application followed by a cleanup command in the background.
    # The ouput and input need to be redirected, otherwise the CGI process will
    # be kept alive by the http server and the browser will keep waiting for
    # the end of the stream...
    # Catching application's failure is not easy since we want to run it in
    # background and therefore we can't get its exit status. However, we can
    # catch obvious errors by logging its output and after some time looking
    # at whether the application is still running or not. This is determine
    # based on some kind of "lock" file.
    # This is quite complicated but it allows to get some error report without
    # leaving any file behind us in any case.

    $LOCK= "/tmp/lock.$$";
    $LOG= "/tmp/log.$$";
    $LOG2 = "/tmp/log2.$$";
    system "(touch $LOCK; _s=true; $command >$LOG 2>&1 || _s=false; if \$_s; then rm $LOG; else rm $LOCK; fi; if [ -f $LOG2 ]; then rm $LOG2; fi; $cleanup) >/dev/null 2>&1 </dev/null &";

    # sleep for a while to let the application start or fail
    # it's up to you to decide how long it could for the application to fail...
    sleep(5);

    # now lets see if the application died
    if (open(LOCK, "<$LOCK")) {
	close(LOCK);
	# the application seems to be running, remove lock and rename the log
	# so that it gets removed no matter how the application exits later on
	system "rm $LOCK; mv $LOG $LOG2";
	# send success error code as reply
	print "0\n";
    } else {
	# the lock file is gone, for sure the application has failed so send
	# back error code and log
	print "1\n";
	system "cat $LOG; rm $LOG";
    }

} else {

    # reply with an error message
    print "This script requires to be given the proper RX arguments
to run successfully.
";

}