#!/usr/bin/perl

# Copyright (c) 2011, Internet Corporation for Assigned Names and Numbers
# 
# Permission to use, copy, modify, and/or distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

### ---------- Description -----------------------------------------------------

# 201103 Dave Knight <dave@knig.ht>
#
# dnspcap
# 
# Generates a libpcap expression to match DNS messages.
# Capture of messages over IPv4/IPv6 UDP/TCP is supported.
# Only TCP packets containing a DNS message are captured, the rest of the
# session is ignored.
#
# Inspired by
# http://www.time-travellers.org/dns-tcpdump/

# version 0.1

### ---------- Modules ---------------------------------------------------------

use strict;
use warnings;
use English qw(-no_match_vars);
use Getopt::Long;
use Net::IP;

### ---------- Config ----------------------------------------------------------

# http://www.iana.org/assignments/dns-parameters

my %dns_class = (
	"IN"		=> 1,
	"CH"		=> 3,
	"HS"		=> 4,
	"NONE"		=> 254,
	"ANY"		=> 255,
);

my %dns_type = (
	"A"		=> 1,
	"NS"		=> 2,
	"MD"		=> 3,
	"MF"		=> 4,
	"CNAME"		=> 5,
	"SOA"		=> 6,
	"MB"		=> 7,
	"MG"		=> 8,
	"MR"		=> 9,
	"NULL"		=> 10,
	"WKS"		=> 11,
	"PTR"		=> 12,
	"HINFO"		=> 13,
	"MINFO"		=> 14,
	"MX"		=> 15,
	"TXT"		=> 16,
	"RP"		=> 17,
	"AFSDB"		=> 18,
	"X25"		=> 19,
	"ISDN"		=> 20,
	"RT"		=> 21,
	"NSAP"		=> 22,
	"NSAP-PTR"	=> 23,
	"SIG"		=> 24,
	"KEY"		=> 25,
	"PX"		=> 26,
	"GPOS"		=> 27,
	"AAAA"		=> 28,
	"LOC"		=> 29,
	"NXT"		=> 30,
	"EID"		=> 31,
	"NIMLOC"	=> 32,
	"SRV"		=> 33,
	"ATMA"		=> 34,
	"NAPTR"		=> 35,
	"KX"		=> 36,
	"CERT"		=> 37,
	"A6"		=> 38,
	"DNAME"		=> 39,
	"SINK"		=> 40,
	"OPT"		=> 41,
	"APL"		=> 42,
	"DS"		=> 43,
	"SSHFP"		=> 44,
	"IPSECKEY"	=> 45,
	"RRSIG"		=> 46,
	"NSEC"		=> 47,
	"DNSKEY"	=> 48,
	"DHCID"		=> 49,
	"NSEC3"		=> 50,
	"NSEC3PARAM"	=> 51,
	"HIP"		=> 55,
	"NINFO"		=> 56,
	"RKEY"		=> 57,
	"TALINK"	=> 58,
	"SPF"		=> 99,
	"UINFO"		=> 100,
	"UID"		=> 101,
	"GID"		=> 102,
	"UNSPEC"	=> 103,
	"TKEY"		=> 249,
	"TSIG"		=> 250,
	"IXFR"		=> 251,
	"AXFR"		=> 252,
	"MAILB"		=> 253,
	"MAILA"		=> 254,
	"ANY"		=> 255,
	"TA"		=> 32768,
	"DLV"		=> 32769,
);

my %offsets = (
	ip		=> 40,
	ip6		=> 60
);

my $max_domain_length	= 255;

my $tcp_offset		= 26;

### ---------- Main ------------------------------------------------------------

my $cli = join ' ', $0, @ARGV;

my ($srcip,$dstip, $srcport,$dstport, $qname,$qtype,$qclass);

GetOptions(
    "help"		=> sub { show_usage() && exit(0); },
    "src-ip=s"		=> \$srcip,
    "dst-ip=s"		=> \$dstip,
    "src-port=s"	=> \$srcport,
    "dst-port=s"	=> \$dstport,
    "qname=s"		=> \$qname,
    "qtype=s"		=> \$qtype,
    "qclass=s"		=> \$qclass,
    "max-length=i"	=> \$max_domain_length,
);

show_usage() && die unless $qname;

# Qname/Qtype/Qclass

if( $qname !~ /\.$/ && ( $qtype || $qclass ) ) {
    die "$0: can only specify qname and qclass or qtype when qname is fqdn\n";
}

# Host and Port

if($srcip && $dstip) {
    my $src = new Net::IP($srcip) || die Net::IP::Error();
    my $srcv = $src->version;
    my $dst = new Net::IP($dstip) || die Net::IP::Error();
    my $dstv = $dst->version;
    die "$0: src and dst ip are different versions\n" unless($srcv == $dstv);
}

print "#\n"
    . "# $cli\n"
    . "#\n"
    . "\n";

print $srcip ? "src host $srcip" : "",
      $srcip && $dstip ? " and " : "",
      $dstip ? "dst host $dstip" : "",
      $srcip || $dstip ? " and " : "",
      $srcport ? "src port $srcport" : "",
      $srcport && $dstport ? " and " : "",
      $dstport ? "dst port $dstport" : "",
      $srcport || $dstport ? " and " : "",
      "\n";

# DNS Message

print "(\n";

foreach my $ipv ('ip', 'ip6') {

    my $offset_limit = $offsets{$ipv}
                     + $tcp_offset
                     + $max_domain_length
                     - length($qname);

    my $offset = $offsets{$ipv};

    my @terms;
    push @terms, $qname ? encode_qname($qname,$ipv,$offset) : ();
    push @terms, $qtype ? encode_qtype($qtype,$ipv,$offset) : ();
    push @terms, $qclass ? encode_qclass($qclass,$ipv,$offset) : ();

    for (; $offset < $offset_limit; $offset++) {

        my @ts = @terms;
        print "  (\n";
        my $o = $offset;
        printf "        %3s[%3d] %s\n", $ipv, $o, shift @ts;
        foreach my $t (@ts) {
            $o++;
            printf "    and %3s[%3d] %s\n", $ipv, $o, $t;
        }
        print "  )\n";
        print "  or\n" unless($offset == ($offset_limit -1) && $ipv eq "ip6");
    }
}

print ")\n";

### ---------- Subroutines -----------------------------------------------------

sub show_usage {
    print "\n"
        . "usage: dnspcap\n"
        . "\n"
        . "  --help            show this usage message\n"
        . "\n"
        . "  --src-ip addr     match source ip address\n"
        . "  --dst-ip addr     match destination ip address\n"
        . "  --src-port port   match source port\n"
        . "  --dst-port port   match destination port\n"
        . "\n"
        . "  --qname string    match QNAME string\n"
        . "  --qtype QTYPE     match QTYPE\n"
        . "  --qclass QCLASS   match QCLASS\n"
        . "\n"
        . "  --max-length int  max domain length\n"
        . "\n";
    1;
}

sub encode_qname {
    my $qname = shift;
    my @terms;
    foreach my $label (split /\./, uc $qname) {
        if (length $qname > 1) {
            push @terms, sprintf "       == %3d  #    %02x  # Label length", 
              length $label, length $label;
            foreach my $char (split //, $label) {
                my $a = ord $char;
                if($a >= 54 && $a <= 90) {
                    push @terms, sprintf "| 0x20 == %3d  # %02x|%02x  # %s",
                      $a + 32,
                      $a, $a + 32,
                      uc($char) . "|" . lc($char);
                }
                else {
                    push @terms, sprintf "       == %3d  #    %02x  # %s",
                      $a,$a,$char;
                }
            }
        }
    }
    push @terms, sprintf "       == %3d  #    %02x  # Null label",
      0, 0 if($qname =~ /\.$/);
    return @terms;
}

sub encode_qclass {
    my $qclass = shift;
    my @terms;
    foreach my $byte (split(//, pack("n", $dns_class{uc $qclass}))) {
        push @terms, sprintf "       == %3d  #    %02x  # Class %s",
          ord $byte, ord $byte, uc $qclass;
    }
    return @terms;
}

sub encode_qtype {
    my $qtype = shift;
    my @terms;
    foreach my $byte (split(//, pack("n", $dns_type{uc $qtype}))) {
        push @terms, sprintf "       == %3d  #    %02x  # Type %s",
          ord $byte, ord $byte, uc $qtype;
    }
    return @terms;
}

__END__

### ---------- Notes -----------------------------------------------------------

