TCP DNS64 Query

Problem this snippet solves:

This code is to support TCP DNS64 query. It is based on NAT64 DNS64 Codeshare contributed by Nat Thirasuttakorn and Configuring IP Address Sharing in a Large Scale Network: DNS64/NAT64 Deployment Guide version 1.4.

Please be noted that this code is only tested in test environment. Any suggestions are welcome.

Code :

when RULE_INIT {
set static::dns64prefix "0064ff9b0000000000000000"
}
when CLIENT_ACCEPTED {
TCP::collect
}
when CLIENT_DATA {
set query [TCP::payload]
binary scan $query @6S qdcount 

# only intercept AAAA QTYPE and reject AXFR/IXFR QTYPE
set index 14
while { $qdcount > 0 } {
binary scan $query @${index}c count
while { $count != 0 } {
incr index [expr {$count + 1}]
binary scan $query @${index}c count
}
incr index
binary scan $query @${index}S qtype
# 28 = AAAA, 251 = IXFR, 252 = AXFR
switch $qtype {
28 {
}
251 -
252 {
reject
return
}
default {
TCP::release
event disable all
return
}
}
incr index 4
incr qdcount -1
}
TCP::release
}
when SERVER_CONNECTED {
log local0. ""
set retry 0
TCP::collect
}
when SERVER_DATA {
log local0. ""

# change AAAA to A QTYPE only if ANCOUNT is 0
if { !$retry } {
binary scan [TCP::payload] @8S ancount
if { $ancount != 0 } {
return
}
binary scan $query @6S qdcount
set index 14
    while { $qdcount > 0 } {
binary scan $query @${index}c count
while { $count != 0 } {
incr index [expr {$count + 1}]
binary scan $query @${index}c count
}
incr index
binary scan $query @${index}S qtype
if { $qtype == 28 } {
set modified_query [binary format a* [string replace $query $index [expr {$index + 1}] [binary format S 1]]]
}
incr index 4
incr qdcount -1
    }
if { [info exists modified_query] } {
TCP::respond $modified_query
TCP::payload replace 0 [TCP::payload length] ""
incr retry
}

# add DNS64 prefix to A RR
} else {
set a_index_list ""

binary scan [TCP::payload] S@6SSSS len qdcount ancount nscount arcount
if { [TCP::payload length] < $len } {
TCP::collect
return
}
set index 14
    while { $qdcount > 0 } {
binary scan [TCP::payload] @${index}c count
while { $count != 0 } {
incr index [expr {$count + 1}]
binary scan [TCP::payload] @${index}c count
}
incr index
binary scan [TCP::payload] @${index}S qtype
if { $qtype == 1 } {
TCP::payload replace $index 2 [binary format S 28]
}
incr index 4
incr qdcount -1
    }

    while { $ancount > 0 || $nscount > 0 || $arcount > 0 } {
binary scan [TCP::payload] @${index}cc count pointer
set loop 0
while { $count != 0 && $loop < 30 } {
incr loop
set pointer_prefix [expr {($count >> 6) & 0x3}]
set pointer_index [expr {(($count & 0x3f) << 8) + ($pointer & 0xff)}]
if { $pointer_prefix == 3 } {
set save_pointer $pointer_index
foreach a $a_index_list {
if { $pointer_index < $a } {
break
}
incr pointer_index 12
}
# rewrite DNS compression pointer to appropriate value
if { $pointer_index > $save_pointer } {
TCP::payload replace $index 2 [binary format S [expr {$pointer_index | 0xc000}]]
}
incr index 2
break
} else {
incr index [expr {$count + 1}]
binary scan [TCP::payload] @${index}cc count pointer
}
}
binary scan [TCP::payload] @${index}SSIS qtype qclass ttl rdlength
incr index 10
if { $qtype == 1 } {
lappend a_index_list $index
binary scan [TCP::payload] @${index}cccc a b c d
set rdlength 16
TCP::payload replace [expr {$index - 10}] 14 [binary format SSISH24cccc 28 $qclass $ttl $rdlength $static::dns64prefix $a $b $c $d]
} elseif { $qtype == 2 } {
binary scan [TCP::payload] @${index}a${rdlength} rdata 
for { set x 0 } { $x < [expr {$rdlength - 1}] } { incr x } {
binary scan $rdata x${x}cc count pointer
set pointer_prefix [expr {($count >> 6) & 0x3}]
set pointer_index [expr {(($count &0x3f) << 8) + ($pointer & 0xff)}]
if { $pointer_prefix == 3 } {
set save_pointer $pointer_index
foreach a $a_index_list {
if { $pointer_index < $a } {
break
}
incr pointer_index 12
}
# rewrite DNS compression pointer to appropriate value
if { $pointer_index > $save_pointer } {
TCP::payload replace [expr {$index + $x}] 2 [binary format S [expr {$pointer_index | 0xc000}]]
}
}
}
}
incr index $rdlength
if { $ancount > 0 } {
incr ancount -1
} elseif  { $nscount > 0 } {
incr nscount -1
} else {
incr arcount -1
}
}
TCP::payload replace 0 2 [binary format S [expr {[TCP::payload length] - 2}]]
}
TCP::release
TCP::collect
}