#!/usr/bin/perl
#
# This is a simple example PAM authentication agent, it implements a
# simple shared secret authentication scheme. The PAM module pam_secret.so
# is its counter part. Both the agent and the remote server are able to
# authenticate one another, but the server is given the opportunity to
# ignore a failed authentication.
#

$^W = 1;
use strict;
use IPC::Open2;
$| = 1;

# display extra information to STDERR
my $debug = 0;
if (scalar @ARGV) {
    $debug = 1;
}

# Globals

my %state;
my $default_key;

my $next_key = $$;

# loop over binary prompts
for (;;) {
    my ($control, $data) = ReadBinaryPrompt();
    my ($reply_control, $reply_data);

    if ($control == 0) {
	if ($debug) {
	    print STDERR "agent: no packet to read\n";
	}
	last;
    } elsif ($control == 0x02) {
	($reply_control, $reply_data) = HandleAgentSelection($data);
    } elsif ($control == 0x01) {
	($reply_control, $reply_data) = HandleContinuation($data);
    } else {
	if ($debug) {
	    print STDERR
		"agent: unrecognized packet $control {$data} to read\n";
	}
	($reply_control, $reply_data) = (0x04, "");
    }

    WriteBinaryPrompt($reply_control, $reply_data);
}

# Only willing to exit well if we've completed our authentication exchange

if (scalar keys %state) {
    if ($debug) {
	print STDERR "The following sessions are still active:\n  ";
	print STDERR join ', ', keys %state;
	print STDERR "\n";
    }
    exit 1;
} else {
    exit 0;
}

sub HandleAgentSelection ($) {
    my ($data) = @_;

    unless ( $data =~ /^([a-zA-Z0-9_]+\@?[a-zA-Z0-9_.]*)\/(.*)$/ ) {
	return (0x04, "");
    }

    my ($agent_name, $payload) = ($1, $2);
    if ($debug) {
	print STDERR "agent: ". "agent=$agent_name, payload=$payload\n";
    }

    # this agent has a defined name
    if ($agent_name ne "secret\@here") {
	if ($debug) {
	    print STDERR "bad agent name: [$agent_name]\n";
	}
	return (0x04, "");
    }

    # the selection request is acompanied with a hexadecimal cookie
    my @tokens = split '\|', $payload;

    unless ((scalar @tokens) == 2) {
	if ($debug) {
	    print STDERR "bad payload\n";
	}
	return (0x04, "");
    }

    unless ($tokens[1] =~ /^[a-z0-9]+$/) {
	if ($debug) {
	    print STDERR "bad server cookie\n";
	}
	return (0x04, "");
    }

    my $shared_secret = IdentifyLocalSecret($tokens[0]);

    unless (defined $shared_secret) {
	# make a secret up
	if ($debug) {
	    print STDERR "agent: cannot authenticate user\n";
	}
	$shared_secret = GetRandom();
    }

    my $local_cookie = GetRandom();
    $default_key = $next_key++;

    $state{$default_key} = $local_cookie ."|". $tokens[1] ."|". $shared_secret;

    if ($debug) {
	print STDERR "agent: \$state{$default_key} = $state{$default_key}\n";
    }

    return (0x01, $default_key ."|". $local_cookie);
}

sub HandleContinuation ($) {
    my ($data) = @_;

    my ($key, $server_digest) = split '\|', $data;

    unless (defined $state{$key}) {
	# retries and out of sequence prompts are not permitted
	return (0x04, "");
    }

    my $expected_digest = CreateDigest($state{$key});
    my ($local_cookie, $remote_cookie, $shared_secret)
	= split '\|', $state{$key};
    delete $state{$key};

    unless ($expected_digest eq $server_digest) {
	if ($debug) {
	    print STDERR "agent: don't trust server - faking reply\n";
	    print STDERR "agent: got      ($server_digest)\n";
	    print STDERR "agent: expected ($expected_digest)\n";
	}

	## FIXME: Agent should exchange a prompt with the client warning
	## that the server is faking us out.

	return (0x03, CreateDigest($expected_digest . $data . GetRandom()));
    }

    if ($debug) {
	print STDERR "agent: server appears to know the secret\n";
    }

    my $session_authenticated_ticket =
	CreateDigest($remote_cookie."|".$shared_secret."|".$local_cookie);

    # FIXME: Agent should set a derived session key environment
    # variable (available for the client (and its children) to sign
    # future data exchanges.

    if ($debug) {
	print STDERR "agent: should putenv("
	    ."\"AUTH_SESSION_TICKET=$session_authenticated_ticket\")\n";
    }

    # return agent's authenticating digest
    return (0x03, CreateDigest($shared_secret."|".$remote_cookie
			       ."|".$local_cookie));
}

sub ReadBinaryPrompt {
    my $buffer = "     ";
    my $count = read(STDIN, $buffer, 5);
    if ($count == 0) {
	# no more packets to read
	return (0, "");
    }

    if ($count != 5) {
	# broken packet header
	return (-1, "");
    }

    my ($length, $control) = unpack("N C", $buffer);
    if ($length < 5) {
	# broken packet length
	return (-1, "");
    }

    my $data = "";
    $length -= 5;
    while ($count = read(STDIN, $buffer, $length)) {
	$data .= $buffer;
	if ($count != $length) {
	    $length -= $count;
	    next;
	}

	if ($debug) {
	    print STDERR "agent: ". "data is [$data]\n";
	}

	return ($control, $data);
    }

    # broken packet data
    return (-1, "");
}

sub WriteBinaryPrompt ($$) {
    my ($control, $data) = @_;

    my $length = 5 + length($data);
    if ($debug) {
	printf STDERR "agent: ". "{%d|0x%.2x|%s}\n", $length, $control, $data;
    }
    my $bp = pack("N C a*", $length, $control, $data);
    print STDOUT $bp;
    if ($debug) {
	printf STDERR "agent: ". "agent has replied\n";
    }
}

##
## Here is where we parse the simple secret file
## The format of this file is a list of lines of the following form:
##
## user@client0.host.name  secret_string1
## user@client1.host.name  secret_string2
## user@client2.host.name  secret_string3
##

sub IdentifyLocalSecret ($) {
    my ($identifier) = @_;
    my $secret;

    if (open SECRETS, "< ". (getpwuid($<))[7] ."/.secret\@here") {
	my $line;
	while (defined ($line = <SECRETS>)) {
	    my ($id, $sec) = split /[\s]+/, $line;
	    if ((defined $id) && ($id eq $identifier)) {
		$secret = $sec;
		last;
	    }
	}
	close SECRETS;
    }

    return $secret;
}

## Here is where we generate a message digest

sub CreateDigest ($) {
    my ($data) = @_;

    my $pid = open2(\*MD5out, \*MD5in, "/usr/bin/md5sum -")
	or die "you'll need /usr/bin/md5sum installed";

    my $oldfd = select MD5in; $|=1; select $oldfd;
    if ($debug) {
	print STDERR "agent: ". "telling md5: <$data>\n";
    }
    print MD5in "$data";
    close MD5in;
    my $reply = <MD5out>;
    ($reply) = split /\s/, $reply;
    if ($debug) {
	print STDERR "agent: ". "md5 said: <$reply>\n";
    }
    close MD5out;

    return $reply;
}

## get a random number

sub GetRandom {

    if ( -r "/dev/urandom" ) {
	open RANDOM, "< /dev/urandom" or die "crazy";

	my $i;
	my $reply = "";

	for ($i=0; $i<4; ++$i) {
	    my $buffer = "    ";
	    while (read(RANDOM, $buffer, 4) != 4) {
		;
	    }
	    $reply .= sprintf "%.8x", unpack("N", $buffer);
	    if ($debug) {
		print STDERR "growing reply: [$reply]\n";
	    }
	}
	close RANDOM;

	return $reply;
    } else {
	print STDERR "agent: ". "[got linux?]\n";
	return "%.8x%.8x%.8x%.8x", time, time, time, time;
    }

}