#!/usr/bin/perl

use strict;
use Data::Dumper;

sub build_rr     ($);
sub build_name   ($);
sub decode_flags ($);
sub encode_flags ($);

$|=1;

use IO::Socket::INET;

my $sock = IO::Socket::INET->new(
	LocalPort => 53,
	Proto     => 'udp',
);

if ( ! $sock ) {
	die "can't open socket: $!";
}

while (my $s = $sock->recv(my $datagram,1500,my $flags)) {
	my($port, $binary_ipaddr) = sockaddr_in($sock->peername);
	my $hishost = gethostbyaddr($binary_ipaddr, AF_INET);
	print "Client: $hishost \n";

	my $query = {};

	print unpack("H*",$datagram),"\n";
	(       $query->{id     },
		my $_flags,
		$query->{qdcount},
		$query->{ancount},
		$query->{nscount},
		$query->{arcount},
	) = unpack("
		n
		n 
		n
		n
		n
		n
		",$datagram);
	print "N: ",pack("n",$_flags)," $_flags\n";
	$query = { %$query, %{ decode_flags $_flags } };
	print "Query: ",Dumper($query);

	print "D $datagram\n";

	my $qname = substr($datagram,6*2);
	print "qname: $qname\n";

	my @QName = ();

	my $i = 73;  # chars f. IPv6 PTR
	QNAME: { 
		do {
			my $qnamepart = unpack("C/a",$qname);
			if ( $qnamepart eq "" ) {
				last QNAME;
			}
			push @QName, $qnamepart;
			print "QName: @QName\n";
			$qname = substr($qname,length($qnamepart)+1);
		} while ($i--); 
	}
	print "qname: $qname\n";
	$query->{qname} = [ @QName ];
	( undef,$query->{qtype},$query->{qclass} ) =
		unpack("C n n",$qname);
	print "qtype:  ",$query->{qtype},"\n";
	print "qclass: ",$query->{qclass},"\n";

	my $ans = undef;
	if ( 
		$query->{qr     } == 0   and
		$query->{opcode } == 0   and 
		$query->{aa     } == 0   and
		$query->{tc     } == 0   and
		$query->{rd     } == 1   and
		$query->{ra     } == 0   and
		$query->{z      } == 0   and
		$query->{rcode  } == 0   and
		$query->{qdcount}  > 0   and
		$query->{ancount} == 0   and
		$query->{nscount} == 0   and
		$query->{arcount} == 0   and
		$query->{qtype  } == 1   and 
		$query->{qclass } == 1   
		) {

		print "ANSWER HERE\n";

		my $rr = build_rr {
			name     => $query->{qname}      , # requested name
			type     => 1                    , # A / host address
			class    => 1                    , # IN / internet
			ttl      => 60                   , # 60 seconds
			rdlength => 4                    , # 4 bytes
			rdata    => pack ("C C C C", 212,9,165,35 ),
			};

		$ans = build_packet({
			id	=> $query->{id     },
			qr      => 1                , # response
			opcode  => $query->{opcode },
			aa      => 1                , # authoritative answer
			tc      => 0                , # no truncation
			rd      => 0                , # 
			ra      => 0                , # no recursion available
			z       => 0                , # always 0
			rcode   => 0                , # no error
			qdcount => 1                , # 1 query
			ancount => 1                , # 1 answer RR
			nscount => 0                , # 0 authoritative NS RR
			arcount => 0                , # additional RR
			rr      => $rr              , 
			#qtype   => $query->{qtype  },
			#qclass  => $query->{qclass },
			});
	} else { # error condition

		print "ERROR HERE\n";

		$ans = build_packet({
			id	=> $query->{id     },
			qr      => 1                , # response
			opcode  => $query->{opcode },
			aa      => 1                , # authoritative answer
			tc      => 0                , # no truncation
			rd      => 0                , # 
			ra      => $query->{ra     }, # no recursion available
			z       => 0                , # always 0
			rcode   => 4                , # not implemented
			qdcount => 0                ,
			ancount => 0                ,
			nscount => 0                ,
			arcount => 0                ,
			rr      => ""               ,
			qtype   => $query->{qtype  },
			qclass  => $query->{qclass },
			});
	}
	$sock->send($ans);
}

sub build_packet ($) {
	my ($p) = @_;
	my $_flags = 0;
	print Dumper($p);

	$_flags = encode_flags $p;
		
	# $_flags |= $p->{rcode } & 0x000f; $_flags <<= 3;
	# $_flags |= $p->{z     } & 0x0007; $_flags <<= 1;
	# $_flags |= $p->{ra    } & 0x0001; $_flags <<= 1;
	# $_flags |= $p->{rd    } & 0x0001; $_flags <<= 1;
	# $_flags |= $p->{tc    } & 0x0001; $_flags <<= 1;
	# $_flags |= $p->{aa    } & 0x0001; $_flags <<= 4;
	# $_flags |= $p->{opcode} & 0x000f; $_flags <<= 1;
	# $_flags |= $p->{qr    } & 0x0001;
	
	print "BPF: $_flags\n";
	print "BPF: ",pack("n",$_flags),"\n";

	if ( 
		defined $p->{qtype  } and 
		defined $p->{qclass } 
		) {

		return pack(
			"n n n n n n a* n n",
			$p->{id},
			$_flags,
			$p->{qdcount},
			$p->{ancount},
			$p->{nscount},
			$p->{arcount},
			$p->{rr     },
			$p->{qtype  },
			$p->{qclass },
			);
	} elsif (
		! defined $p->{qtype  } and 
		! defined $p->{qclass } 
		) {
		return pack(
			"n n n n n n a*",
			$p->{id},
			$_flags,
			$p->{qdcount},
			$p->{ancount},
			$p->{nscount},
			$p->{arcount},
			$p->{rr     },
			);
	} else {
		die "build_packet() error";
	}
}

sub build_name ($) {
	join "",map { chr(length($_)) . $_ } @{$_[0]},"";
}

sub build_rr ($) {
	my ($p) = @_;
	print Dumper($p);

#        0x0000:  4500 004b bac5 0000 3c11 be84 d409 a001  E..K....<.......
#        0x0010:  d409 bd43 0035 bf1a 0037 3c31 8e08 8580  ...C.5...7<1....
#        0x0020:  0001 0001 0000 0000 0377 7777 0663 6974  .........www.cit
#        0x0030:  6563 7302 6465 0000 0100 01c0 0c00 0100  ecs.de..........
#        0x0040:  0100 0151 8000 04d4 09a5 23              ...Q......#

	print join " ", "BRR",
		"type    :",$p->{type     },
		"class   :",$p->{class    },
		"ttl     :",$p->{ttl      },
		"rdlength:",$p->{rdlength },
		"rdata   :",$p->{rdata    },
		"\n";

	return pack(
		"a* n n  n n n  N n a*",
		build_name $p->{name},
		$p->{type     },
		$p->{class    },
		0xc00c,0x0001,0x0001, # repeat label f. q. section [0]
		$p->{ttl      },
		$p->{rdlength },
		$p->{rdata    },
        );
}

sub encode_flags ($) {
	my ($p) = @_;


	my $_flags = 
		( $p->{rcode } & 0x000f )        |
		( $p->{z     } & 0x0007 ) <<  4  |
		( $p->{ra    } & 0x0001 ) <<  7  |
		( $p->{rd    } & 0x0001 ) <<  8  |
		( $p->{tc    } & 0x0001 ) <<  9  |
		( $p->{aa    } & 0x0001 ) << 10  |
		( $p->{opcode} & 0x000f ) << 11  |
		( $p->{qr    } & 0x0001 ) << 15
		;

	print "N: $_flags\n";
	return $_flags;
}

sub decode_flags ($) {
	my ($_flags) = @_;

	my $p = {};
	print "N: $_flags\n";

	$p->{qr    } =   ( $_flags & 0x8000 ) >> 15;
	$p->{opcode} =   ( $_flags & 0x7800 ) >> 11;
	$p->{aa    } =   ( $_flags & 0x0400 ) >> 10;
	$p->{tc    } =   ( $_flags & 0x0200 ) >>  9;
	$p->{rd    } =   ( $_flags & 0x0100 ) >>  8;
	$p->{ra    } =   ( $_flags & 0x0080 ) >>  7;
	$p->{z     } =   ( $_flags & 0x0070 ) >>  4;
	$p->{rcode } =   ( $_flags & 0x000f )      ;
	print "qr:      ",$p->{qr     },"\n";
	print "opcode:  ",$p->{opcode },"\n";
	print "aa:      ",$p->{aa     },"\n"; 
	print "tc:      ",$p->{tc     },"\n"; 
	print "rd:      ",$p->{rd     },"\n"; 
	print "ra:      ",$p->{ra     },"\n"; 
	print "z:       ",$p->{z      },"\n"; 
	print "rcode:   ",$p->{rcode  },"\n";

	return $p;
}

__END__

#
# ein RR in einer DNS-Anwort nach einem A-RR hat lt. RFC 1035 p.28 das Format:
# 
#     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
#     |                                               |
#     /                                               /
#     /                      NAME                     /
#     |                                               |
#     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
#     |                      TYPE                     |
#     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
#     |                     CLASS                     |
#     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
#     |                      TTL                      |
#     |                                               |
#     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
#     |                   RDLENGTH                    |
#     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--|
#     /                     RDATA                     /
#     /                                               /
#     +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
# 
# Tatsaechlich kommt folgendes von einem DNS als
# Antwort zurueck:
# 
#         0x0000:  4500 004b c844 0000 3c11 b105 d409 a001    E..K.D..<.......
# 
#         0x0010:  d409 bd43 0035 ca0a 0037 9d6d 21dc 8580    ...C.5...7.m!...
#                                                [0]   [1]
#         0x0020:  0001 0001 0000 0000 0377 7777 0663 6974    .........www.cit
#                   [2]  [3]  [4]  [5]  [-------- 6 ------
#         0x0030:  6563 7302 6465 00 0001 0001 c00c 0001 00   ecs.de..........
#                  ----- 6 --------]  [7]  [8]  [9] [10] [11
# 
#         0x0040:  01 00015180 0004 d409a523                 ...Q......#
#                  -]   [12]   [13]
# 
# wobei:
#     [0]      - id (sequence)
#     [1]      - flags = RESPONSE OPCODE=0 AUTHORITATIVE-ANSWER=1 TRUNCATION=0 
#                        RECURSION-DESIRED=1 RECURSION-AVAILABLE=1 Z=0 RCODE=0
#     [2]      - QDCOUNT=1
#     [3]      - ANCOUNT=1
#     [4]      - NSCOUNT=0
#     [5]      - ARCOUNT=0
#     Wiederholung des Query-Records:
#     [6]      - urspruenglich angefragter Hostname
#     [7]      - QTYPE=1 host address
#     [8]      - QCLASS=1 Internet
# 
#     Antwort-RR:
#     [9]      -  1 1 0 0 0 0 0 1 1
#                [9a] [---- 9b ---]
#                Label an Offset 12[9b] wiederverwenden[9a], das waere [6]
#     [10]     - TYPE=1 host address
#     [11]     - CLASS=1 Internet
#     [12]     - TTL=86400
#     [14]     - RLENGTH=4
#     [15]     - RDATA=d409a523 -> 212.9.165.35
# 
#     00015180 - serial 86400
#     d409a523 - 212.9.165.35
#