#!/usr/bin/perl
#
# Copyright (C) 2007, 2008, 2009 Fabian Knittel
# Copyright (C) 2008 Philipp Kern
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

use warnings;
use strict;
use POSIX qw(setsid setuid setgid);
use POSIX ":sys_wait_h";
use IO::Socket;
use Sys::Syslog;

# Declare functions
#

sub main();
sub logerror($);
sub loginfo($);
sub logdebug($);
sub daemonize($);
sub my_die($);
sub run_kdmctl($);
sub run_xauth($$);
sub handle_connection($$);
sub handle_abort($);
sub handle_list_servers($$);
sub handle_flexi_xserver($);
sub search_auth_key($$);
sub handle_set_vt($$);
sub handle_get_config($$$);
sub open_socket($);



# Main program
#
main();

# Functions.
#

sub main()
{
	my %CONFIG = (
		'PID_FILE' => '/var/run/gdm-emulatord.pid',
		'GDM_SOCKET_FILE' => '/var/run/gdm_socket',
		'GOTO_BACKGROUND' => 1,
		'DEFAULT_MIN_UID' => 1000,
		'DEFAULT_EXCLUDE_USERS' => ''
	);

	openlog("gdm-emulatord", 'pid', 'user');

	$SIG{'PIPE'} = 'IGNORE';
	$SIG{'QUIT'} = \&handle_abort;
	$SIG{'INT'} = \&handle_abort;
	$SIG{'TERM'} = \&handle_abort;


	my $gdm_socket = open_socket($CONFIG{'GDM_SOCKET_FILE'});

	if ($CONFIG{'GOTO_BACKGROUND'}) {
		daemonize($CONFIG{'PID_FILE'});
	}

	loginfo "Started gdm-emulatord. Will listen on ".
			$CONFIG{'GDM_SOCKET_FILE'};
	while (1) {
		my $conn = $gdm_socket->accept;
		if (!$conn) {
			logerror "Failed to accept connection: $!";
			sleep 5;
			next;
		}

		# Connections are short-lived, so we simply handle them in a
		# blocked fashion.
		handle_connection($conn, \%CONFIG);
	}

	# Never reached.
	exit(0);
}

sub open_socket($)
{
	my $gdm_socket_fn = $_[0];

	unlink $gdm_socket_fn;
	my $gdm_socket;
	defined($gdm_socket = IO::Socket::UNIX->new(Type => SOCK_STREAM,
		                                    Local => $gdm_socket_fn,
						    Listen => 1)) or
		my_die "could not open gdm socket: $!";
	chmod 0666, $gdm_socket_fn or
		my_die "could not set permissions on socket: $!";
	return $gdm_socket;
}

sub handle_connection($$)
{
	my ($conn, $config) = @_;

	my $curr_auth;

	my $line;
	while (defined($line = $conn->getline)) {
		chomp $line;

		if ($line eq 'VERSION') {
			$conn->print("GDM 2.16.0\n");
		} elsif ($line eq 'CONSOLE_SERVERS') {
			handle_list_servers($conn, 'alllocal');
		} elsif ($line eq 'ALL_SERVERS') {
			handle_list_servers($conn, 'all');
		} elsif ($line eq 'CLOSE') {
			last;
		} elsif ($line =~ /^AUTH_LOCAL (.+)/) {
			$curr_auth = search_auth_key($conn, $1);
		} elsif ($line =~ /^SET_SAFE_LOGOUT_ACTION (.+)/) {
			if (!defined($curr_auth)) {
				logerror "Attempted SET_SAFE_LOGOUT_ACTION ".
					"without prior authentication";
				$conn->print("ERROR 100 Not authenticated\n");
			} else {
				# TODO: use this stuff somehow
				$conn->print("OK\n");
			}
		} elsif ($line =~ /^SET_VT (\d+)/) {
			my $vtnum = $1;
			if (!defined($curr_auth)) {
				logerror "Attempted SET_VT without ".
					"prior authentication";
				$conn->print("ERROR 100 Not authenticated\n");
			} else {
				handle_set_vt($conn, $vtnum);
			}
		} elsif ($line =~ /^FLEXI_XSERVER/) {
			if (!defined($curr_auth)) {
				logerror "Attempted FLEXI_XSERVER without ".
					"prior authentication";
				$conn->print("ERROR 100 Not authenticated\n");
			} else {
				handle_flexi_xserver($conn);
			}
		} elsif ($line eq 'QUERY_LOGOUT_ACTION') {
			if (!defined($curr_auth)) {
				logerror "Attempted QUERY_LOGOUT_ACTION ".
					"without prior authentication";
				$conn->print("ERROR 100 Not authenticated\n");
			} else {
				# TODO: Implement.
				$conn->print("OK \n");
			}
		} elsif ($line =~ /^GET_CONFIG (.+)/) {
			handle_get_config($conn, $config, $1);
		} else {
			logerror "Received unknown command: '$line'";
			$conn->print("ERROR 0 Not implemented\n");
		}
	}

	$conn->close;
}

sub run_kdmctl($)
{
	my $param = $_[0];

	if (open(CTL, "/usr/bin/kdmctl $param|")) {
		my $line = <CTL>;
		chomp($line);
		close(CTL);

		my @TOKENS = split(/\t/, $line);
		return @TOKENS;
	} else {
		return;
	}
}

sub run_xauth($$)
{
	my ($xauth_file, $xdisp) = @_;

	if (open(XAUTH, "/usr/bin/xauth -f $xauth_file list $xdisp|")) {
		my $line = <XAUTH>;
		chomp($line);
		close(XAUTH);

		if ($line !~ /^.+$xdisp +MIT-MAGIC-COOKIE-1 +([a-f0-9]+)$/) {
			logerror "xauth output does not match expected output";
			return;
		}
		my $xauthcookie = $1;
		return $xauthcookie;
	} else {
		return;
	}
}

sub handle_set_vt($$)
{
	my $conn = $_[0];
	my $vtnum = $_[1];

	loginfo "Received request to activate vt$vtnum";
	my @TOKENS = run_kdmctl('activate vt'.$vtnum);
	if (@TOKENS) {
		my $result = shift @TOKENS;
		if ($result eq 'ok') {
			$conn->print("OK\n");
			# Avoid DoS by waiting for a moment.
			sleep 7;
		} else {
			logerror "kdmctl failed to provide switch to vt $vtnum";
			$conn->print("ERROR 2 kdmctl failed to switch to ".
			             "vt $vtnum\n");
		}
	} else {
		logerror "Failed to call kdmctl";
		$conn->print("ERROR 2 Failed to call kdmctl\n");
	}
}

sub handle_flexi_xserver($)
{
	my $conn = $_[0];

	loginfo "Received request for new xsession";
	my @TOKENS = run_kdmctl('reserve');
	if (@TOKENS) {
		my $result = shift @TOKENS;
		if ($result eq 'ok') {
			$conn->print("OK\n");
			# Avoid DoS by waiting for a moment.
			sleep 7;
		} else {
			logerror "kdmctl failed to provide ".
				 "new session";
			$conn->print("ERROR 2 kdmctl failed to".
				     " provide new session\n");
		}
	} else {
		logerror "Failed to call kdmctl";
		$conn->print("ERROR 2 Failed to call kdmctl\n");
	}
}

sub search_auth_key($$)
{
	my ($conn, $xauthcookie) = @_;

	my @TOKENS = run_kdmctl("list alllocal");
	if (@TOKENS) {
		my $result = shift @TOKENS;
		if ($result eq 'ok') {
			foreach my $token (@TOKENS) {
				my @ELS = split(/,/, $token);
				my $disp = $ELS[0];
				if ($disp !~ /^:\d+/) {
					# We only care for X displays.
					next;
				}
				if (!defined($ELS[2])) {
					# We need a logged-in user.
					next;
				}
				my $user = $ELS[2];

				my @PW = getpwnam($user);
				if (!@PW) {
					# Somehow, the user has no entry in the
					# system's password database. Skip.
					logdebug "Skipping invalid user $user";
					next;
				}
				my $homedir = $PW[7];

				my $xauth_file = $homedir."/.Xauthority";
				if (!-e $xauth_file) {
					# User has no xauth file, so we can't
					# recover the xauth cookie. Skip.
					logdebug "Skipping user $user without ".
						".Xauthority file";
					next;
				}

				my $user_xauthcookie = run_xauth($xauth_file,
					$disp);
				if (!defined($user_xauthcookie)) {
					# Cookie could not be read
					logerror "X auth cookie reading failed";
					next;
				}
				if ($user_xauthcookie ne $xauthcookie) {
					# Cookie does not match.
					next;
				}

				logdebug "User $user authenticated for ".
					"disp $disp";
				$conn->print("OK\n");
				return { 'user' => $user,
					'disp' => $disp,
					'cookie' => $xauthcookie };
			}
		} else {
			logerror "kdmctl list output could ".
				 "not be parsed";
			$conn->print("ERROR 999 kdmctl list ".
				"output could not be parsed\n");
		}
	} else {
		logerror "Failed to call kdmctl";
		$conn->print("ERROR 999 Failed to call kdmctl\n");
	}

	logerror "Failed to find a user matching the authentication";
	$conn->print("ERROR 100 Not authenticated\n");
	return;
}

sub handle_list_servers($$)
{
	my $conn = $_[0];
	my $type = $_[1];

	my @TOKENS = run_kdmctl("list $type");
	if (@TOKENS) {
		my $result = shift @TOKENS;
		if ($result eq 'ok') {
			my @SERVERS;

			foreach my $server (@TOKENS) {
				my @ELS = split(/,/, $server);
				my $disp = $ELS[0];
				my $vt = $ELS[1];
				if ($vt !~ /^vt(\d+)$/) {
					logerror "could not parse vt info $vt";
					next;
				}
				my $vtnum = $1;
				my $user = defined($ELS[2]) ? $ELS[2] : '';
				push @SERVERS, $disp.",".$user.",".$vtnum;
			}

			my $server_list = join(';', @SERVERS);
			logdebug "Sending consoles $server_list";
			$conn->print("OK $server_list\n");
		} else {
			logerror "kdmctl list output could ".
				 "not be parsed";
			$conn->print("ERROR 999 kdmctl list ".
				"output could not be parsed\n");
		}
	} else {
		logerror "Failed to call kdmctl";
		$conn->print("ERROR 999 Failed to call kdmctl\n");
	}
}

sub handle_get_config($$$)
{
	my ($conn, $config, $var) = @_;

	logdebug "Request for variable $var";
	if ($var eq 'greeter/MinimalUID') {
		my $min_uid = ${$config}{'DEFAULT_MIN_UID'};

		logdebug "Sending minimal UID $min_uid";
		$conn->print("OK $min_uid\n");
	} elsif ($var eq 'greeter/Exclude') {
		my $excl_users = ${$config}{'DEFAULT_EXCLUDE_USERS'};

		logdebug "Sending excluded users \"$excl_users\"";
		$conn->print("OK $excl_users\n");
	} else {
		logdebug "Declining request for variable $var";
		$conn->print("ERROR 50 Unsupported key <$var>\n");
	}
}

sub daemonize($)
{
	my $pid_file = $_[0];

	chdir('/') or my_die "Can't chdir to /: $!";

	open(STDIN, '/dev/null') or my_die "Can't read /dev/null: $!";
	open(STDOUT, '>>/dev/null') or my_die "Can't write to /dev/null: $!";
	open(STDERR, '>>/dev/null') or my_die "Can't write to /dev/null: $!";

	my $pid;
	defined($pid = fork()) or my_die "Can't fork: $!";

	if ($pid > 0) {
		# We're the parent.
		open(PID, ">$pid_file") or
			my_die "Can't write pid file $pid_file: $!\n";
		print PID $pid."\n";
		close(PID);
		exit 0;
	}

	setsid() or my_die "Can't start a new session: $!";
}

sub my_die($)
{
	logerror "fatal: ".$_[0];
	closelog();
	exit 1;
}

sub logerror($)
{
	syslog('err', $_[0]);
}

sub loginfo($)
{
	syslog('info', $_[0]);
}

sub logdebug($)
{
	syslog('debug', $_[0]);
}

sub handle_abort($)
{
	my $sig = $_[0];

	loginfo("gdm-emulatord received signal $sig.");
	exit(1);
}
