#! /usr/bin/perl -w

# This script generates a pcap filter for the query passed in.

use strict;
use English;
use Getopt::Long;

# DNS paramaters are documented here:
# http://www.iana.org/assignments/dns-parameters
# We don't include all of them, because we don't care.

my %dns_class = (
     "in" => 1,
     "ch" => 3, 
    "any" => 255,
);

my %dns_type = (
        "a" => 1,
       "ns" => 2,
    "cname" => 5,
      "soa" => 6,
      "ptr" => 12,
       "mx" => 15,
      "txt" => 16,
     "aaaa" => 28,
    "dname" => 39,
       "ds" => 43,
    "rrsig" => 46,
     "nsec" => 47,
   "dnskey" => 48,
    "nsec3" => 50,
     "ixfr" => 251,
     "axfr" => 252,
      "dlv" => 32769,
);


# Encode the name given into a DNS name
sub name2dns {
    my ($name) = @_;
    if ($name eq '.') {
        return chr(0);
    }
    my $dns = "";
    foreach my $label (split(/\./, $name)) {
        $dns .= chr(length($label)) . $label;
    }
    $dns .= chr(0);
    return $dns;
}


# MAIN PROGRAM BEGINS HERE

# Command-line parsing
my $class = "in";
my $type = "a";

Getopt::Long::Configure("bundling");
my $result = GetOptions("class|c=s" => \$class,
                        "type|t=s"  => \$type);
if ((not $result) or (@ARGV != 1)) {
    print STDERR "Usage: $PROGRAM_NAME [-c class] [-t type] name\n";
    exit(1);
}

$class = lc($class);
if (not exists($dns_class{$class})) {
    print STDERR "Unknown class ", uc($class), "\n";
    exit(1);
}

$type = lc($type);
if (not exists($dns_type{$type})) {
    print STDERR "Unknown type ", uc($type), "\n";
    exit(1);
}

my $name = $ARGV[0];

# With pcap, we can get offsets into the UDP packet.
# UDP headers are fixed-length, so that also gives us offset into the
# the DNS packet.

# UDP header offset & contents:
#    0 source port high-order byte
#    1 source port low-order byte
#    2 destination port high-order byte
#    3 destination port low-order byte
#    4 length high-order byte
#    5 length low-order byte
#    6 checksum high-order byte
#    7 checksum low-order byte

#  DNS header offsets (from UDP start) & contents:
#    8 query ID high-order byte
#    9 query ID low-order byte
#   10 QR bit, OPCODE (4 bits), AA bit, TC bit, RD bit
#   11 RA bit, Z (3 bits), RCODE (4 bits)
#   12 QDCOUNT high-order byte
#   13 QDCOUNT low-order byte
#   14 ANCOUNT high-order byte
#   15 ANCOUNT low-order byte
#   16 NSCOUNT high-order byte
#   17 NSCOUNT low-order byte
#   18 ARCOUNT high-order byte
#   19 ARCOUNT low-order byte

# We could add a few of these into our filter. For instance, we should
# have a QDCOUNT of 1, and ANCOUNT and NSCOUNT should both be 0. But
# we'll leave these out as they are not really necessary.

# Instead, we will focus in on the query, which is the first thing in
# the packet after the DNS header.

# DNS question offsets (from UDP start) & contents for label of length n:
#   20 QNAME byte 0
#      ...
# 20+n 0 (last byte in QNAME is always 0)
# 21+n QTYPE high-order byte
# 22+n QTYPE low-order byte
# 23+n QCLASS high-order byte
# 24+n QCLASS low-order byte

# Since DNS is case-insensitive, we will also need to make sure we look 
# for both uppercase and lowercase of each letter in a label. So, for
# ID.SERVER we need to match [iI][dD].[sS][eE][rR][vV][eE][rR] to be sure
# we catch them all.

my @rules;
my $dnsname = name2dns($name);

# make rules for the encoded name
my $p = 0;
while ($p < length($dnsname)) {
    my $c = lc(substr($dnsname, $p, 1));
    my $rule = sprintf('(udp[%d] == %d)', $p+20, ord($c));
    if (uc($c) ne $c) {
        $rule = "($rule" .  sprintf(' or (udp[%d] == %d))', $p+20, ord(uc($c)));
    }
    push(@rules, $rule);
    $p++;
}

# make rules for the type and class
my $qtype_qclass = pack("nn", $dns_type{$type}, $dns_class{$class});
for (my $i=0; $i<length($qtype_qclass); $i++) {
    my $c = substr($qtype_qclass, $i, 1);
    push(@rules, sprintf('(udp[%d] == %d)', $p+20, ord($c)));
    $p++;
}

my $query_filter = join(" and ", @rules);

print "$query_filter\n";
