--- /dev/null
+#! /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 protocl 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' => \×tamp,
+ '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_summnary.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<protocl> 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 modifiy 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 LISENCE 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
git.samba.org / samba.git / commitdiff