path: root/script/traffic_summary.pl

#! /usr/bin/perl
#
# Summarise tshark pdml output into a form suitable for the load test tool
#
# Copyright (C) Catalyst.Net Ltd 2017
#
# Catalyst.Net's contribution was written by Gary Lockyer
# <gary@catalyst.net.nz>.
#
# 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 3 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, see <http://www.gnu.org/licenses/>.
#

use warnings;
use strict;

use Getopt::Long;
use Pod::Usage;

BEGIN {
    unless (eval "require XML::Twig") {
        warn "traffic_summary requires the perl module XML::Twig\n" .
             "on Ubuntu/Debian releases run\n".
             "  sudo apt install libxml-twig-perl \n".
             "or install from CPAN\n".
             "\nThe reported error was:\n$@";
        exit(1);
    }
}


my %ip_map;              # Map of IP address to sequence number
my $ip_sequence = 0;     # count of unique IP addresses seen


my $timestamp;           # Packet timestamp
my $stream;              # Wireshark stream number
my $ip_proto;            # IP protocol (IANA protocol number)
my $source;              # source IP address
my $dest;                # destination address
my $proto;               # application protocol name
my $description;         # protocol specific description
my %proto_data;          # protocol specific data captured for the current packet
my $malformed_packet;    # Indicates the current packet has errors
my $ldap_filter;         # cleaned ldap filter
my $ldap_attributes;     # attributes requested in an ldap query



# Dispatch table mapping the wireshark variables of interest to the
# functions responsible for processing them
my %field_dispatch_table = (
    'timestamp'                       => \&timestamp,
    'ip.src'                          => \&ip_src,
    'ipv6.src'                        => \&ip_src,
    'ip.dst'                          => \&ip_dst,
    'ipv6.dst'                        => \&ip_dst,
    'ip.proto'                        => \&ip_proto,
    'udp.stream'                      => \&stream,
    'tcp.stream'                      => \&stream,
    'dns.flags.opcode'                => \&field_data,
    'dns.flags.response'              => \&field_data,
    'netlogon.opnum'                  => \&field_data,
    'kerberos.msg_type'               => \&field_data,
    'smb.cmd'                         => \&field_data,
    'smb2.cmd'                        => \&field_data,
    'ldap.protocolOp'                 => \&field_data,
    'gss-api.OID'                     => \&field_data,
    'ldap.gssapi_encrypted_payload'   => \&field_data,
    'ldap.baseObject'                 => \&field_data,
    'ldap.scope'                      => \&field_data,
    'ldap.AttributeDescription'       => \&ldap_attribute,
    'ldap.modification_element'       => \&ldap_add_modify,
    'ldap.AttributeList_item_element' => \&ldap_add_modify,
    'ldap.operation'                  => \&field_data,
    'ldap.authentication'             => \&field_data,
    'lsarpc.opnum'                    => \&field_data,
    'samr.opnum'                      => \&field_data,
    'dcerpc.pkt_type'                 => \&field_data,
    'epm.opnum'                       => \&field_data,
    'dnsserver.opnum'                 => \&field_data,
    'drsuapi.opnum'                   => \&field_data,
    'browser.command'                 => \&field_data,
    'smb_netlogon.command'            => \&field_data,
    'srvsvc.opnum'                    => \&field_data,
    'nbns.flags.opcode'               => \&field_data,
    'nbns.flags.response'             => \&field_data,
    '_ws.expert.message'              => \&field_data,
);

# Dispatch table mapping protocols to the routine responsible for formatting
# their output.  Protocols not in this table are ignored.
#
my %proto_dispatch_table = (
    'dns'          => sub { return format_opcode( 'dns.flags.response')},
    'rpc_netlogon' => sub { return format_opcode( 'netlogon.opnum')},
    'kerberos'     => \&format_kerberos,
    'smb'          => sub { return format_opcode( 'smb.cmd')},
    'smb2'         => sub { return format_opcode( 'smb2.cmd')},
    'ldap'         => \&format_ldap,
    'cldap'        => \&format_ldap,
    'lsarpc'       => sub { return format_opcode( 'lsarpc.opnum')},
    'samr'         => sub { return format_opcode( 'samr.opnum')},
    'dcerpc'       => sub { return format_opcode( 'dcerpc.pkt_type')},
    'epm'          => sub { return format_opcode( 'epm.opnum')},
    'dnsserver'    => sub { return format_opcode( 'dnsserver.opnum')},
    'drsuapi'      => sub { return format_opcode( 'drsuapi.opnum')},
    'browser'      => sub { return format_opcode( 'browser.command')},
    'smb_netlogon' => sub { return format_opcode( 'smb_netlogon.command')},
    'srvsvc'       => sub { return format_opcode( 'srvsvc.opnum')},
    'nbns'         => sub { return format_opcode( 'nbns.flags.response')},
);

# XPath entry to extract the kerberos cname
my $kerberos_cname_path =
      'packet/proto/field[@name = "kerberos.as_req_element"]'
    . '/field[@name = "kerberos.req_body_element"]'
    . '/field[@name = "kerberos.cname_element"]'
    . '/field[@name = "kerberos.name_string"]'
    . '/field[@name = "kerberos.KerberosString"]';

# XPath entry to extract the ldap filter
my $ldap_filter_path =
      'field[@name = "ldap.searchRequest_element"]/field';


# Create an XML Twig parser and register the event handlers.
#
my $t = XML::Twig->new(
    start_tag_handlers => {
        'packet'       => \&packet_start,
    },
    twig_handlers => {
         'packet'              => \&packet,
         'proto'               => \&protocol,
         'field'               => \&field,
         $kerberos_cname_path  => \&kerberos_cname,
         $ldap_filter_path     => \&ldap_filter,
    },
);

#------------------------------------------------------------------------------
# Main loop
#
#------------------------------------------------------------------------------
my $help = 0;
GetOptions( 'help|h' => \$help) or pod2usage(2);
pod2usage(1) if $help;

if (@ARGV) {
    foreach my $file (@ARGV) {
        eval {
            $t->parsefile( $file);
        };
        if ($@) {
            print STDERR "Unable to process $file, ".
                         "did you run tshark with the -T pdml option?";
        }
    }
} else {
    pod2usage(1) if -t STDIN;
    eval {
        $t->parse( \*STDIN);
    };
    if ($@) {
        print STDERR "Unable to process input, ".
                     "are you running tshark with the -T pdml option?";
    }
}


#------------------------------------------------------------------------------
# New packet detected reset the globals
#------------------------------------------------------------------------------
sub packet_start
{
    my ($t, $packet) = @_;
    $timestamp           = "";
    $stream              = "";
    $ip_proto            = "";
    $source              = "";
    $dest                = "";
    $description         = undef;
    %proto_data          = ();
    $malformed_packet    = undef;
    $ldap_filter         = "";
    $ldap_attributes     = "";
}

#------------------------------------------------------------------------------
# Complete packet element parsed from the XML feed
# output the protocol summary if required
#------------------------------------------------------------------------------
sub packet
{
    my ($t, $packet) = @_;

    my $data;
    if (exists $proto_dispatch_table{$proto}) {
        if ($malformed_packet) {
            $data = "\t\t** Malformed Packet ** " . ($proto_data{'_ws.expert.message.show'} || '');
        } else {
            my $rsub = $proto_dispatch_table{$proto};
            $data = &$rsub();
        }
        print "$timestamp\t$ip_proto\t$stream\t$source\t$dest\t$proto\t$data\n";
    }
    $t->purge;
}

#------------------------------------------------------------------------------
# Complete protocol element parsed from the XML input
# Update the protocol name
#------------------------------------------------------------------------------
sub protocol
{
    my ($t, $protocol) = @_;
    if ($protocol->{att}->{showname}) {
    }
    # Tag a packet as malformed if the protocol is _ws.malformed
    # and the hide attribute is not 'yes'
    if ($protocol->{att}->{name} eq '_ws.malformed'
        && !($protocol->{att}->{hide} && $protocol->{att}->{hide} eq 'yes')
    ) {
        $malformed_packet = 1;
    }
    # Don't set the protocol name if it's a wireshark malformed
    # protocol entry, or the packet was truncated during capture
    my $p = $protocol->{att}->{name};
    if ($p ne '_ws.malformed' && $p ne '_ws.short')  {
        $proto = $p;
    }
}


#------------------------------------------------------------------------------
# Complete field element parsed, extract any data of interest
#------------------------------------------------------------------------------
sub field
{
    my ($t, $field) = @_;
    my $name = $field->{att}->{name};

    # Only process the field if it has a corresponding entry in
    # %field_dispatch_table
    if (exists $field_dispatch_table{$name}) {
        my $rsub = $field_dispatch_table{$name};
        &$rsub( $field);
    }
}

#------------------------------------------------------------------------------
# Process a timestamp field element
#------------------------------------------------------------------------------
sub timestamp
{
    my ($field) = @_;
    $timestamp = $field->{att}->{value};
}

#------------------------------------------------------------------------------
# Process a wireshark stream element, used to group a sequence of requests
# and responses between two IP addresses
#------------------------------------------------------------------------------
sub stream
{
    my ($field) = @_;
    $stream = $field->{att}->{show};
}

#------------------------------------------------------------------------------
# Process a source ip address field, mapping the IP address to it's
# corresponding sequence number.
#------------------------------------------------------------------------------
sub ip_src
{
    my ($field) = @_;
    $source = map_ip( $field);
}

#------------------------------------------------------------------------------
# Process a destination ip address field, mapping the IP address to it's
# corresponding sequence number.
#------------------------------------------------------------------------------
sub ip_dst
{
    my ($field) = @_;
    $dest = map_ip( $field);
}

#------------------------------------------------------------------------------
# Process an ip protocol element, extracting IANA protocol number
#------------------------------------------------------------------------------
sub ip_proto
{
    my ($field) = @_;
    $ip_proto = $field->{att}->{value};
}



#------------------------------------------------------------------------------
# Extract an ldap attribute and append it to ldap_attributes
#------------------------------------------------------------------------------
sub ldap_attribute
{
    my ($field) = @_;
    my $attribute =  $field->{att}->{show};

    if (defined $attribute) {
        $ldap_attributes .= "," if $ldap_attributes;
        $ldap_attributes .= $attribute;
    }
}

#------------------------------------------------------------------------------
# Process a field element, extract the value, show and showname attributes
# and store them in the %proto_data hash.
#
#------------------------------------------------------------------------------
sub field_data
{
    my ($field) = @_;
    my $name  = $field->{att}->{name};
    $proto_data{$name.'.value'}    = $field->{att}->{value};
    $proto_data{$name.'.show'}     = $field->{att}->{show};
    $proto_data{$name.'.showname'} = $field->{att}->{showname};
}

#------------------------------------------------------------------------------
# Process a kerberos cname element, if the cname ends with a $ it's a machine
# name. Otherwise it's a user name.
#
#------------------------------------------------------------------------------
sub kerberos_cname
{
    my ($t, $field) = @_;
    my $cname =  $field->{att}->{show};
    my  $type;
    if( $cname =~ /\$$/) {
        $type = 'machine';
     } else {
        $type = 'user';
     }
     $proto_data{'kerberos.cname.type'} = $type;
}


#------------------------------------------------------------------------------
# Process an ldap filter, remove the values but keep the attribute names
#------------------------------------------------------------------------------
sub ldap_filter
{
    my ($t, $field) = @_;
    if ( $field->{att}->{show} && $field->{att}->{show} =~ /^Filter:/) {
        my $filter = $field->{att}->{show};

        # extract and save the objectClass to keep the value
        my @object_classes;
        while ( $filter =~ m/\((objectClass=.*?)\)/g) {
           push  @object_classes, $1;
        }

        # extract and save objectCategory and the top level value
        my @object_categories;
        while ( $filter =~ m/(\(objectCategory=.*?,|\(objectCategory=.*?\))/g
        ) {
            push @object_categories, $1;
        }

        # Remove all the values from the attributes
        # Input
        #     Filter: (nCName=DC=DomainDnsZones,DC=sub1,DC=ad,DC=rh,DC=at,DC=net)
        # Output
        #     (nCName)
        $filter =~ s/^Filter:\s*//; # Remove the 'Filter: ' prefix
        $filter =~ s/=.*?\)/\)/g;   # Remove from the = to the first )

        # Now restore the parts of objectClass and objectCategory that are being
        # retained
        #
        for my $cat (@object_categories) {
            $filter =~ s/\(objectCategory\)/$cat/;
        }

        for my $class (@object_classes) {
            $filter =~ s/\(objectClass\)/($class)/;
        }

        $ldap_filter = $filter;
    } else {
        # Ok not an ldap filter so call the default field handler
        field( $t, $field);
    }
}


#------------------------------------------------------------------------------
# Extract the attributes from ldap modification and add requests
#------------------------------------------------------------------------------
sub ldap_add_modify
{
    my ($field) = @_;
    my $type      = $field->first_child('field[@name="ldap.type"]');
    my $attribute = $type->{att}->{show} if $type;
    if (defined $attribute) {
        $ldap_attributes .= "," if $ldap_attributes;
        $ldap_attributes .= $attribute;
    }
}
#------------------------------------------------------------------------------
# Map an IP address to a unique sequence number. Assigning it a sequence number
# if one has not already been assigned.
#
#------------------------------------------------------------------------------
sub map_ip
{
    my ($field) = @_;
    my $ip = $field->{att}->{show};
    if ( !exists( $ip_map{$ip})) {
        $ip_sequence++;
        $ip_map{$ip} = $ip_sequence;
    }
    return $ip_map{$ip};
}

#------------------------------------------------------------------------------
# Format a protocol operation code for output.
#
#------------------------------------------------------------------------------
sub format_opcode
{
    my ($name) = @_;
    my $operation   = $proto_data{$name.'.show'};
    my $description = $proto_data{$name.'.showname'} || '';

    # Strip off the common prefix text, and the trailing (n).
    # This tidies up most but not all descriptions.
    $description =~ s/^[^:]*?: ?//     if $description;
    $description =~ s/^Message is a // if $description;
    $description =~ s/\(\d+\)\s*$//    if $description;
    $description =~ s/\s*$//           if $description;

    return "$operation\t$description";
}

#------------------------------------------------------------------------------
# Format ldap protocol details for output
#------------------------------------------------------------------------------
sub format_ldap
{
    my ($name) = @_;
    if (   exists( $proto_data{'ldap.protocolOp.show'})
        || exists( $proto_data{'gss-api.OID.show'})
    ) {
        my $operation   = $proto_data{'ldap.protocolOp.show'};
        my $description = $proto_data{'ldap.protocolOp.showname'} || '';
        my $oid         = $proto_data{'gss-api.OID.show'}         || '';
        my $base_object = $proto_data{'ldap.baseObject.show'}     || '';
        my $scope       = $proto_data{'ldap.scope.show'}          || '';

        # Now extract operation specific data
        my $extra;
        my $extra_desc;
        $operation = '' if !defined $operation;
        if ($operation eq 6) {
            # Modify operation
            $extra         = $proto_data{'ldap.operation.show'};
            $extra_desc    = $proto_data{'ldap.operation.showname'};
        } elsif ($operation eq 0) {
            # Bind operation
            $extra         = $proto_data{'ldap.authentication.show'};
            $extra_desc    = $proto_data{'ldap.authentication.showname'};
        }
        $extra      = '' if !defined $extra;
        $extra_desc = '' if !defined $extra_desc;


        # strip the values out of the base object
        if ($base_object) {
            $base_object =~ s/^<//;       # leading '<' if present
            $base_object =~ s/>$//;       # trailing '>' if present
            $base_object =~ s/=.*?,/,/g;  # from = up to the next comma
            $base_object =~ s/=.*?$//;    # from = up to the end of string
        }

        # strip off the leading prefix on the extra_description
        # and the trailing (n);
        $extra_desc =~ s/^[^:]*?: ?//  if $extra_desc;
        $extra_desc =~ s/\(\d+\)\s*$// if $extra_desc;
        $extra_desc =~ s/\s*$//        if $extra_desc;

        # strip off the common prefix on the description
        # and the trailing (n);
        $description =~ s/^[^:]*?: ?//  if $description;
        $description =~ s/\(\d+\)\s*$// if $description;
        $description =~ s/\s*$//        if $description;

        return "$operation\t$description\t$scope\t$base_object"
              ."\t$ldap_filter\t$ldap_attributes\t$extra\t$extra_desc\t$oid";
    } else {
        return "\t*** Unknown ***";
    }
}

#------------------------------------------------------------------------------
# Format kerberos protocol details for output.
#------------------------------------------------------------------------------
sub format_kerberos
{
    my $msg_type    = $proto_data{'kerberos.msg_type.show'} || '';
    my $cname_type  = $proto_data{'kerberos.cname.type'} || '';
    my $description = $proto_data{'kerberos.msg_type.showname'} || '';

    # Tidy up the description
    $description =~ s/^[^:]*?: ?//  if $description;
    $description =~ s/\(\d+\)\s*$// if $description;
    $description =~ s/\s*$//        if $description;
    return "$msg_type\t$description\t$cname_type";
}

=pod

=head1 NAME

traffic_summary.pl - summarise tshark pdml output

=head1 USAGE

B<traffic_summary.pl> [FILE...]

Summarise samba network traffic from tshark pdml output.  Produces a tsv
delimited summary of samba activity.

To process unencrypted traffic

 tshark -r capture.file -T pdml | traffic_summary.pl

To process encrypted kerberos traffic

 tshark -r capture.file -K krb5.keytab -o kerberos.decrypt:true -T pdml | traffic_summary.pl

To display more detailed documentation, including details of the output format

 perldoc traffic_summary.pl

 NOTE: tshark pdml output is very verbose, so it's better to pipe the tshark
       output directly to traffic_summary, rather than generating
       intermediate pdml format files.

=head1 OPTIONS
 B<--help> Display usage message and exit.

=head1 DESCRIPTION

Summarises tshark pdml output into a format suitable for load analysis
and input into load generation tools.

It reads the pdml input from stdin or the list of files passed on the command line.


=head2 Output format
    The output is tab delimited fields and one line per summarised packet.

=head3 Fields
     B<timestamp>                Packet timestamp
     B<IP protocol>              The IANA protocol number
     B<Wireshark Stream Number>  Calculated by wireshark groups related requests and responses
     B<Source IP>                The unique sequence number for the source IP address
     B<Destination IP>           The unique sequence number for the destination IP address
     B<protocol>                 The protocol name
     B<opcode>                   The protocol operation code
     B<Description>              The protocol or operation description
     B<extra>                    Extra protocol specific data, may be more than one field


=head2 IP address mapping
    Rather than capturing and printing the IP addresses. Each unique IP address
    seen is assigned a sequence number. So the first IP address seen will be 1,
    the second 2 ...

=head2 Packets collected
    Packets containing the following protocol records are summarised:
      dns
      rpc_netlogon
      kerberos
      smb
      smb2
      ldap
      cldap
      lsarpc
      samr
      dcerpc
      epm
      dnsserver
      drsuapi
      browser
      smb_netlogon
      srvsvc
      nbns

   Any other packets are ignored.

   In addition to the standard elements extra data is returned for the following
   protocol record.

=head3 kerberos
     cname_type  machine cname ends with a $
                 user    cname does not end with a $

=head3 ldap

     scope                Query Scope
                            0 - Base
                            1 - One level
                            2 - sub tree
     base_object          ldap base object
     ldap_filter          the ldap filter, attribute names are retained but the values
                          are removed.
     ldap_attributes      ldap attributes, only the names are retained any values are
                          discarded, with the following two exceptions
                            objectClass    all the attribute values are retained
                            objectCategory the top level value is retained
                                           i.e. everything from the = to the first ,

=head3 ldap modifiyRequest
     In addition to the standard ldap fields the modification type is also captured

     modify_operator      for modifyRequests this contains the modify operation
                            0 - add
                            1 - delete
                            2 - replace
     modify_description   a description of the operation if available

=head3 modify bindRequest
     In addition to the standard ldap fields details of the authentication
     type are captured

     authentication type  0 - Simple
                          3 - SASL
     description          Description of the authentication mechanism
     oid                  GSS-API OID's
                            1.2.840.113554.1.2.2   - Kerberos v5
                            1.2.840.48018.1.2.2    - Kerberos V5
                               (incorrect, used by old Windows versions)
                            1.3.6.1.5.5.2          - SPNEGO
                            1.3.6.1.5.2.5          - IAKERB
                            1.3.6.1.4.1.311.2.2.10 - NTLM SSP
                            1.3.6.1.5.5.14         - SCRAM-SHA-1
                            1.3.6.1.5.5.18         - SCRAM-SHA-256
                            1.3.6.1.5.5.15.1.1.*   - GSS-EAP
                            1.3.6.1.5.2.7          - PKU2U
                            1.3.6.1.5.5.1.1        - SPKM-1
                            1.3.6.1.5.5.1.2        - SPKM-2
                            1.3.6.1.5.5.1.3        - SPKM-3
                            1.3.6.1.5.5.9          - LIPKEY
                            1.2.752.43.14.2        - NETLOGON

=head1 DEPENDENCIES
tshark
XML::Twig         For Ubuntu libxml-twig-perl, or from CPAN
use Getopt::Long
use Pod::Usage


=head1 Diagnostics

=head2 ** Unknown **
Unable to determine the operation being performed, for ldap it typically
indicates a kerberos encrypted operation.

=head2 ** Malformed Packet **
tshark indicated that the packet was malformed, for ldap it usually indicates TLS
encrypted traffic.

=head1 LICENSE AND COPYRIGHT

 Copyright (C) Catalyst.Net Ltd 2017

 Catalyst.Net's contribution was written by Gary Lockyer
 <gary@catalyst.net.nz>.

 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 3 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, see <http://www.gnu.org/licenses/>.


=cut