#!/usr/bin/env perl
# kl -- Kerberos credential cache viewer
use warnings;
use strict;
use feature qw(say switch);
use Getopt::Long qw(:config bundling);
use List::Util qw(max);
use Nullroute::Lib;

my %COLORS = (
	tgt_local	=> "32", # same realm as client
	tgt_cross	=> "35", # immediate cross-realm
	tgt_distant	=> "35", # distant cross-realm
	no_tgt		=> "34", # tickets with no corresponding TGT
	referral	=> "34", # empty realm

	expiring	=> "1;33",
	expired		=> "1;31",
	invalid		=> "1;35",

	bold		=> "1",
	dark		=> "2",
	reset		=> "0",
);

my $verbose;
my $counter;

sub fmt {
	my ($color, $str, $fmt) = @_;

	if (!$str) {
		$str = "";
	}
	if ($fmt) {
		$str = sprintf($fmt, $str);
	}
	if ($str && $color) {
		return $color.$str.$COLORS{reset};
	}
	return $str;
}

sub lpad {
	my ($str, $fmt, $max) = @_;

	return " "x($max - length($str)) . ($fmt // $str);
}

sub rpad {
	my ($str, $fmt, $max) = @_;

	return ($fmt // $str) . " "x($max - length($str));
}

sub mangle_name {
	mangle_principal((shift)->{server_name});
}

sub mangle_principal {
	join "/", map {join ".", reverse split /\./, $_} split /\//, lc shift;
}

sub enum_ccaches {
	my @ccaches;

	open(my $proc, "-|", "pklist", "-l")
		or _die("'pklist' not found");
	while (<$proc>) {
		chomp;
		my @l = split(/\t/, $_);
		for (shift @l) {
			if ($_ eq "cache") {
				my ($ccache, $princ) = @l;
				push @ccaches, [$ccache, $princ];
			}
		}
	}
	close($proc);

	return @ccaches;
}

sub display_ccache {
	my ($ccache) = @_;

	my @pklist_args;
	my @fields;
	my $cache;
	my $defprinc;
	my $defrealm;
	my @extrealms;
	my %tgtcreds;
	my %creds;
	my $init;
	my $tgt;

	# read tickets from ccache

	if (defined $ccache) {
		_debug("examining ccache '$ccache'");
		push @pklist_args, ("-c", $ccache);
	} else {
		_debug("examining system default ccache");
	}

	open(my $proc, "-|", "pklist", @pklist_args)
		or _die("'pklist' must be installed to use this tool");

	while (<$proc>) {
		chomp;
		my @l = split(/\t/, $_);
		for (shift @l) {
			if ($_ eq "cache") {
				($cache, $defprinc) = @l;
				# If I ever decide to merge the 'cache' line formats in pklist.
				if (defined $defprinc) {
					($defrealm) = $defprinc =~ /@([^@]+)$/;
				}
			}
			elsif ($_ eq "principal") {
				($defprinc) = @l;
				($defrealm) = $defprinc =~ /@([^@]+)$/;
			}
			elsif ($_ eq "CREDENTIALS") {
				@fields = @l;
			}
			elsif ($_ eq "ticket") {
				my %tkt = ();
				@tkt{@fields} = @l;
				my ($name, $realm) = $tkt{server_name} =~ /^(.+)@([^@]*)$/;
				push @extrealms, $realm
					unless $realm eq $defrealm;

				if ($tkt{flags} =~ /I/) {
					$init = \%tkt;
				}

				if ($name =~ m|^krbtgt/(.+)| && $realm ne '') {
					push @{$tgtcreds{$1}}, \%tkt;
					push @extrealms, $1
						unless $1 eq $defrealm;
					if ($1 eq $realm) {
						$tgt = \%tkt;
					}
				} else {
					push @{$creds{$realm}}, \%tkt;
				}
			}
		}
	}
	close($proc);

	if (!defined $cache) {
		return 1;
	}

	if ($defrealm eq 'WELLKNOWN:ANONYMOUS') {
		($defrealm) = ($init // $tgt)->{server_name} =~ /^.+@([^@]+)$/;
	}

	# format TGT expiration time

	my @expirystr;

	if (!%creds && !%tgtcreds) {
		push @expirystr, "credential cache is empty";
		goto do_print;
	}

	my $starting = $init->{start_time} || $tgt->{start_time};

	my $expiry = $init->{expiry_time} || $tgt->{expiry_time};

	my $renew = $tgt ? $tgt->{renew_time} : 0;

	my $flags = $init->{flags} || $tgt->{flags};

	if ($flags
	    && $flags =~ /d/
	    && $flags =~ /i/
	    && $starting <= time) {
		push @expirystr, fmt($COLORS{invalid}, "invalid");
	}

	if ($starting > time) {
		push @expirystr, "postdated, will become valid in ".interval($starting);
	} elsif ($expiry <= time) {
		push @expirystr, fmt($COLORS{expired}, "expired");
	} elsif ($expiry <= time + 3600) {
		push @expirystr, fmt($COLORS{expiring}, "expire in ".interval($expiry));
	} else {
		push @expirystr, "expire in ".interval($expiry);
	}

	if ($flags
	    && $flags =~ /R/
	    && $starting <= time
	    && $expiry > time
	    && $renew > time) {
		push @expirystr, "renewable for ".interval($renew);
	} else {
		push @expirystr, "not renewable";
	}

	# output tickets sorted by realm, server name

do_print:

	my $INDENT = 2;

	say "" if $counter++;

	say "* Credentials for ".fmt($COLORS{bold}, $defprinc);
	say " "x$INDENT, "kept in '".$ccache."'" if $verbose;
	say " "x$INDENT, join(", ", @expirystr) if @expirystr;
	say "";

	my @realms = uniq grep {$_ ne $defrealm}
			  sort {$a eq '' ? 1 :
				$b eq '' ? -1 :
				$a cmp $b} (@extrealms);

	for my $realm ($defrealm, @realms) {
		_debug("printing tickets for realm '$realm'");

		if ($realm eq '' && !$verbose) {
			_debug("skipping referral pseudo-realm");
			next;
		}

		$tgtcreds{$realm} //= [];
		$creds{$realm} //= [];

		my @creds = (
			(sort {$b->{expiry_time} <=> $a->{expiry_time}} @{$tgtcreds{$realm}}),
			(sort {$b->{expiry_time} <=> $a->{expiry_time}}
			 sort {mangle_name($a) cmp mangle_name($b)} @{$creds{$realm}}),
		);

		my $num_tgt = 0;
		my $num_srv = 0;
		my %seen_srv = ();

		if (!@{$tgtcreds{$realm}}) {
			my ($color, $label);
			if ($realm eq '') {
				$color = $COLORS{referral};
				$label = fmt($color.$COLORS{bold}, "(referral tickets)");
			} else {
				$color = $COLORS{no_tgt};
				$label = fmt($color.$COLORS{bold}, $realm);
				$label .= " ".fmt($color, "(no TGT found)");
			}

			say " "x$INDENT, $label;
		}

		for my $tkt (@creds) {
			my %str;
			my %fmt;
			my %max;

			next if $seen_srv{$tkt->{server_name}
					  .",".$tkt->{client_name}
					  .",".$tkt->{flags}}++;

			my ($svname, $svrealm) = $tkt->{server_name} =~ /^(.+)@(.*)$/;

			if ($svname =~ m|^krbtgt/(.+)$| && $svrealm ne '') {
				my $color = "0";
				my $nextrealm = $1;

				if ($num_tgt && !$verbose) {
					_debug("skipping TGT '$svname'");
					next;
				}

				if ($svrealm eq $defrealm) {
					if ($svrealm eq $nextrealm) {
						$color = $COLORS{tgt_local};
					} else {
						$color = $COLORS{tgt_cross};
					}
				} else {
					$color = $COLORS{tgt_distant};
				}

				$str{label} .= $nextrealm;
				$fmt{label} .= fmt($color,
						fmt($COLORS{bold}, $nextrealm));

				if ($svrealm eq $nextrealm && $svrealm eq $defrealm) {
					$str{label} .= " (local)";
					$fmt{label} .= " ".fmt($color, "(local)");
				} else {
					$str{label} .= " (via $svrealm)";
					$fmt{label} .= " ".fmt($color, "(via $svrealm)");
				}

				$num_tgt++;
			} else {
				$str{label} .= " "x2;
				$fmt{label} .= " "x2;

				$str{label} .= $svname;
				if ($svname =~ /\/(\Q$svrealm\E)$/i) {
					# service/domain (matching the realm, e.g. afs/foo.tld)
					$svname =~ s//\/$COLORS{dark}$1$COLORS{reset}/;
				}
				elsif ($svname =~ /\/([^\/]+)(\.\Q$svrealm\E)$/i) {
					# service/host.domain (matching the realm)
					$svname =~ s//\/$COLORS{bold}$1$COLORS{reset}$COLORS{dark}$2$COLORS{reset}/;
				}
				elsif ($svname =~ /\/([^.\/]+)\./) {
					# service/host.domain (*not* matching the realm)
					$svname =~ s//\/$COLORS{bold}$1$COLORS{reset}./;
				}
				elsif ($svname =~ /\/([^.\/]+)$/) {
					# service/host
					$svname =~ s//\/$COLORS{bold}$1$COLORS{reset}/;
				}
				$fmt{label} .= $svname;

				if ($tkt->{client_name} ne $defprinc) {
					my ($defname) = ($tkt->{client_name} =~ /^(.+)@/);
					$str{label} .= " for $defname";
					$fmt{label} .= " ";
					$fmt{label} .= fmt($COLORS{for_client}, "for ");
					$fmt{label} .= fmt($COLORS{for_client},
							fmt($COLORS{bold}, $defname));
				}

				$num_srv++;
			}
			$max{label} = max(50, length($str{label}));

			$str{flags} = $tkt->{flags};
			$max{flags} = 8;

			if ($tkt->{expiry_time} > time) {
				$str{expiry} = interval($tkt->{expiry_time});
			} else {
				$str{expiry} = "expired";
			}

			if ($tkt->{start_time} > time) {
				$fmt{expiry} = fmt($COLORS{invalid}, $str{expiry});
			} elsif ($tkt->{expiry_time} <= time) {
				$fmt{expiry} = fmt($COLORS{expired}, $str{expiry});
			} elsif ($tkt->{expiry_time} <= time+300) {
				$fmt{expiry} = fmt($COLORS{expiring}, $str{expiry});
			} else {
				$fmt{expiry} = $str{expiry};
			}
			$max{expiry} = 8;

			say " "x$INDENT,
				rpad($str{label}, $fmt{label}, $max{label}), " ",
				rpad($str{flags}, $fmt{flags}, $max{flags}), " ",
				lpad($str{expiry}, $fmt{expiry}, $max{expiry});
		}

		if (!$num_srv) {
			say " "x$INDENT,
				"  ".fmt($COLORS{dark}, "(no service tickets)"),
				;
		}
	}
	return 0;
}

sub usage {
	say for (
	"Usage: $::arg0 [-v] [-c <ccname> | -l]",
	"",                       #
	"  -c, --cache=PATH       Show contents of given ccache",
	"  -l, --[no-]list        List a 'DIR:' ccache collection",
	"  -v, --verbose          Show referrals, duplicate TGTs",
	"",
	"Flags:",
	"  A   pre-authenticated           a   anonymous",
	"  D   postdateable                d   postdated",
	"  F   forwardable                 f   forwarded",
	"  H   hardware-authenticated",
	"  I   initial                     i   invalid",
	"  O   ok as delegate",
	"  P   proxiable                   p   proxied",
	"  R   renewable",
	"  T   transit policy checked",
	);
}

my $ccache;
my $list_all;

GetOptions(
	"help"		=> sub { usage(); exit; },
	"c|cache=s"	=> \$ccache,
	"l|list!"	=> \$list_all,
	"v|verbose!"	=> \$verbose,
) or exit 2;

if (-t 1 && $ENV{TERM}) {
	%COLORS = map {$_ => "\e[$COLORS{$_}m"} keys %COLORS;
} else {
	%COLORS = map {$_ => ""} keys %COLORS;
}

my $defcc = $ccache // $ENV{KRB5CCNAME};

if (defined $ccache) {
	$list_all = 0;
} else {
	$list_all = 1;
}

my @visible;

if ($list_all) {
	@visible = map {$_->[0]} sort {$a->[1] cmp $b->[1]} enum_ccaches();
} else {
	@visible = ($ccache);
}

if (@visible) {
	display_ccache($_) for @visible;
} else {
	say "No credentials cache found.";
}
