dnsrend-0.08/000755 001751 000000 00000000000 11465643344 013341 5ustar00jameswheel000000 000000 dnsrend-0.08/README000644 001751 001751 00000007610 11401744000 014213 0ustar00jamesjames000000 000000 rend: v. tr. To tear or split apart or into pieces violently. $Id: README,v 1.16 2010/06/03 15:19:28 james Exp $ Faced with broken DNS software spitting out junk DNS packets there is only one satisfactory way to understand the problem: get a pencil and pad, tcpdump and start reading hex. I've dealt with DNS servers that put looping compression pointers in replies or pointers to the wrong part of the packet, load balancing switches that set various header bit-flags seemingly at random, and a DNS server that adds resource records to a reply without announcing them in the header, and plenty others. dnsrend is some perl that will rend a DNS packet, in place of my pencil and pad. It reads libpcap packet capture data or tcpdump's hex output and gives a laborious dissection of the packet. It supports IPv4 and IPv6 transport. You will need the Net::Pcap module and version 0.04 or newer of Net::Pcap::Reassemble to read libpcap data. Net::Pcap::Reassemble is required to reassemble IP fragments so fragment support is available only when reading libpcap data. It is not an introductory tool. It is for those of us who already understand how a packet should be composed and want to examine byte-by-byte a packet we suspect is broken. USAGE Options: -a filename Read tcpdump ASCII/hex output. Use `-' for stdin. -D Data is a DNS message without any L2/3 header. Give dnsrend the output of tcpdump -n -s 4096 -w - udp port 53 Why 4kB? Because with the onset of EDNS and OPT records the historic 512 byte limit for UDP DNS packets can, with the mutual consent of the communicating parties, be ignored. Beware that your tcpdump may buffer its output so dnsrend may have to wait for more than one packet to arrive before tcpdump will supply it the contents of its output buffer. Some platforms have a -U tcpdump option to make the pcap output unbuffered. Check your tcpdump man page. Examples: tcpdump -n -s 4096 -w - udp port 53 | dnsrend | less (libpcap) tcpdump -xnl -s 4096 udp port 53 | dnsrend -a - | less or tcpdump -n -s 4096 -w dns.packets udp port 53 then dnsrend dns.packets | less Read the output carefully. In an effort to make your life a little easier, the output tries to use uniform keywords to help you pick out messages of significant interest. dnsrend will say ``BAD'' for errors, and ``ODD'' for unusual observations. Because it's intended to continue parsing DNS messages even in the face of total junk dnsrend can generate lots of warnings from perl (about undefined values, out of bounds reads, etc). These are harmless but clutter up the display. Redirect stderr to null to eliminate them. dnsrend has rudimentary support for parsing TCP DNS messages. The limitation is that the complete DNS message must be contained in one TCP datagram. I haven't yet found a TCP stream reassembler that I'm happy with. PROBLEM REPORTING If you want to report a problem, submit a patch or a comment please email . Please include as much information about your problem as you can. Some things which are especially useful are - what version of perl you are using (``perl -v'') - what version of tcpdump you are using Remember -- I can't see your computer and I didn't see what you tried to do. You'll have to tell me! There are two fine essays on the topics of bug reporting and requesting help available on the web. I strongly suggest you invest a little time to read them. They're entertaining _and_ educational! How to Report Bugs Effectively, by Simon Tatham: http://www.chiark.greenend.org.uk/~sgtatham/bugs.html How To Ask Questions The Smart Way, by Eric Steven Raymond: http://www.tuxedo.org/~esr/faqs/smart-questions.html THANKS A thank you to people who've helped out; Mark Campbell, DCU School of Computer Applications and Philip Reynolds, RFC Networks (www.rfc-networks.ie) for giving me large samples of captured DNS packets. $Id: README,v 1.16 2010/06/03 15:19:28 james Exp $ dnsrend-0.08/dnsrend000755 001751 001751 00000073003 11465642303 014732 0ustar00jamesjames000000 000000 #!/usr/bin/perl -Tw use strict; use warnings; use Getopt::Std; use Net::Pcap::Reassemble 0.04; # # Copyright (c) 2003-2010 James Raftery . All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # Please submit bug reports, patches and comments to the author. # # $Id: dnsrend,v 1.61 2010/11/08 00:30:59 james Exp $ # # Feed me the output of # tcpdump -n -s 4096 -w - udp port 53 # on stdin and pipe my stdout to a pager or into a file. # Or from a saved file: # tcpdump -n -s 4096 -w foo.cap udp port 53 # dnsrend foo.cap # # Alternatively, use the -a option and feed me tcpdump's hex output # on stdin: # tcpdump -xnl -s 4096 udp port 53 | dnsrend -a - # # See http://romana.now.ie/#dnsrend and the included README file for # more information. You will need the Net::Pcap module and version 0.04 or # newer of Net::Pcap::Reassemble to read libpcap data. # my %typesbyval = ( 0 => 'SIGZERO', # RFC2931 consider this a pseudo type 1 => 'A', # RFC 1035, Section 3.4.1 2 => 'NS', # RFC 1035, Section 3.3.11 3 => 'MD', # RFC 1035, Section 3.3.4 (obsolete) 4 => 'MF', # RFC 1035, Section 3.3.5 (obsolete) 5 => 'CNAME', # RFC 1035, Section 3.3.1 6 => 'SOA', # RFC 1035, Section 3.3.13 7 => 'MB', # RFC 1035, Section 3.3.3 8 => 'MG', # RFC 1035, Section 3.3.6 9 => 'MR', # RFC 1035, Section 3.3.8 10 => 'NULL', # RFC 1035, Section 3.3.10 11 => 'WKS', # RFC 1035, Section 3.4.2 (deprecated) 12 => 'PTR', # RFC 1035, Section 3.3.12 13 => 'HINFO', # RFC 1035, Section 3.3.2 14 => 'MINFO', # RFC 1035, Section 3.3.7 15 => 'MX', # RFC 1035, Section 3.3.9 16 => 'TXT', # RFC 1035, Section 3.3.14 17 => 'RP', # RFC 1183, Section 2.2 18 => 'AFSDB', # RFC 1183, Section 1 19 => 'X25', # RFC 1183, Section 3.1 20 => 'ISDN', # RFC 1183, Section 3.2 21 => 'RT', # RFC 1183, Section 3.3 22 => 'NSAP', # RFC 1706, Section 5 23 => 'NSAP_PTR', # RFC 1348 (obsolete) 24 => 'SIG', # RFC 2535, Section 4.1 25 => 'KEY', # RFC 2535, Section 3.1 26 => 'PX', # RFC 2163, 27 => 'GPOS', # RFC 1712 (obsolete) 28 => 'AAAA', # RFC 1886, Section 2.1 29 => 'LOC', # RFC 1876 30 => 'NXT', # RFC 2535, Section 5.2 31 => 'EID', # draft-ietf-nimrod-dns-xx.txt 32 => 'NIMLOC', # draft-ietf-nimrod-dns-xx.txt 33 => 'SRV', # RFC 2052 34 => 'ATMA', # ??? 35 => 'NAPTR', # RFC 2168/3403 36 => 'KX', # RFC 2230 37 => 'CERT', # RFC 2538 38 => 'A6', # RFC 2874 39 => 'DNAME', # RFC 2672 40 => 'SINK', # ??? 41 => 'OPT', # RFC 2671 42 => 'APL', # RFC 3123 43 => 'DS', # RFC 3658/4034 44 => 'SSHFP', # RFC 4255 45 => 'IPSECKEY', # RFC 4025 46 => 'RRSIG', # RFC 3755/4034 47 => 'NSEC', # RFC 3755/4034 48 => 'DNSKEY', # RFC 3755/4034 49 => 'DHCID', # RFC 4701 50 => 'NSEC3', # RFC 5155 51 => 'NSEC3PARAM', # RFC 5155 55 => 'HIP', # RFC 5205 56 => 'NINFO', # ? 57 => 'RKEY', # ? 99 => 'SPF', # RFC 4408 100 => 'UINFO', # non-standard 101 => 'UID', # non-standard 102 => 'GID', # non-standard 103 => 'UNSPEC', # non-standard 249 => 'TKEY', # RFC 2930 250 => 'TSIG', # RFC 2931 251 => 'IXFR', # RFC 1995 252 => 'AXFR', # RFC 1035 253 => 'MAILB', # RFC 1035 (MB, MG, MR) 254 => 'MAILA', # RFC 1035 (obsolete - see MX) 255 => 'ANY', # RFC 1035 32768 => 'TA', # ? 32769 => 'DLV', # RFC 4431 ); my %classesbyval = ( 0 => 'RESERVED - BAD', 1 => 'IN', # RFC 1035 3 => 'CH - ODD', # RFC 1035 4 => 'HS - ODD', # RFC 1035 254 => 'NONE - BAD', # RFC 2136 255 => 'ANY', # RFC 1035 65535 => 'RESERVED - BAD', ); my %opcodesbyval = ( 0 => 'QUERY', # RFC 1035 1 => 'IQUERY - ODD', # RFC 1035 2 => 'STATUS - ODD', # RFC 1035 4 => 'NOTIFY', # RFC 1996 5 => 'UPDATE', # RFC 2136 ); my %rcodesbyval = ( 0 => 'NOERROR', # RFC 1035 1 => 'FORMERR', # RFC 1035 2 => 'SERVFAIL', # RFC 1035 3 => 'NXDOMAIN', # RFC 1035 4 => 'NOTIMP', # RFC 1035 5 => 'REFUSED', # RFC 1035 6 => 'YXDOMAIN', # RFC 2136 7 => 'YXRRSET', # RFC 2136 8 => 'NXRRSET', # RFC 2136 9 => 'NOTAUTH', # RFC 2136 10 => 'NOTZONE', # RFC 2136 16 => 'BADVERS/SIG', # RFC 2671/2845 17 => 'BADKEY', # RFC 2845 18 => 'BADTIME', # RFC 2845 19 => 'BADMODE', # RFC 2930 20 => 'BADNAME', # RFC 2930 21 => 'BADALG', # RFC 2930 22 => 'BADTRUNC', # RFC 4635 ); sub rend (); sub rend_callback ($$$); sub strip_ip_udp_header (); sub line (); sub readoctet ($;$); sub peekoctet ($); sub readdec ($); sub readhex ($); sub readraw ($); sub readname ($); sub readcharstr (); sub readrr (); sub readquestion (); sub readheader (); sub readArdata ($); sub readAAAArdata ($); sub readSOArdata ($); sub readMINFOrdata ($$); sub readSRVrdata ($); sub readMXrdata ($$); sub readTXTrdata ($); sub readOPTrdata ($); sub readLOCrdata ($); sub latlon2dms ($$); sub readSSHFPrdata ($); sub readNAPTRrdata ($); sub readDNSKEYrdata ($); sub readNSECrdata ($); sub readRRSIGrdata ($); sub readDSrdata ($); use vars qw($in $rcode $base $opt_a $opt_D); getopts('a:D'); if ($opt_a) { # # tcpdump ASCII/hex input # # suck in the hex data $in = ''; open(F, $opt_a) or die; while () { chomp; s/\s+//g; s/^0x[a-f0-9]+://; # timestamp: '14:45:46.822304 ' or blank line if (/^\s*$/ or /^\d{1,2}:\d{2}:\d{2}\.\d+/) { rend() if ($in = pack('H*', $in)); } else { die "bad data $_" unless /^[a-f0-9]*$/i; $in .= $_; } } close(F); rend() if ($in = pack('H*', $in)); } else { # # libpcap input. # my $err; my $pcap_t = Net::Pcap::open_offline(($ARGV[0] ? $ARGV[0] : '-'), \$err); if (!defined($pcap_t)) { die "Net::Pcap::open_offline returned error: $err\n"; } #$Net::Pcap::Reassemble::debug = 1; $Net::Pcap::Reassemble::stripl2 = 1; Net::Pcap::Reassemble::loop($pcap_t, -1, \&rend_callback, ''); } exit 0; # # END # #### sub rend () { my ($j, $pktlen, $qdcount, $ancount, $nscount, $arcount); print '=== Start packet: ', qq$Revision: 1.61 $, '='x39, "\n"; # # A `-D' means a raw DNS message -- no header to remove. # If -D is absent try to remove the L3/L4 headers. Skip this # packet if header removal fails. # goto END_PKT if (!$opt_D and !strip_ip_udp_header()); $base = 0; $pktlen = length($in); # Print DNS packet print "\nAnalyzing DNS packet ($pktlen octets):\n"; print unpack('H*', $in)."\n"; print "Packet is TOO SHORT - BAD\n" if ($pktlen < 12); goto END_PKT if ($pktlen == 0); line(); print "Reading Header section\n"; ($qdcount, $ancount, $nscount, $arcount) = readheader(); print "Header invalid size ($base) - BAD\n" if ($base != 12); print "End of Header section\n"; line(); print "Reading Question section (QDCOUNT is $qdcount)\n"; while ($qdcount) { last if ($base==$pktlen); readquestion(); $qdcount--; } print "Read fewer RRs than QDCOUNT, $qdcount absent - BAD\n" if $qdcount; print "End of Question section\n"; line(); print "Reading Answer section (ANCOUNT is $ancount)\n"; while ($ancount) { last if ($base==$pktlen); readrr(); $ancount--; } print "Read fewer RRs than ANCOUNT, $ancount absent - BAD\n" if $ancount; print "End of Answer section\n"; line(); print "Reading Authority section (NSCOUNT is $nscount)\n"; while ($nscount) { last if ($base==$pktlen); readrr(); $nscount--; } print "Read fewer RRs than NSCOUNT, $nscount absent - BAD\n" if $nscount; print "End of Authority section\n"; line(); print "Reading Additional section (ARCOUNT is $arcount)\n"; while ($arcount) { last if ($base==$pktlen); readrr(); $arcount--; } print "Read fewer RRs than ARCOUNT, $arcount absent - BAD\n" if $arcount; print "End of Additional section\n"; # # Check for trailing data # while ($pktlen > $base) { line(); $j = length($in) - $base; print "Spare data - BAD ($j octets):\n0x".peekoctet($j)."\n\n"; # Min. RR size is name:1 type:2 class:2 ttl:4 rdlen:2 rdata:0 # = 11 octets if ($j >= 11) { print 'Attempting to readrr() - ' . "this may barf spectacularly\n"; readrr(); } else { print "Not enough data to readrr()\n"; ## should we try anyway? readoctet($j); # throw away } } END_PKT: $in = ''; print '=== End packet ', '='x57, "\n"; return; } sub rend_callback ($$$) { # $in is the pkt (undef, undef, $in) = @_; rend() if $in; return; } sub strip_ip_udp_header () { # # Remove the IP and UDP headers. # my ($ipversion, $hdrlen, $l4, $discard); $ipversion = unpack('C', $in) >> 4; return 0 if !defined($ipversion); if ($ipversion == 4) { # IHL is length of IP header in 32 bit words (4 bytes). # Usually 5 words (160bits). # XXX we can't deal with options. $hdrlen = (unpack('C', $in) & 0x0f) * 4; $l4 = unpack('C', substr($in, 9, 1)); } elsif ($ipversion == 6) { # IPv6 header is 40 bytes in size $hdrlen = 40; # XXX what about extension headers? $l4 = unpack('C', substr($in, 6, 1)); } else { # Ignore this packet if something other than IPv4 or IPv6 print "Unsupported IP version: $ipversion\n"; return 0; } if ($l4 == 17) { # Add UDP header (8 bytes) to IHL $hdrlen += 8; print 'Discarding IPv'.$ipversion."/UDP header ($hdrlen octets):\n"; } elsif ($l4 == 6) { $hdrlen += ((unpack('x'x($hdrlen+12).'C', $in) >> 4) * 4); print 'Discarding IPv'.$ipversion."/TCP header ($hdrlen octets):\n"; } else { print 'Unsupported IPv'.$ipversion." payload: $l4\n"; return 0; } ($discard, $in) = unpack("a$hdrlen a*", $in); return 0 if !$discard or (length($discard) != $hdrlen); print unpack('H*', $discard), "\n"; return 0 if !$in; if ($l4 == 6) { # XXX should check that the message length matches the # packet data print "Discarding DNS/TCP message length:\n"; ($discard, $in) = unpack('a2 a*', $in); return 0 if !$discard or (length($discard) != 2) or !$in; print unpack('H*', $discard), "\n"; } return 1; } sub line () { print '='x72, "\n"; return; } sub readoctet ($;$) { my $num_octets = shift; my $what = shift || 'read'; my ($len, $template, $data, $hex, $dec); $base += $num_octets if ($num_octets < 0); # rewind return ('','','') if ($num_octets <= 0); if ($base >= length($in)) { print "BAD $what aborted, base ($base) >= pkt length ...\n"; return ('','',''); } elsif ($base+$num_octets > length($in)) { print "BAD $what about to happen ...\n"; } $data = substr($in, $base, $num_octets); if (defined $data) { $len = length($data); $hex = unpack('H*',$data); if ($num_octets == 1) { $template = 'C' } elsif ($num_octets == 2) { $template = 'n' } elsif ($num_octets == 4) { $template = 'N' } else { # dunno how to deal with it. oh well. $template = 'a'.$num_octets; } $dec = unpack($template, $data); print "$what $len octets". ($what eq 'read' ? " (0x$hex)" : ''). ($len != $num_octets ? " (BAD: $num_octets requested)" : ''). " starting at octet $base\n"; $base += $len if $what eq 'read'; } else { print "BAD: $what $num_octets octets starting at octet ". "$base returned no data\n"; } return ($data, $hex, $dec); } sub peekoctet ($) { return (readoctet(shift, 'peek'))[1]; } sub readdec ($) { return (readoctet(shift))[2]; } sub readhex ($) { return (readoctet(shift))[1]; } sub readraw ($) { return (readoctet(shift))[0]; } sub readname ($) { my ($hex, $dec, $label, $name, $i, $brakes, $savebase); print "Starting to read a domain name\n"; # Set to true if we're reading RDATA from an RFC1035 RR. Only # these RRs can use compression safely. An RFC1035 compliant # server implementation has no special knowledge of later RRs. # To it SRV RDATA, for example, is merely a bit stream. If the # domain-name portion of SRV RDATA is compressed (thank you BIND # 8!) an old caching resolver will not know to uncompress it and # will instead pass the raw RDATA back to the client/stub # resolver. Stub resolvers have no way to deal with compression. # The SRV RDATA will be garbage to it. We want to flag # inappropriate compression use. Compression is always permitted # in RR owner domain-names. my $safecompression = shift; # two octet mask # isolate compression pointer my $ptrmask = 0x3fff; # 0011 1111 1111 1111 # single octet mask # label type my $lblmask = 0xc0; # 1100 0000 $name = ''; for ($brakes = 0; $brakes < 256; $brakes++) { (undef,$hex,$dec) = readoctet(1); if ($dec == 0) { # empty label, end of name print "Zero octet, end of name, append root label\n"; $name .= '.'; last; } my $labeltype = ($dec & $lblmask) >> 6; my $len = 0; if ($labeltype == 3) { # compression pointer print "Next label starts a pointer\n"; if (!$safecompression) { print 'BAD - UNSAFE USE OF COMPRESSION! Only'. 'RFC1035 RDATA domain-names may be '. "compressed\n"; } readoctet(-1); (undef,$hex,$dec) = readoctet(2); print "Pointer is 0x$hex, points to octet " . ($dec & $ptrmask) . "\n"; $savebase = $base unless $savebase; $base = $dec & $ptrmask; # XXX Should really abort this print "Compression pointer points past end of data - BAD\n" if ($base > length($in)); print "Forward compression pointer - BAD\n" if ($base > $savebase); print "Compression pointer points here - BAD\n" if ($base == $savebase); print "Compression pointer points to message header - BAD\n" if ($base < 12); next; } elsif ($labeltype == 0) { # normal $len = $dec; print "Length of next label is 0x$hex ". "(decimal $len) octets\n"; } elsif ($labeltype == 1) { # EDNS extended # Extended labels have been obsoleted print 'Label is an EDNS extended label - BAD: ' . ($dec & ~$lblmask) . (($dec & ~$lblmask) == 63 ? 'RESERVED LABEL TYPE' : '') . "\n"; next; } else { print "BAD label type: $labeltype\n"; last; } print "BAD label length: $len\n" if ($len > 63 or $len < 1); $label = ''; for ($i = 1; $i <= $len; $i++) { $_ = chr(readdec(1)); print "Octet $i/$len is: $_\n"; $label .= $_; } $name .= ($name ? '.' : '') . $label; print "Label is '$label'\nName so far is: $name\n"; if (length($name) > 255) { print 'BAD - name has invalid length ('.length($name). "). Forging on regardless ...\n"; } } $base = $savebase if $savebase; if ($brakes >= 255) { print "BAD - Hit the brakes in readname() to escape a loop.\n". " Since we've stopped mid-data all bets are off.\n"; } print "This name is '$name'\n"; return $name; } sub readcharstr () { my ($len, $str, $hex); (undef,$hex,$len) = readoctet(1); print "Length of next string is 0x$hex (decimal $len) octets\n"; $str = '"' . unpack('A*', readraw($len)) . '"'; print "String is $str\n"; # $len+1 to account for the `length' octet return($len+1, $str); } sub readrr () { my ($name, $type, $class, $ttl, $work, $len, $expected); my ($hex, $dec); print "Starting to read an RR\n"; $name = readname(1); print "NAME is: $name\n"; (undef,$hex,$dec) = readoctet(2); $type = defined $typesbyval{$dec} ? $typesbyval{$dec} : 'INVALID - BAD'; print "TYPE is 0x$hex ($type / decimal $dec)\n"; if ($type eq 'OPT') { # # The OPT psuedo-RR needs special handling # XXX only one OPT allowed per message. # # two octet mask my $okmask = 0x8000; # 1000 0000 0000 0000 my $zmask = 0x4000; # 0100 0000 0000 0000 print "OPT owner name is '$name' - BAD\n" if ($name ne '.'); (undef,$hex,$class) = readoctet(2); print "UDP payload size is 0x$hex (decimal $class) octets\n"; (undef,$hex,$ttl) = readoctet(1); print "Extended Rcode is 0x$hex (decimal $ttl)\n"; # XXX - fixme if ($ttl > 0) { $rcode = unpack('n', pack('C*', $ttl, $rcode)); $hex = unpack('H*',$rcode); print "Full Rcode is 0x$hex (decimal $rcode / " . (defined $rcodesbyval{$rcode} ? $rcodesbyval{$rcode} : 'INVALID - BAD') . ")\n"; } (undef,$hex,$dec) = readoctet(1); print "EDNS version is 0x$hex (decimal $dec)\n"; (undef,$hex,$dec) = readoctet(2); print "EDNS flags are 0x$hex (decimal $dec)\n"; print ' DO is ', $dec & $okmask ? 'set' : 'unset', "\n"; while ($zmask) { print ' Z is ', $dec & $zmask ? 'set - BAD' : 'unset', "\n"; $zmask >>= 1; } } else { # # Normal (non-OPT) RR processing ... # (undef,$hex,$dec) = readoctet(2); $class = defined $classesbyval{$dec} ? $classesbyval{$dec} : 'INVALID - BAD'; print "CLASS is 0x$hex ($class / decimal $dec)\n"; (undef,$hex,$ttl) = readoctet(4); print "TTL is 0x$hex (decimal $ttl)\n"; } # RDLENGTH can be zero when opcode is UPDATE (undef,$hex,$len) = readoctet(2); $expected = $base + $len; print "RDLENGTH is 0x$hex (decimal $len) octets\n"; print "BAD RDLENGTH: $len\n" if ($len < 1 and $type ne 'NULL' and $type ne 'OPT'); $work = ''; TYPE: { last TYPE if (!$len); print 'RDATA is 0x' . peekoctet($len) . "\n"; # Stupid fucking BIND compresses other types; RP, SRV # Need to uncompress them # Need to check for the proper CLASS too # # Should add: # CERT, NSEC3, NSEC3PARAM # if ($type eq 'OPT') { readOPTrdata($len); last TYPE; } if ($type eq 'A') { $work = readArdata($len); last TYPE; } if ($type eq 'SOA') { $work = readSOArdata($len); last TYPE; } if ($type eq 'SRV') { $work = readSRVrdata($len); last TYPE; } if ($type eq 'AAAA') { $work = readAAAArdata($len); last TYPE; } if ($type eq 'LOC') { $work = readLOCrdata($len); last TYPE; } if ($type eq 'SSHFP') { $work = readSSHFPrdata($len); last TYPE; } if ($type eq 'NAPTR') { $work = readNAPTRrdata($len); last TYPE; } if ($type eq 'MINFO') { $work = readMINFOrdata($len, 1); last TYPE; } if ($type eq 'RP') { $work = readMINFOrdata($len, 0); last TYPE; } if ($type eq 'NS' or $type eq 'PTR' or $type eq 'CNAME' or $type eq 'MB' or $type eq 'MG' or $type eq 'MR') { $work = readname(1); last TYPE; } if ($type eq 'DNAME') { $work = readname(0); last TYPE; } if ($type eq 'MX') { $work = readMXrdata($len, 1); last TYPE; } if ($type eq 'RT' or $type eq 'AFSDB') { $work = readMXrdata($len, 0); last TYPE; } if ($type eq 'TXT' or $type eq 'X25' or $type eq 'HINFO' or $type eq 'ISDN' or $type eq 'SPF') { $work = readTXTrdata($len); last TYPE; } if ($type eq 'NSEC' or $type eq 'NXT') { $work = readNSECrdata($len); last TYPE; } if ($type eq 'DNSKEY' or $type eq 'KEY') { $work = readDNSKEYrdata($len);last TYPE; } if ($type eq 'RRSIG' or $type eq 'SIG') { $work = readRRSIGrdata($len); last TYPE; } if ($type eq 'DS' or $type eq 'DLV') { $work = readDSrdata($len); last TYPE; } # Default: just spit the hex data $work = '0x' . readhex($len); } # End: TYPE print "BAD - RDLENGTH ($len) mismatch. " . "(Expected to be at octet $expected, now at ". "octet $base)\n" if $base != $expected; print "\n$name $ttl\t$class\t$type\t$work\n\n" unless ($type eq 'OPT'); } sub readquestion () { my ($name, $type, $class, $hex, $dec); print "Starting to read a question\n"; $name = readname(1); print "QNAME is: $name\n"; (undef,$hex,$dec) = readoctet(2); $type = defined $typesbyval{$dec} ? $typesbyval{$dec} : 'INVALID - BAD'; print "QTYPE is 0x$hex ($type / decimal $dec)\n"; (undef,$hex,$dec) = readoctet(2); $class = defined $classesbyval{$dec} ? $classesbyval{$dec} : 'INVALID - BAD'; print "QCLASS is 0x$hex ($class / decimal $dec)\n"; print "\n$name\t$class\t$type\n\n"; } sub readheader () { # two octet masks my $qrmask = 0x8000; # 1000 0000 0000 0000 my $opmask = 0x7800; # 0111 1000 0000 0000 my $aamask = 0x0400; # 0000 0100 0000 0000 my $tcmask = 0x0200; # 0000 0010 0000 0000 my $rdmask = 0x0100; # 0000 0001 0000 0000 my $ramask = 0x0080; # 0000 0000 1000 0000 my $zmask = 0x0040; # 0000 0000 0100 0000 my $admask = 0x0020; # 0000 0000 0010 0000 my $cdmask = 0x0010; # 0000 0000 0001 0000 my $rmask = 0x000f; # 0000 0000 0000 1111 my ($hex, $dec, $opcode, $is_query, $is_update, $qdcount, $ancount, $nscount, $arcount); print "Starting to read the header\n"; (undef,$hex,$dec) = readoctet(2); print "ID is 0x$hex (decimal $dec)\n"; (undef,$hex,$dec) = readoctet(2); print "Flags are 0x$hex (decimal $dec)\n"; print ' QR is ', $dec & $qrmask ? "set - response\n" : "unset - query\n"; # Unknown opcodes are bad (duh!), and ones other than QUERY, # NOTIFY and UPDATE to be considered unusual. $opcode = ($dec & $opmask) >> 11; print " Opcode is $opcode (", defined $opcodesbyval{$opcode} ? $opcodesbyval{$opcode} : 'INVALID - BAD', ")\n"; $is_query = $opcode==0 && !($dec & $qrmask) ? 1 : 0; $is_update = $opcode==5 ? 1 : 0; # Give the status of the bit flags ... print ' AA is ', $dec & $aamask ? 'set' : 'unset', "\n"; print "AA set in query - BAD\n" if ($dec & $aamask) and $is_query; print ' TC is ', $dec & $tcmask ? 'set' : 'unset', "\n"; print "TC set in query - BAD\n" if ($dec & $tcmask) and $is_query; print ' RD is ', $dec & $rdmask ? 'set' : 'unset', "\n"; print ' RA is ', $dec & $ramask ? 'set' : 'unset', "\n"; print "RA set in query - BAD\n" if ($dec & $ramask) and $is_query; print ' Z is ', $dec & $zmask ? 'set - BAD' : 'unset', "\n"; print ' AD is ', $dec & $admask ? 'set' : 'unset', "\n"; print "AD set in query - BAD\n" if ($dec & $admask) and $is_query; print ' CD is ', $dec & $cdmask ? 'set' : 'unset', "\n"; $rcode = $dec & $rmask; print " Rcode is $rcode (".(defined $rcodesbyval{$rcode} ? $rcodesbyval{$rcode} : 'INVALID - BAD').")\n"; (undef,$hex,$qdcount) = readoctet(2); print 'Number of question RRs (', $is_update ? 'ZOCOUNT' : 'QDCOUNT', ") is 0x$hex (decimal $qdcount)\n"; print "QDCOUNT is > 1 - ODD\n" if $qdcount > 1; (undef,$hex,$ancount) = readoctet(2); print 'Number of answer RRs (', $is_update ? 'PRCOUNT' : 'ANCOUNT', ") is 0x$hex (decimal $ancount)\n"; (undef,$hex,$nscount) = readoctet(2); print 'Number of authority RRs (', $is_update ? 'UPCOUNT' : 'NSCOUNT', ") is 0x$hex (decimal $nscount)\n"; print "AA is set but NSCOUNT==0 - ODD\n" if ($dec & $aamask) and !$nscount and !($dec & $tcmask); (undef,$hex,$arcount) = readoctet(2); # what the heck was so wrong with "ARCOUNT" ? print 'Number of additional RRs (', $is_update ? 'ADCOUNT' : 'ARCOUNT', ") is 0x$hex (decimal $arcount)\n"; return($qdcount, $ancount, $nscount, $arcount); } sub readArdata ($) { my $rdlength = shift or die; print "Starting to read A RR RDATA\n"; print "BAD - RDLENGTH is not 4!\n" if $rdlength != 4; return join('.', unpack('C*', readraw($rdlength))); } sub readAAAArdata ($) { my $rdlength = shift or die; print "Starting to read AAAA RR RDATA\n"; print "BAD - RDLENGTH is not 16!\n" if $rdlength != 16; # add colons my $hex = join(':', unpack('a4'x8, readhex($rdlength))); # 2001:04f8:0000:0002:0000:0000:0000:0013 # drop leading zeros $hex =~ s/:0+/:0/g; $hex =~ s/:0([^:])/:$1/g; # 2001:4f8:0:2:0:0:0:13 ## condense zeros? # 2001:4f8:0:2::13 return $hex; } sub readSOArdata ($) { my $rdlength = shift or die; print "Starting to read SOA RR RDATA\n"; # mname, rname, serial, refresh, retry, minimum/neg cache ttl, expire return join(' ', readname(1), readname(1), readdec(4), readdec(4), readdec(4), readdec(4), readdec(4)); } sub readMINFOrdata ($$) { my ($rdlength, $sc) = @_ or die; # $sc is 'safe for compression' flag print "Starting to read MINFO/RP RR RDATA\n"; # rmailbx, emailbx return join(' ', readname($sc), readname($sc)); } sub readSRVrdata ($) { my $rdlength = shift or die; print "Starting to read SRV RR RDATA\n"; # priority, weight, port, target return join(' ', readdec(2), readdec(2), readdec(2), readname(0)); } sub readMXrdata ($$) { my ($rdlength, $sc) = @_ or die; # $sc is 'safe for compression' flag print "Starting to read MX/RT/AFSDB RR RDATA\n"; # priority, name return join(' ', readdec(2), readname($sc)); } sub readTXTrdata ($) { my $rdlength = shift or die; my (@str, $len, $s); my $i = 0; print "Starting to read TXT/X25/HINFO/ISDN/SPF RR RDATA\n"; while ($i < $rdlength) { ($len, $s) = readcharstr(); push(@str, $s); $i += $len; } return join(' ', @str); } sub readOPTrdata ($) { my $rdlength = shift or die; my ($hex, $dec); my $i = 0; print "Starting to read OPT RR RDATA\n"; while ($i < $rdlength) { (undef,$hex,$dec) = readoctet(2); $i += 2; print "Option code is 0x$hex (decimal $dec)\n"; (undef,$hex,$dec) = readoctet(2); $i += 2; print "Option length is 0x$hex (decimal $dec) octets\n"; print 'Option data is 0x' . readhex($dec) . "\n" if $dec; $i += $dec; } return; } sub readLOCrdata ($) { my $rdlength = shift or die; my ($work, $size, $vp, $hp, $lat, $long, $alt, $hex, $dec); # Reference altitude in centimeters (see RFC 1876). my $reference_alt = 100000 * 100; print "Starting to read LOC RR RDATA\n"; print "BAD - RDLENGTH is not 16!\n" if $rdlength != 16; # LOC RDATA is nasty to convert into human-readable # zone data format. (undef,$hex,$dec) = readoctet(1); print "VERSION is ODD, should be zero (is 0x$hex)\n" if ($dec != 0); (undef,$hex,$dec) = readoctet(1); $size = $dec >> 4; print "SIZE base is too large ($size) - BAD\n" if $size > 9;# keep going? $work = $dec & 0x0f; print "SIZE exponent is too large ($work) - BAD\n" if $work > 9; print "SIZE base is zero but exponent is non-zero - BAD\n" if $size == 0 and $work != 0; $size = sprintf('%.2fm', ($size * 10**$work)/100); (undef,$hex,$dec) = readoctet(1); $hp = $dec >> 4; print "HORIZ PRE base is too large ($hp) - BAD\n" if $hp > 9;# keep going? $work = $dec & 0x0f; print "HORIZ PRE exponent is too large ($work) - BAD\n" if $work > 9; print "HORIZ PRE base is zero but exponent is non-zero - BAD\n" if $hp == 0 and $work != 0; $hp = sprintf('%.2fm', ($hp * 10**$work)/100); (undef,$hex,$dec) = readoctet(1); $vp = $dec >> 4; print "VERT PRE base is too large ($vp) - BAD\n" if $vp > 9; ## keep going? $work = $dec & 0x0f; print "VERT PRE exponent is too large ($work) - BAD\n" if $work > 9; print "VERT PRE base is zero but exponent is non-zero - BAD\n" if $vp == 0 and $work != 0; $vp = sprintf('%.2fm', ($vp * 10**$work)/100); $lat = latlon2dms(readdec(4), 'NS'); $long = latlon2dms(readdec(4), 'EW'); $alt = sprintf('%.2fm', (readdec(4) - $reference_alt)/100); return "$lat $long $alt $size $hp $vp"; } sub latlon2dms ($$) { # # This sub is from Net::DNS, which is Copyright (c) 1997-2002 # Michael Fuhr. All rights reserved. # my ($rawmsec, $hems) = @_ or die; # Reference lat/lon (see RFC 1876). my $reference_latlon = 2**31; # Conversions to/from thousandths of a degree. my $conv_sec = 1000; my $conv_min = 60 * $conv_sec; my $conv_deg = 60 * $conv_min; # Tried to use modulus here, but Perl dumped core if # the value was >= 2**31. my ($abs, $deg, $min, $sec, $msec, $hem); $abs = abs($rawmsec - $reference_latlon); $deg = int($abs / $conv_deg); $abs -= $deg * $conv_deg; $min = int($abs / $conv_min); $abs -= $min * $conv_min; $sec = int($abs / $conv_sec); $abs -= $sec * $conv_sec; $msec = $abs; $hem = substr($hems, ($rawmsec >= $reference_latlon ? 0 : 1), 1); return sprintf('%d %02d %02d.%03d %s', $deg, $min, $sec, $msec, $hem); } sub readSSHFPrdata ($) { my $rdlength = shift or die; print "Starting to read SSHFP RR RDATA\n"; return join(' ', readdec(1), readdec(1), readhex($rdlength-2)); } sub readNAPTRrdata ($) { my $rdlength = shift or die; print "Starting to read NAPTR RR RDATA\n"; return join(' ', readdec(2), readdec(2), (readcharstr)[1], (readcharstr)[1], (readcharstr)[1], readname(0)); } sub readDNSKEYrdata ($) { my $rdlength = shift or die; my ($key, $hex); print "Starting to read DNSKEY/KEY RR RDATA\n"; # flags, protocol, algorithm my $r = join(' ', readdec(2), readdec(1), readdec(1)); ($key,$hex,undef) = readoctet($rdlength-4); # public key eval { use MIME::Base64; }; if ($@) { warn $@; $key = "0x$hex"; } else { $key = encode_base64($key, ' '); } return "$r $key"; } sub readNSECrdata ($) { my $rdlength = shift or die; my ($nextname, $bitmap_list, $bitmap, $bitmap_offset, $bitmap_len, $i, $j, $k, $window_number, $rrtypes); print "Starting to read NSEC/NXT RR RDATA\n"; $bitmap_offset = $base; $nextname = readname(1); $bitmap_offset = $base - $bitmap_offset; print "Bit map offset is $bitmap_offset\n"; $bitmap_list = readraw($rdlength-$bitmap_offset); # XXX this sucks. Use vec? $i = 0; while ($i < $rdlength-$bitmap_offset) { $window_number = unpack('C', substr($bitmap_list, $i, 1)); $window_number <<= 8+$window_number; print "window number: $window_number\n"; $i++; $bitmap_len = unpack('C', substr($bitmap_list, $i, 1)); print "bitmap len: $bitmap_len\n"; $i++; $bitmap = unpack('B*', substr($bitmap_list, $i, $bitmap_len)); print "bitmap: $bitmap\n"; $i += $bitmap_len; for ($j = 0; $j <= $bitmap_len*8; $j++) { next if !substr($bitmap,$j,1); $k = $j+$window_number; $rrtypes .= ' ' . (exists $typesbyval{$k} ? $typesbyval{$k} : $k); } } return "${nextname}${rrtypes}"; } sub readRRSIGrdata ($) { my $rdlength = shift or die; my ($sig, $hex); print "Starting to read RRSIG/SIG RR RDATA\n"; eval { use POSIX qw(strftime); }; my $fmt = '%Y%m%d%H%M%S'; # XXX - fixme - what about unknown types # type covered, algorithm, labels, original ttl, sig expiration, # sig inception, key tag (18 octets to here) my $r = join(' ', $typesbyval{readdec(2)}, readdec(1), readdec(1), readdec(4), strftime($fmt, gmtime(readdec(4))), strftime($fmt, gmtime(readdec(4))), readdec(2)); my $offset = $base; $r .= ' ' . readname(0); # signer's name ($sig,$hex,undef) = readoctet($rdlength-18-($base-$offset)); # sig eval { use MIME::Base64; }; if ($@) { warn $@; $sig = "0x$hex"; } else { $sig = encode_base64($sig, ' '); } return "$r $sig"; } sub readDSrdata ($) { my $rdlength = shift or die; print "Starting to read DS/DLV RR RDATA\n"; # key tag, algorithm, digest type, digest return join(' ', readdec(2), readdec(1), readdec(1), readhex($rdlength-4)); } # # EOF #