#! /usr/bin/perl -w

# Quick hack to inspect decrypted tacacs+ packets
# Needs to run as root to be able to catch packets

# Make a (access restricted) file in $HOME/conf/tacacs with a line like:
# key = "Put your shared secret here"

# Todo: all array lookups in the result prints should have a fallback for undef

use strict;
use Socket;
use Getopt::Long 2.11;
use Digest::MD5 qw(md5);

use Net::PcapUtils;
use NetPacket::Ethernet qw(:strip);
use NetPacket::IP qw(:strip);
use NetPacket::TCP;

use Data::HexDump;

my $VERSION = "0.01";

my $interface = "eth0";
my $port = 49;
my ($help, $version, $unsafe, $debug, $dump_file);

Getopt::Long::config("bundling", "require_order");
die "Could not parse your command line. Try $0 -h\n" unless
    GetOptions("interface|i=s"	=> \$interface,
               "port|p=i"	=> \$port,
               "read|r=s"	=> \$dump_file,
               "debug!"		=> \$debug,
               "d"		=> \$debug,
               "version!"	=> \$version,
               "v"		=> \$version,
               "unsafe!"	=> \$unsafe,
               "U"		=> \$unsafe,
               "help!"		=> \$help,
               "h"		=> \$help);

if ($version) {
    print<<"EOF";
TacSnoop (Ton Utils) $VERSION
EOF
    exit 0;
}
if ($help) {
    require Config;
    $ENV{PATH} .= ":" unless $ENV{PATH} eq "";
    $ENV{PATH} = "$ENV{PATH}$Config::Config{'installscript'}";
    exec("perldoc", "-F", $unsafe ? "-U" : (), $0) || exit 1;
    # make parser happy
    %Config::Config = ();
}

use constant {
    DATA	=> 0,
    TCP_SEQNO	=> 1,
    WANT	=> 2,
    HEADER	=> 3,
    TYPE	=> 4,
    TAC_SEQNO	=> 5,
    FLAGS	=> 6,
    SESSION_ID	=> 7,
    PAD		=> 8,

    AUTHEN	=> 0x01, # Authentication
    AUTHOR	=> 0x02, # Authorization
    ACCT	=> 0x03, # Accounting

    UNENCRYPTED_FLAG	=> 0x01,
    SINGLE_CONNECT_FLAG=> 0x04,

    NOECHO	=> 1,
    ABORT	=> 1.
};

my $data = getkeys("/home/ton/conf/tacacs");
my $key  = $data->{key} || die "No secret";

my %connections;
my @action = (undef, qw(AUTHEN_LOGIN
                        AUTHEN_CHPASS
                        AUTHEN_SENDPASS
                        AUTHEN_SENDAUTH));
my @priv_level = (qw(PRIV_LVL_MIN PRIV_LVL_USER), (undef)x13,
                  "PRIV_LVL_ROOT");
my @authen_type = (undef, qw(AUTHEN_TYPE_ASCII
                             AUTHEN_TYPE_PAP
                             AUTHEN_TYPE_CHAP
                             AUTHEN_TYPE_ARAP
                             AUTHEN_TYPE_MSCHAP));
my @service = (qw(AUTHEN_SVC_NONE
                  AUTHEN_SVC_LOGIN
                  AUTHEN_SVC_ENABLE
                  AUTHEN_SVC_PPP
                  AUTHEN_SVC_ARAP
                  AUTHEN_SVC_PT
                  AUTHEN_SVC_RCMD
                  AUTHEN_SVC_X25
                  AUTHEN_SVC_NASI
                  AUTHEN_SVC_FWPROXY));

my @status = (undef, qw(AUTHEN_STATUS_PASS    
                        AUTHEN_STATUS_FAIL    
                        AUTHEN_STATUS_GETDATA 
                        AUTHEN_STATUS_GETUSER 
                        AUTHEN_STATUS_GETPASS 
                        AUTHEN_STATUS_RESTART 
                        AUTHEN_STATUS_ERROR),
              (undef) x 25, "AUTHEN_STATUS_FOLLOW");

my @method = (qw(AUTHEN_METH_NOT_SET AUTHEN_METH_NONE AUTHEN_METH_KRB5
                 AUTHEN_METH_LINE AUTHEN_METH_ENABLE AUTHEN_METH_LOCAL
                 AUTHEN_METH_TACACSPLUS), undef, qw(AUTHEN_METH_GUEST),
              undef, qw(AUTHEN_METH_RADIUS AUTHEN_METH_KRB4), (undef) x 14,
              qw(AUTHEN_METH_RCMD));

my @author_status = (undef, qw(AUTHOR_STATUS_PASS_ADD AUTHOR_STATUS_PASS_REPL),
                     (undef) x 13, qw(AUTHOR_STATUS_FAIL AUTHOR_STATUS_ERROR),
                     (undef) x 15, qw(AUTHOR_STATUS_FOLLOW));

my @account_status = (undef, qw(ACCT_STATUS_SUCCESS ACCT_STATUS_ERROR),
                      (undef) x 30, qw(ACCT_STATUS_FOLLOW));
my @account_flag_bits = qw(MORE START STOP WATCHDOG);

sub process_pkt {
    my (undef, $hdr, $pkt) = @_;
    my ($sec,$min,$hour) = localtime($hdr->{tv_sec});

    die "Packet truncated ($hdr->{len} to $hdr->{caplen}), use a bigger SNAPLEN\n" if $hdr->{len} > $hdr->{caplen};
    if ($debug) {
        my $dump = HexDump($pkt);
        $dump =~ s/^.*\n.*\n//;
        print STDERR "$dump\n";
    }

    # Decode the packet layers
    my $ip_pkt  = eth_strip($pkt);
    my $ip	= NetPacket::IP->decode($ip_pkt);
    my $tcp	= NetPacket::TCP->decode($ip->{data});

    if ($debug && 0) {
        printf STDERR
            ("%02d:%02d:%02d.%06d %s:%d -> %s:%d, flags=%08x, seq=%d\n",
             $hour, $min, $sec, $hdr->{tv_usec},
             $ip->{src_ip},$tcp->{src_port}, $ip->{dest_ip}, $tcp->{dest_port},
             $tcp->{flags}, $tcp->{seqnum});
        my $dump = HexDump($tcp->{data});
        $dump =~ s/^.*\n.*\n//;
        print STDERR "$dump\n";
    }

    if ($ip->{len} < length($ip_pkt)) {
        my $extra = length($ip_pkt) - $ip->{len};
        die "tcp packet too short" if length($tcp->{data}) < $extra;
        substr($tcp->{data}, -$extra) = "";
    }

    # Find the right tcp stream
    my $cid =
        "$ip->{src_ip}:$tcp->{src_port} $ip->{dest_ip}:$tcp->{dest_port}";
    # Maybe we shoud also decode stream closes...
    $connections{$cid} = ["", $tcp->{seqnum}, 12, 1] if $tcp->{flags} & SYN;
    my $conn = $connections{$cid} || return;
    #if ($tcp->{seqnum} != $conn->[TCP_SEQNO]) {
    #    print STDERR "Out of sequence packet, forget about $cid\n";
    #    delete $connections{$cid};
    #    return;
    #}

    # Append data to stream
    $conn->[DATA]	.= $tcp->{data};
    $conn->[TCP_SEQNO]	+= length($tcp->{data});

    # Check if we have enough to do some decoding
    while (length($conn->[DATA]) >= $conn->[WANT]) {
        my $data = substr($conn->[DATA], 0, $conn->[WANT], "");
        if ($conn->[HEADER]) {
            # Header
            (my $version, @$conn[TYPE, TAC_SEQNO, FLAGS, SESSION_ID, WANT]) =
                unpack("CCCCa4N", $data);
            $conn->[HEADER] =  0;
            $conn->[PAD] = pseudo_pad($data, $conn->[WANT]) unless
                $conn->[FLAGS] & UNENCRYPTED_FLAG;
            my $dump = HexDump($data);
            $dump =~ s/^.*\n.*\n//;
            $dump =~ s/^/  /mg;
            print STDERR $dump;
            next;
        }
        # Body
        $conn->[WANT]   = 12;
        $conn->[HEADER] =  1;

        $data ^= $conn->[PAD] unless
            $conn->[FLAGS] & UNENCRYPTED_FLAG;
        my $dump = HexDump($data);
        $dump =~ s/^.*\n.*\n//;
        $dump =~ s/^/  /mg;

        printf STDERR
            ("%02d:%02d:%02d.%06d %s:%d -> %s:%d (packet %d, type %d, flags 0x%02x)\n",
             $hour, $min, $sec, $hdr->{tv_usec},
             $ip->{src_ip},$tcp->{src_port},$ip->{dest_ip},$tcp->{dest_port},
             @$conn[TAC_SEQNO, TYPE, FLAGS]);
        print STDERR $dump;
        if ($conn->[TYPE] == AUTHEN) {
            if ($conn->[TAC_SEQNO] % 2) {	
                # Client
                if ($conn->[TAC_SEQNO] == 1) {
                    decode_authen_start($conn, $data);
                } else {
                    decode_authen_continue($conn, $data);
                }
            } else {
                decode_authen_reply($conn, $data);	# Server
            }
        } elsif ($conn->[TYPE] == AUTHOR) {
            if ($conn->[TAC_SEQNO] % 2) {
                decode_author_request($conn, $data);	# Client
            } else {
                decode_author_response($conn, $data);	# Server
            }
        } elsif ($conn->[TYPE] == ACCT) {
            if ($conn->[TAC_SEQNO] % 2) {
                decode_account_request($conn, $data);	# Client
            } else {
                decode_account_reply($conn, $data);	# Server
            }
        } else {
            print STDERR "Unknown packet type $conn->[TYPE]\n";
        }
        print STDERR "\n";
    }
}

sub pseudo_pad {
    my ($header, $length) = @_;
    $length > 1 ||
        die "Assertion failed: There are no length $length TACACS+ packets";
    my $prefix = substr($header, 4, 4) . $key .
        substr($header, 0, 1) . substr($header, 2, 1);
    my $pseudo_pad = my $last = md5($prefix);
    $pseudo_pad .= $last = md5($prefix . $last) for 1..($length-1)/16;
    return substr($pseudo_pad, 0, $length);
}

sub decode_authen_start {
    my ($conn, $data) = @_;

    if (length($data) < 8) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my ($action, $priv_level, $authen_type, $service,
        $ulen, $plen, $alen, $dlen) = unpack("CCCCCCCC",$data);
    if (length($data) != $ulen + $plen + $alen + $dlen + 8) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my ($user, $port, $addr, $d) =
        unpack("x8a${ulen}a${plen}a${alen}a${dlen}", $data);
    print STDERR "action\t= $action[$action]\nprivlev= $priv_level[$priv_level]\nauttype= $authen_type[$authen_type]\nservice= $service[$service]\nuser\t= '$user'\nport\t= '$port'\nrem_addr= '$addr'\ndata\t= '$d'\n";
}

sub decode_authen_continue {
    my ($conn, $data) = @_;

    if (length($data) < 5) {
        print STDERR "Bad packet (too short)\n\n";
        return;
    }
    my ($mlen, $dlen) = unpack("nn", $data);
    if (length($data) != $mlen + $dlen + 5) {
        print STDERR "Bad packet (wrong length)\n\n";
        return;
    }

    my ($flags, $msg, $d)=unpack("x4Ca${mlen}a${dlen}", $data);

    my @flag_names;
    if ($flags & ABORT) {
        push @flag_names, qw(ABORT);
        $flags &= ~ABORT;
    }
    push @flag_names, $flags if $flags;
    @flag_names = qw(none) unless @flag_names;

    print STDERR ("flags\t= ", join("|", @flag_names), 
                  "\nusermsg= '$msg'\ndata\t= '$d'\n");
}

sub decode_authen_reply {
    my ($conn, $data) = @_;

    if (length($data) < 6) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my ($status, $flags, $mlen, $dlen) = unpack("CCnn", $data);
    if (length($data) != $mlen+$dlen+6) {
        print STDERR "Bad packet\n\n";
        return;
    }

    my @flag_names;
    if ($flags & NOECHO) {
        push @flag_names, qw(NOECHO);
        $flags &= ~NOECHO;
    }
    push @flag_names, $flags if $flags;
    @flag_names = qw(none) unless @flag_names;

    my ($msg, $d) = unpack("x6a${mlen}a${dlen}", $data);
    print STDERR ("status\t= $status[$status]\nflags\t= ", 
                  join("|", @flag_names), "\nservmsg= '$msg'\ndata\t= '$d'\n");
}

sub decode_author_request {
    my ($conn, $data) = @_;

    if (length($data) < 8) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my ($user_len, $port_len, $addr_len, $nr_args) = 
        unpack('@4CCCC', $data);
    my $l = 8+$nr_args+$user_len+$port_len+$addr_len;
    if (length($data) < $l) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my $read_args = "";
    $read_args .= "a$_", $l+=$_ for unpack("\@8C$nr_args", $data);
    if (length($data) != $l) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my ($a_method, $priv, $a_type,
        $a_service, $user, $port, $addr, @args) = 
            unpack('CCCC@' . (8+$nr_args) . "a${user_len}a${port_len}a${addr_len}$read_args", $data);
    print STDERR "amethod= $method[$a_method]\nprivlvl= $priv_level[$priv]\na_type\t= $authen_type[$a_type]\na_serv\t= $service[$a_service]\nnr_args= $nr_args\nuser\t= '$user'\nport\t= '$port'\nremaddr= '$addr'\n";
    printf STDERR "arg[%2d]= '%s'\n", $_, $args[$_-1] for 1..$nr_args;
}

sub decode_author_response {
    my ($conn, $data) = @_;

    if (length($data) < 6) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my ($nr_args, $msg_len, $data_len) = unpack("xCnn", $data);
    my $l = 6+$nr_args+$msg_len+$data_len;
    if (length($data) < $l) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my $read_args = "";
    $read_args .= "a$_", $l+=$_ for unpack("\@6C$nr_args", $data);
    if (length($data) != $l) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my ($status, $msg, $d, @args) =
        unpack('C@' .(6+$nr_args). "a${msg_len}a${data_len}$read_args", $data);
    print STDERR "status\t= $author_status[$status]\nnr_args= $nr_args\nser mes= '$msg'\ndata\t= '$d'\n";
    printf STDERR "arg[%2d]= '%s'\n", $_, $args[$_-1] for 1..$nr_args;
}

sub decode_account_request {
    my ($conn, $data) = @_;

    if (length($data) < 9) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my ($user_len, $port_len, $addr_len, $nr_args) = 
        unpack('@5CCCC', $data);
    my $l = 9+$nr_args+$user_len+$port_len+$addr_len;
    if (length($data) < $l) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my $read_args = "";
    $read_args .= "a$_", $l+=$_ for unpack("\@9C$nr_args", $data);
    if (length($data) != $l) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my ($flags, $a_method, $priv, $a_type,
        $a_service, $user, $port, $addr, @args) = 
            unpack('CCCCC@' . (9+$nr_args) . "a${user_len}a${port_len}a${addr_len}$read_args", $data);
    my @flag_names;
    for (0..$#account_flag_bits) {
        next unless $flags & 1 << $_;
        push @flag_names, $account_flag_bits[$_];
        $flags &= ~(1 << $_);
    }
    push @flag_names, $flags if $flags;
    @flag_names = qw(none) unless @flag_names;

    print STDERR "flags\t= ", join("|", @flag_names), "\namethod= $method[$a_method]\nprivlvl= $priv_level[$priv]\na_type\t= $authen_type[$a_type]\na_serv\t= $service[$a_service]\nnr_args= $nr_args\nuser\t= '$user'\nport\t= '$port'\nremaddr= '$addr'\n";
    printf STDERR "arg[%2d]= '%s'\n", $_, $args[$_-1] for 1..$nr_args;
}

sub decode_account_reply {
    my ($conn, $data) = @_;

    if (length($data) < 5) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my ($slen, $dlen) = unpack("nn", $data);
    if (length($data) != 5+$slen+$dlen) {
        print STDERR "Bad packet\n\n";
        return;
    }
    my ($status, $msg, $d) = unpack("x4Ca${slen}a${dlen}", $data);
    print STDERR "status\t= $account_status[$status]\nusermsg= '$msg'\ndata\t= '$d'\n";
}

sub getkeys {
    my $file = shift;
    open(my $fh, "<", $file) || die "Could not open $file: $!";
    local $_;
    my %data;
    while (<$fh>) {
        s/\#.*//;
        next unless /\S/;
        s/\s+$//;
        my ($tag, undef, $val) = /^\s*(\w+)\s*=\s*(\"|)([^\"]*)\2$/ or # "
            die "Could not parse line $. of $file\n";
        $data{$tag} = $val;
    }
    return \%data;
}

my $error = Net::PcapUtils::loop
    (\&process_pkt,
     FILTER => "tcp && port $port",
     SNAPLEN => 1600,
     defined($dump_file) ? (SAVEFILE => $dump_file) :
     (DEV => $interface));
die "$error\n" if $error;

__END__

=head1 NAME

TacSnoop - Snoop and decode TACACS+ data streams

=head1 SYNOPSIS

 TacSnoop [-r file] [--read file] [-i interface] [--interface interface] [-p port] [--port port]
 TacSnoop [-v] [--version] [--unsafe] [-U] [-h] [--help]

=head1 DESCRIPTION

....Write some real docs here...

This program will probably need to run as root because it needs priveleges 
to read from an interface in promiscuous mode (except when using the 
L<-r option|"read">).

=head1 OPTIONS

=over

=item -p $port, --port $port

Filter for tcp packets involving port $port. Defaults to 49 (the standard 
TACACS+ port).

=item -i $interface, --interface $interface

Use the given $interface to snoop packets from. Defaults to eth0.

=item X<read>-r $file, --read $file

Don't snoop packets, but read the packets from dumpfile $file instead (for 
example created using the -w option to L<tcpdump|tcpdump(1)>).

=item X<debug>-d, --debug

Print packet dumps.

=item X<help>-h, --help

Show this help.

=item X<unsafe>-U, --unsafe

Allow even root to run the perldoc.
Remember, the reason this is off by default is because it B<IS> unsafe.

=item X<version>-v, --version

Print version info.

=back

=head1 AUTHOR

Ton Hospel, E<lt>TacSnoop@ton.iguana.beE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2004 by Ton Hospel

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.2 or,
at your option, any later version of Perl 5 you may have available.

=cut