1227 lines
36 KiB
Tcl
1227 lines
36 KiB
Tcl
# dns.tcl - Steve Bennett <steveb@workware.net.au>
|
|
#
|
|
# Modified for Jim Tcl to:
|
|
# - use udp transport by default
|
|
# - use sendto/recvfrom
|
|
# - don't try to determine local nameservers
|
|
# - remove support for dns uris and finding local nameservers
|
|
# - remove logging calls
|
|
# (both of these in order to remove dependencies on tcllib)
|
|
|
|
# Based on:
|
|
|
|
# dns.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
|
|
#
|
|
# Provide a Tcl only Domain Name Service client. See RFC 1034 and RFC 1035
|
|
# for information about the DNS protocol. This should insulate Tcl scripts
|
|
# from problems with using the system library resolver for slow name servers.
|
|
#
|
|
# This implementation uses TCP only for DNS queries. The protocol reccommends
|
|
# that UDP be used in these cases but Tcl does not include UDP sockets by
|
|
# default. The package should be simple to extend to use a TclUDP extension
|
|
# in the future.
|
|
#
|
|
# Support for SPF (http://spf.pobox.com/rfcs.html) will need updating
|
|
# if or when the proposed draft becomes accepted.
|
|
#
|
|
# Support added for RFC1886 - DNS Extensions to support IP version 6
|
|
# Support added for RFC2782 - DNS RR for specifying the location of services
|
|
# Support added for RFC1995 - Incremental Zone Transfer in DNS
|
|
#
|
|
# TODO:
|
|
# - When using tcp we should make better use of the open connection and
|
|
# send multiple queries along the same connection.
|
|
#
|
|
# - We must switch to using TCP for truncated UDP packets.
|
|
#
|
|
# - Read RFC 2136 - dynamic updating of DNS
|
|
#
|
|
# -------------------------------------------------------------------------
|
|
# See the file "license.terms" for information on usage and redistribution
|
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
# -------------------------------------------------------------------------
|
|
#
|
|
# $Id: dns.tcl,v 1.36 2008/11/22 12:28:54 mic42 Exp $
|
|
|
|
package require binary
|
|
package require namespace
|
|
|
|
namespace eval ::dns {
|
|
variable version 1.3.3-jim2
|
|
variable rcsid {$Id: dns.tcl,v 1.36 2008/11/22 12:28:54 mic42 Exp $}
|
|
|
|
namespace export configure resolve name address cname \
|
|
status reset wait cleanup errorcode
|
|
|
|
variable options
|
|
if {![info exists options]} {
|
|
array set options {
|
|
port 53
|
|
timeout 30000
|
|
protocol udp
|
|
search {}
|
|
nameserver {localhost}
|
|
loglevel warn
|
|
}
|
|
#variable log [logger::init dns]
|
|
#${log}::setlevel $options(loglevel)
|
|
}
|
|
|
|
variable types
|
|
array set types {
|
|
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
|
|
SPF 16 AAAA 28 SRV 33 IXFR 251 AXFR 252 MAILB 253 MAILA 254
|
|
ANY 255 * 255
|
|
}
|
|
|
|
variable classes
|
|
array set classes { IN 1 CS 2 CH 3 HS 4 * 255}
|
|
|
|
variable uid
|
|
if {![info exists uid]} {
|
|
set uid 0
|
|
}
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# Configure the DNS package. In particular the local nameserver will need
|
|
# to be set. With no options, returns a list of all current settings.
|
|
#
|
|
proc ::dns::configure {args} {
|
|
variable options
|
|
variable log
|
|
|
|
if {[llength $args] < 1} {
|
|
set r {}
|
|
foreach opt [lsort [array names options]] {
|
|
lappend r -$opt $options($opt)
|
|
}
|
|
return $r
|
|
}
|
|
|
|
set cget 0
|
|
if {[llength $args] == 1} {
|
|
set cget 1
|
|
}
|
|
|
|
while {[string match -* [lindex $args 0]]} {
|
|
switch -glob -- [lindex $args 0] {
|
|
-n* -
|
|
-ser* {
|
|
if {$cget} {
|
|
return $options(nameserver)
|
|
} else {
|
|
set options(nameserver) [Pop args 1]
|
|
}
|
|
}
|
|
-po* {
|
|
if {$cget} {
|
|
return $options(port)
|
|
} else {
|
|
set options(port) [Pop args 1]
|
|
}
|
|
}
|
|
-ti* {
|
|
if {$cget} {
|
|
return $options(timeout)
|
|
} else {
|
|
set options(timeout) [Pop args 1]
|
|
}
|
|
}
|
|
-pr* {
|
|
if {$cget} {
|
|
return $options(protocol)
|
|
} else {
|
|
set proto [string tolower [Pop args 1]]
|
|
if {[string compare udp $proto] == 0 \
|
|
&& [string compare tcp $proto] == 0} {
|
|
return -code error "invalid protocol \"$proto\":\
|
|
protocol must be either \"udp\" or \"tcp\""
|
|
}
|
|
set options(protocol) $proto
|
|
}
|
|
}
|
|
-sea* {
|
|
if {$cget} {
|
|
return $options(search)
|
|
} else {
|
|
set options(search) [Pop args 1]
|
|
}
|
|
}
|
|
-log* {
|
|
if {$cget} {
|
|
return $options(loglevel)
|
|
} else {
|
|
set options(loglevel) [Pop args 1]
|
|
${log}::setlevel $options(loglevel)
|
|
}
|
|
}
|
|
-- { Pop args ; break }
|
|
default {
|
|
set opts [join [lsort [array names options]] ", -"]
|
|
return -code error "bad option [lindex $args 0]:\
|
|
must be one of -$opts"
|
|
}
|
|
}
|
|
Pop args
|
|
}
|
|
|
|
return
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# Create a DNS query and send to the specified name server. Returns a token
|
|
# to be used to obtain any further information about this query.
|
|
#
|
|
proc ::dns::resolve {query args} {
|
|
variable uid
|
|
variable options
|
|
variable log
|
|
|
|
# get a guaranteed unique and non-present token id.
|
|
set id [incr uid]
|
|
while {[info exists [set token [namespace current]::$id]]} {
|
|
set id [incr uid]
|
|
}
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
|
|
# Setup token/state defaults.
|
|
set state(id) $id
|
|
set state(query) $query
|
|
set state(qdata) ""
|
|
set state(opcode) 0; # 0 = query, 1 = inverse query.
|
|
set state(-type) A; # DNS record type (A address)
|
|
set state(-class) IN; # IN (internet address space)
|
|
set state(-recurse) 1; # Recursion Desired
|
|
set state(-command) {}; # asynchronous handler
|
|
set state(-timeout) $options(timeout); # connection timeout default.
|
|
set state(-nameserver) $options(nameserver);# default nameserver
|
|
set state(-port) $options(port); # default namerservers port
|
|
set state(-search) $options(search); # domain search list
|
|
set state(-protocol) $options(protocol); # which protocol udp/tcp
|
|
|
|
# Support for DNS URL's removed
|
|
|
|
while {[string match -* [lindex $args 0]]} {
|
|
switch -glob -- [lindex $args 0] {
|
|
-n* - ns -
|
|
-ser* { set state(-nameserver) [Pop args 1] }
|
|
-po* { set state(-port) [Pop args 1] }
|
|
-ti* { set state(-timeout) [Pop args 1] }
|
|
-co* { set state(-command) [Pop args 1] }
|
|
-cl* { set state(-class) [Pop args 1] }
|
|
-ty* { set state(-type) [Pop args 1] }
|
|
-pr* { set state(-protocol) [Pop args 1] }
|
|
-sea* { set state(-search) [Pop args 1] }
|
|
-re* { set state(-recurse) [Pop args 1] }
|
|
-inv* { set state(opcode) 1 }
|
|
-status {set state(opcode) 2}
|
|
-data { set state(qdata) [Pop args 1] }
|
|
default {
|
|
set opts [join [lsort [array names state -*]] ", "]
|
|
return -code error "bad option [lindex $args 0]: \
|
|
must be $opts"
|
|
}
|
|
}
|
|
Pop args
|
|
}
|
|
|
|
if {$state(-nameserver) == {}} {
|
|
return -code error "no nameserver specified"
|
|
}
|
|
|
|
# Check for reverse lookups
|
|
if {[regexp {^(?:\d{0,3}\.){3}\d{0,3}$} $state(query)]} {
|
|
set addr [lreverse [split $state(query) .]]
|
|
lappend addr in-addr arpa
|
|
set state(query) [join $addr .]
|
|
set state(-type) PTR
|
|
}
|
|
|
|
BuildMessage $token
|
|
|
|
if {$state(-protocol) == "tcp"} {
|
|
TcpTransmit $token
|
|
if {$state(-command) == {}} {
|
|
wait $token
|
|
}
|
|
} else {
|
|
UdpTransmit $token
|
|
wait $token
|
|
}
|
|
|
|
return $token
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# Return a list of domain names returned as results for the last query.
|
|
#
|
|
proc ::dns::name {token} {
|
|
set r {}
|
|
Flags $token flags
|
|
array set reply [Decode $token]
|
|
|
|
switch -exact -- $flags(opcode) {
|
|
0 {
|
|
# QUERY
|
|
foreach answer $reply(AN) {
|
|
array set AN $answer
|
|
if {![info exists AN(type)]} {set AN(type) {}}
|
|
switch -exact -- $AN(type) {
|
|
MX - NS - PTR {
|
|
if {[info exists AN(rdata)]} {lappend r $AN(rdata)}
|
|
}
|
|
default {
|
|
if {[info exists AN(name)]} {
|
|
lappend r $AN(name)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
1 {
|
|
# IQUERY
|
|
foreach answer $reply(QD) {
|
|
array set QD $answer
|
|
lappend r $QD(name)
|
|
}
|
|
}
|
|
default {
|
|
return -code error "not supported for this query type"
|
|
}
|
|
}
|
|
return $r
|
|
}
|
|
|
|
# Description:
|
|
# Return a list of the IP addresses returned for this query.
|
|
#
|
|
proc ::dns::address {token} {
|
|
set r {}
|
|
array set reply [Decode $token]
|
|
foreach answer $reply(AN) {
|
|
array set AN $answer
|
|
|
|
if {[info exists AN(type)]} {
|
|
switch -exact -- $AN(type) {
|
|
"A" {
|
|
lappend r $AN(rdata)
|
|
}
|
|
"AAAA" {
|
|
lappend r $AN(rdata)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return $r
|
|
}
|
|
|
|
# Description:
|
|
# Return a list of all CNAME results returned for this query.
|
|
#
|
|
proc ::dns::cname {token} {
|
|
set r {}
|
|
array set reply [Decode $token]
|
|
foreach answer $reply(AN) {
|
|
array set AN $answer
|
|
|
|
if {[info exists AN(type)]} {
|
|
if {$AN(type) == "CNAME"} {
|
|
lappend r $AN(rdata)
|
|
}
|
|
}
|
|
}
|
|
return $r
|
|
}
|
|
|
|
# Description:
|
|
# Return the decoded answer records. This can be used for more complex
|
|
# queries where the answer isn't supported byb cname/address/name.
|
|
proc ::dns::result {token args} {
|
|
array set reply [eval [linsert $args 0 Decode $token]]
|
|
return $reply(AN)
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# Get the status of the request.
|
|
#
|
|
proc ::dns::status {token} {
|
|
upvar #0 $token state
|
|
return $state(status)
|
|
}
|
|
|
|
# Description:
|
|
# Get the error message. Empty if no error.
|
|
#
|
|
proc ::dns::error {token} {
|
|
upvar #0 $token state
|
|
if {[info exists state(error)]} {
|
|
return $state(error)
|
|
}
|
|
return ""
|
|
}
|
|
|
|
# Description
|
|
# Get the error code. This is 0 for a successful transaction.
|
|
#
|
|
proc ::dns::errorcode {token} {
|
|
upvar #0 $token state
|
|
set flags [Flags $token]
|
|
set ndx [lsearch -exact $flags errorcode]
|
|
incr ndx
|
|
return [lindex $flags $ndx]
|
|
}
|
|
|
|
# Description:
|
|
# Reset a connection with optional reason.
|
|
#
|
|
proc ::dns::reset {token {why reset} {errormsg {}}} {
|
|
upvar #0 $token state
|
|
set state(status) $why
|
|
if {[string length $errormsg] > 0 && ![info exists state(error)]} {
|
|
set state(error) $errormsg
|
|
}
|
|
catch {fileevent $state(sock) readable {}}
|
|
Finish $token
|
|
}
|
|
|
|
# Description:
|
|
# Wait for a request to complete and return the status.
|
|
#
|
|
proc ::dns::wait {token} {
|
|
upvar #0 $token state
|
|
|
|
if {$state(status) == "connect"} {
|
|
vwait [subst $token](status)
|
|
}
|
|
|
|
return $state(status)
|
|
}
|
|
|
|
# Description:
|
|
# Remove any state associated with this token.
|
|
#
|
|
proc ::dns::cleanup {token} {
|
|
upvar #0 $token state
|
|
if {[info exists state]} {
|
|
catch {close $state(sock)}
|
|
catch {after cancel $state(after)}
|
|
unset state
|
|
}
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# Dump the raw data of the request and reply packets.
|
|
#
|
|
proc ::dns::dump {args} {
|
|
if {[llength $args] == 1} {
|
|
set type -reply
|
|
set token [lindex $args 0]
|
|
} elseif { [llength $args] == 2 } {
|
|
set type [lindex $args 0]
|
|
set token [lindex $args 1]
|
|
} else {
|
|
return -code error "wrong # args:\
|
|
should be \"dump ?option? methodName\""
|
|
}
|
|
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
|
|
set result {}
|
|
switch -glob -- $type {
|
|
-qu* -
|
|
-req* {
|
|
set result [DumpMessage $state(request)]
|
|
}
|
|
-rep* {
|
|
set result [DumpMessage $state(reply)]
|
|
}
|
|
default {
|
|
error "unrecognised option: must be one of \
|
|
\"-query\", \"-request\" or \"-reply\""
|
|
}
|
|
}
|
|
|
|
return $result
|
|
}
|
|
|
|
# Description:
|
|
# Perform a hex dump of binary data.
|
|
#
|
|
proc ::dns::DumpMessage {data} {
|
|
set result {}
|
|
binary scan $data c* r
|
|
foreach c $r {
|
|
append result [format "%02x " [expr {$c & 0xff}]]
|
|
}
|
|
return $result
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# Contruct a DNS query packet.
|
|
#
|
|
proc ::dns::BuildMessage {token} {
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
variable types
|
|
variable classes
|
|
variable options
|
|
|
|
if {! [info exists types($state(-type))] } {
|
|
return -code error "invalid DNS query type"
|
|
}
|
|
|
|
if {! [info exists classes($state(-class))] } {
|
|
return -code error "invalid DNS query class"
|
|
}
|
|
|
|
set qdcount 0
|
|
set qsection {}
|
|
set nscount 0
|
|
set nsdata {}
|
|
|
|
# In theory we can send multiple queries. In practice, named doesn't
|
|
# appear to like that much. If it did work we'd do this:
|
|
# foreach domain [linsert $options(search) 0 {}] ...
|
|
|
|
|
|
# Pack the query: QNAME QTYPE QCLASS
|
|
set qsection [PackName $state(query)]
|
|
append qsection [binary format SS \
|
|
$types($state(-type))\
|
|
$classes($state(-class))]
|
|
incr qdcount
|
|
|
|
if {[string length $state(qdata)] > 0} {
|
|
set nsdata [eval [linsert $state(qdata) 0 PackRecord]]
|
|
incr nscount
|
|
}
|
|
|
|
switch -exact -- $state(opcode) {
|
|
0 {
|
|
# QUERY
|
|
set state(request) [binary format SSSSSS $state(id) \
|
|
[expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
|
|
$qdcount 0 $nscount 0]
|
|
append state(request) $qsection $nsdata
|
|
}
|
|
1 {
|
|
# IQUERY
|
|
set state(request) [binary format SSSSSS $state(id) \
|
|
[expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
|
|
0 $qdcount 0 0 0]
|
|
append state(request) \
|
|
[binary format cSSI 0 \
|
|
$types($state(-type)) $classes($state(-class)) 0]
|
|
switch -exact -- $state(-type) {
|
|
A {
|
|
append state(request) \
|
|
[binary format Sc4 4 [split $state(query) .]]
|
|
}
|
|
PTR {
|
|
append state(request) \
|
|
[binary format Sc4 4 [split $state(query) .]]
|
|
}
|
|
default {
|
|
return -code error "inverse query not supported for this type"
|
|
}
|
|
}
|
|
}
|
|
default {
|
|
return -code error "operation not supported"
|
|
}
|
|
}
|
|
|
|
return
|
|
}
|
|
|
|
# Pack a human readable dns name into a DNS resource record format.
|
|
proc ::dns::PackName {name} {
|
|
set data ""
|
|
foreach part [split [string trim $name .] .] {
|
|
set len [string length $part]
|
|
append data [binary format ca$len $len $part]
|
|
}
|
|
append data \x00
|
|
return $data
|
|
}
|
|
|
|
# Pack a character string - byte length prefixed
|
|
proc ::dns::PackString {text} {
|
|
set len [string length $text]
|
|
set data [binary format ca$len $len $text]
|
|
return $data
|
|
}
|
|
|
|
# Pack up a single DNS resource record. See RFC1035: 3.2 for the format
|
|
# of each type.
|
|
# eg: PackRecord name wiki.tcl.tk type MX class IN rdata {10 mail.example.com}
|
|
#
|
|
proc ::dns::PackRecord {args} {
|
|
variable types
|
|
variable classes
|
|
array set rr {name "" type A class IN ttl 0 rdlength 0 rdata ""}
|
|
array set rr $args
|
|
set data [PackName $rr(name)]
|
|
|
|
switch -exact -- $rr(type) {
|
|
CNAME - MB - MD - MF - MG - MR - NS - PTR {
|
|
set rr(rdata) [PackName $rr(rdata)]
|
|
}
|
|
HINFO {
|
|
array set r {CPU {} OS {}}
|
|
array set r $rr(rdata)
|
|
set rr(rdata) [PackString $r(CPU)]
|
|
append rr(rdata) [PackString $r(OS)]
|
|
}
|
|
MINFO {
|
|
array set r {RMAILBX {} EMAILBX {}}
|
|
array set r $rr(rdata)
|
|
set rr(rdata) [PackString $r(RMAILBX)]
|
|
append rr(rdata) [PackString $r(EMAILBX)]
|
|
}
|
|
MX {
|
|
foreach {pref exch} $rr(rdata) break
|
|
set rr(rdata) [binary format S $pref]
|
|
append rr(rdata) [PackName $exch]
|
|
}
|
|
TXT {
|
|
set str $rr(rdata)
|
|
set len [string length [set str $rr(rdata)]]
|
|
set rr(rdata) ""
|
|
for {set n 0} {$n < $len} {incr n} {
|
|
set s [string range $str $n [incr n 253]]
|
|
append rr(rdata) [PackString $s]
|
|
}
|
|
}
|
|
NULL {}
|
|
SOA {
|
|
array set r {MNAME {} RNAME {}
|
|
SERIAL 0 REFRESH 0 RETRY 0 EXPIRE 0 MINIMUM 0}
|
|
array set r $rr(rdata)
|
|
set rr(rdata) [PackName $r(MNAME)]
|
|
append rr(rdata) [PackName $r(RNAME)]
|
|
append rr(rdata) [binary format IIIII $r(SERIAL) \
|
|
$r(REFRESH) $r(RETRY) $r(EXPIRE) $r(MINIMUM)]
|
|
}
|
|
}
|
|
|
|
# append the root label and the type flag and query class.
|
|
append data [binary format SSIS $types($rr(type)) \
|
|
$classes($rr(class)) $rr(ttl) [string length $rr(rdata)]]
|
|
append data $rr(rdata)
|
|
return $data
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# Transmit a DNS request over a tcp connection.
|
|
#
|
|
proc ::dns::TcpTransmit {token} {
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
|
|
# setup the timeout
|
|
if {$state(-timeout) > 0} {
|
|
set state(after) [after $state(-timeout) \
|
|
[list [namespace origin reset] \
|
|
$token timeout\
|
|
"operation timed out"]]
|
|
}
|
|
|
|
# Jim Tcl has no async connect ...
|
|
|
|
set s [socket stream $state(-nameserver):$state(-port)]
|
|
fileevent $s writable [list [namespace origin TcpConnected] $token $s]
|
|
set state(sock) $s
|
|
set state(status) connect
|
|
|
|
return $token
|
|
}
|
|
|
|
proc ::dns::TcpConnected {token s} {
|
|
variable $token
|
|
upvar 0 $token state
|
|
|
|
fileevent $s writable {}
|
|
|
|
# Jim Tcl has no async connect ...
|
|
# if {[catch {fconfigure $s -peername}]} {
|
|
# # TCP connection failed
|
|
# Finish $token "can't connect to server"
|
|
# return
|
|
# }
|
|
|
|
fconfigure $s -blocking 0 -translation binary -buffering none
|
|
|
|
# For TCP the message must be prefixed with a 16bit length field.
|
|
set req [binary format S [string length $state(request)]]
|
|
append req $state(request)
|
|
|
|
puts -nonewline $s $req
|
|
|
|
fileevent $s readable [list [namespace current]::TcpEvent $token]
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
# Description:
|
|
# Transmit a DNS request using UDP datagrams
|
|
#
|
|
# Note:
|
|
# This requires a UDP implementation that can transmit binary data.
|
|
# As yet I have been unable to test this myself and the tcludp package
|
|
# cannot do this.
|
|
#
|
|
proc ::dns::UdpTransmit {token} {
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
|
|
# setup the timeout
|
|
if {$state(-timeout) > 0} {
|
|
set state(after) [after $state(-timeout) \
|
|
[list [namespace origin reset] \
|
|
$token timeout\
|
|
"operation timed out"]]
|
|
}
|
|
|
|
set state(sock) [socket dgram]
|
|
#fconfigure $state(sock) -translation binary -buffering none
|
|
set state(status) connect
|
|
$state(sock) sendto $state(request) $state(-nameserver):$state(-port)
|
|
|
|
fileevent $state(sock) readable [list [namespace current]::UdpEvent $token]
|
|
|
|
return $token
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# Tidy up after a tcp transaction.
|
|
#
|
|
proc ::dns::Finish {token {errormsg ""}} {
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
global errorInfo errorCode
|
|
|
|
if {[string length $errormsg] != 0} {
|
|
set state(error) $errormsg
|
|
set state(status) error
|
|
}
|
|
catch {close $state(sock)}
|
|
catch {after cancel $state(after)}
|
|
if {[info exists state(-command)] && $state(-command) != {}} {
|
|
if {[catch {eval $state(-command) {$token}} err]} {
|
|
if {[string length $errormsg] == 0} {
|
|
set state(error) [list $err $errorInfo $errorCode]
|
|
set state(status) error
|
|
}
|
|
}
|
|
if {[info exists state(-command)]} {
|
|
unset state(-command)
|
|
}
|
|
}
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# Handle end-of-file on a tcp connection.
|
|
#
|
|
proc ::dns::Eof {token} {
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
set state(status) eof
|
|
Finish $token
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# Process a DNS reply packet (protocol independent)
|
|
#
|
|
proc ::dns::Receive {token} {
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
|
|
binary scan $state(reply) SS id flags
|
|
set status [expr {$flags & 0x000F}]
|
|
|
|
switch -- $status {
|
|
0 {
|
|
set state(status) ok
|
|
Finish $token
|
|
}
|
|
1 { Finish $token "Format error - unable to interpret the query." }
|
|
2 { Finish $token "Server failure - internal server error." }
|
|
3 { Finish $token "Name Error - domain does not exist" }
|
|
4 { Finish $token "Not implemented - the query type is not available." }
|
|
5 { Finish $token "Refused - your request has been refused by the server." }
|
|
default {
|
|
Finish $token "unrecognised error code: $err"
|
|
}
|
|
}
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# file event handler for tcp socket. Wait for the reply data.
|
|
#
|
|
proc ::dns::TcpEvent {token} {
|
|
variable log
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
set s $state(sock)
|
|
|
|
if {[eof $s]} {
|
|
Eof $token
|
|
return
|
|
}
|
|
|
|
set status [catch {read $state(sock)} result]
|
|
if {$status != 0} {
|
|
${log}::debug "Event error: $result"
|
|
Finish $token "error reading data: $result"
|
|
} elseif { [string length $result] >= 0 } {
|
|
if {[catch {
|
|
# Handle incomplete reads - check the size and keep reading.
|
|
if {![info exists state(size)]} {
|
|
binary scan $result S state(size)
|
|
set result [string range $result 2 end]
|
|
}
|
|
append state(reply) $result
|
|
|
|
# check the length and flags and chop off the tcp length prefix.
|
|
if {[string length $state(reply)] >= $state(size)} {
|
|
binary scan $result S id
|
|
set id [expr {$id & 0xFFFF}]
|
|
if {$id != [expr {$state(id) & 0xFFFF}]} {
|
|
${log}::error "received packed with incorrect id"
|
|
}
|
|
# bug #1158037 - doing this causes problems > 65535 requests!
|
|
#Receive [namespace current]::$id
|
|
Receive $token
|
|
} else {
|
|
${log}::debug "Incomplete tcp read:\
|
|
[string length $state(reply)] should be $state(size)"
|
|
}
|
|
} err]} {
|
|
Finish $token "Event error: $err"
|
|
}
|
|
} elseif { [eof $state(sock)] } {
|
|
Eof $token
|
|
} elseif { [fblocked $state(sock)] } {
|
|
${log}::debug "Event blocked"
|
|
} else {
|
|
${log}::critical "Event error: this can't happen!"
|
|
Finish $token "Event error: this can't happen!"
|
|
}
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# file event handler for udp sockets.
|
|
proc ::dns::UdpEvent {token} {
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
set s $state(sock)
|
|
|
|
set payload [$state(sock) recvfrom 1500]
|
|
append state(reply) $payload
|
|
|
|
binary scan $payload S id
|
|
set id [expr {$id & 0xFFFF}]
|
|
if {$id != [expr {$state(id) & 0xFFFF}]} {
|
|
${log}::error "received packed with incorrect id"
|
|
}
|
|
# bug #1158037 - doing this causes problems > 65535 requests!
|
|
#Receive [namespace current]::$id
|
|
Receive $token
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
proc ::dns::Flags {token {varname {}}} {
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
|
|
if {$varname != {}} {
|
|
upvar $varname flags
|
|
}
|
|
|
|
array set flags {query 0 opcode 0 authoritative 0 errorcode 0
|
|
truncated 0 recursion_desired 0 recursion_allowed 0}
|
|
|
|
binary scan $state(reply) SSSSSS mid hdr nQD nAN nNS nAR
|
|
|
|
set flags(response) [expr {($hdr & 0x8000) >> 15}]
|
|
set flags(opcode) [expr {($hdr & 0x7800) >> 11}]
|
|
set flags(authoritative) [expr {($hdr & 0x0400) >> 10}]
|
|
set flags(truncated) [expr {($hdr & 0x0200) >> 9}]
|
|
set flags(recursion_desired) [expr {($hdr & 0x0100) >> 8}]
|
|
set flags(recursion_allowed) [expr {($hdr & 0x0080) >> 7}]
|
|
set flags(errorcode) [expr {($hdr & 0x000F)}]
|
|
|
|
return [array get flags]
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Description:
|
|
# Decode a DNS packet (either query or response).
|
|
#
|
|
proc ::dns::Decode {token args} {
|
|
variable log
|
|
# FRINK: nocheck
|
|
variable $token
|
|
upvar 0 $token state
|
|
|
|
array set opts {-rdata 0 -query 0}
|
|
while {[string match -* [set option [lindex $args 0]]]} {
|
|
switch -exact -- $option {
|
|
-rdata { set opts(-rdata) 1 }
|
|
-query { set opts(-query) 1 }
|
|
default {
|
|
return -code error "bad option \"$option\":\
|
|
must be -rdata"
|
|
}
|
|
}
|
|
Pop args
|
|
}
|
|
|
|
if {$opts(-query)} {
|
|
binary scan $state(request) SSSSSSc* mid hdr nQD nAN nNS nAR data
|
|
} else {
|
|
binary scan $state(reply) SSSSSSc* mid hdr nQD nAN nNS nAR data
|
|
}
|
|
|
|
set fResponse [expr {($hdr & 0x8000) >> 15}]
|
|
set fOpcode [expr {($hdr & 0x7800) >> 11}]
|
|
set fAuthoritative [expr {($hdr & 0x0400) >> 10}]
|
|
set fTrunc [expr {($hdr & 0x0200) >> 9}]
|
|
set fRecurse [expr {($hdr & 0x0100) >> 8}]
|
|
set fCanRecurse [expr {($hdr & 0x0080) >> 7}]
|
|
set fRCode [expr {($hdr & 0x000F)}]
|
|
set flags ""
|
|
|
|
if {$fResponse} {set flags "QR"} else {set flags "Q"}
|
|
set opcodes [list QUERY IQUERY STATUS]
|
|
lappend flags [lindex $opcodes $fOpcode]
|
|
if {$fAuthoritative} {lappend flags "AA"}
|
|
if {$fTrunc} {lappend flags "TC"}
|
|
if {$fRecurse} {lappend flags "RD"}
|
|
if {$fCanRecurse} {lappend flags "RA"}
|
|
|
|
set info "ID: $mid\
|
|
Fl: [format 0x%02X [expr {$hdr & 0xFFFF}]] ($flags)\
|
|
NQ: $nQD\
|
|
NA: $nAN\
|
|
NS: $nNS\
|
|
AR: $nAR"
|
|
#${log}::debug $info
|
|
|
|
set ndx 12
|
|
set r {}
|
|
set QD [ReadQuestion $nQD $state(reply) ndx]
|
|
lappend r QD $QD
|
|
set AN [ReadAnswer $nAN $state(reply) ndx $opts(-rdata)]
|
|
lappend r AN $AN
|
|
set NS [ReadAnswer $nNS $state(reply) ndx $opts(-rdata)]
|
|
lappend r NS $NS
|
|
set AR [ReadAnswer $nAR $state(reply) ndx $opts(-rdata)]
|
|
lappend r AR $AR
|
|
return $r
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
proc ::dns::Expand {data} {
|
|
set r {}
|
|
binary scan $data c* d
|
|
foreach c $d {
|
|
lappend r [expr {$c & 0xFF}]
|
|
}
|
|
return $r
|
|
}
|
|
|
|
|
|
# -------------------------------------------------------------------------
|
|
# Description:
|
|
# Pop the nth element off a list. Used in options processing.
|
|
#
|
|
proc ::dns::Pop {varname {nth 0}} {
|
|
upvar $varname args
|
|
set r [lindex $args $nth]
|
|
set args [lreplace $args $nth $nth]
|
|
return $r
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
proc ::dns::KeyOf {arrayname value {default {}}} {
|
|
upvar $arrayname array
|
|
set lst [array get array]
|
|
set ndx [lsearch -exact $lst $value]
|
|
if {$ndx != -1} {
|
|
incr ndx -1
|
|
set r [lindex $lst $ndx]
|
|
} else {
|
|
set r $default
|
|
}
|
|
return $r
|
|
}
|
|
|
|
|
|
# -------------------------------------------------------------------------
|
|
# Read the question section from a DNS message. This always starts at index
|
|
# 12 of a message but may be of variable length.
|
|
#
|
|
proc ::dns::ReadQuestion {nitems data indexvar} {
|
|
variable types
|
|
variable classes
|
|
upvar $indexvar index
|
|
set result {}
|
|
|
|
for {set cn 0} {$cn < $nitems} {incr cn} {
|
|
set r {}
|
|
lappend r name [ReadName data $index offset]
|
|
incr index $offset
|
|
|
|
# Read off QTYPE and QCLASS for this query.
|
|
set ndx $index
|
|
incr index 3
|
|
binary scan [string range $data $ndx $index] SS qtype qclass
|
|
set qtype [expr {$qtype & 0xFFFF}]
|
|
set qclass [expr {$qclass & 0xFFFF}]
|
|
incr index
|
|
lappend r type [KeyOf types $qtype $qtype] \
|
|
class [KeyOf classes $qclass $qclass]
|
|
lappend result $r
|
|
}
|
|
return $result
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
# Read an answer section from a DNS message.
|
|
#
|
|
proc ::dns::ReadAnswer {nitems data indexvar {raw 0}} {
|
|
variable types
|
|
variable classes
|
|
upvar $indexvar index
|
|
set result {}
|
|
|
|
for {set cn 0} {$cn < $nitems} {incr cn} {
|
|
set r {}
|
|
lappend r name [ReadName data $index offset]
|
|
incr index $offset
|
|
|
|
# Read off TYPE, CLASS, TTL and RDLENGTH
|
|
binary scan [string range $data $index end] SSIS type class ttl rdlength
|
|
|
|
set type [expr {$type & 0xFFFF}]
|
|
set type [KeyOf types $type $type]
|
|
|
|
set class [expr {$class & 0xFFFF}]
|
|
set class [KeyOf classes $class $class]
|
|
|
|
set ttl [expr {$ttl & 0xFFFFFFFF}]
|
|
set rdlength [expr {$rdlength & 0xFFFF}]
|
|
incr index 10
|
|
set rdata [string range $data $index [expr {$index + $rdlength - 1}]]
|
|
|
|
if {! $raw} {
|
|
switch -- $type {
|
|
A {
|
|
set rdata [join [Expand $rdata] .]
|
|
}
|
|
AAAA {
|
|
set rdata [ip::contract [ip::ToString $rdata]]
|
|
}
|
|
NS - CNAME - PTR {
|
|
set rdata [ReadName data $index off]
|
|
}
|
|
MX {
|
|
binary scan $rdata S preference
|
|
set exchange [ReadName data [expr {$index + 2}] off]
|
|
set rdata [list $preference $exchange]
|
|
}
|
|
SRV {
|
|
set x $index
|
|
set rdata [list priority [ReadUShort data $x off]]
|
|
incr x $off
|
|
lappend rdata weight [ReadUShort data $x off]
|
|
incr x $off
|
|
lappend rdata port [ReadUShort data $x off]
|
|
incr x $off
|
|
lappend rdata target [ReadName data $x off]
|
|
incr x $off
|
|
}
|
|
TXT {
|
|
set rdata [ReadString data $index $rdlength]
|
|
}
|
|
SOA {
|
|
set x $index
|
|
set rdata [list MNAME [ReadName data $x off]]
|
|
incr x $off
|
|
lappend rdata RNAME [ReadName data $x off]
|
|
incr x $off
|
|
lappend rdata SERIAL [ReadULong data $x off]
|
|
incr x $off
|
|
lappend rdata REFRESH [ReadLong data $x off]
|
|
incr x $off
|
|
lappend rdata RETRY [ReadLong data $x off]
|
|
incr x $off
|
|
lappend rdata EXPIRE [ReadLong data $x off]
|
|
incr x $off
|
|
lappend rdata MINIMUM [ReadULong data $x off]
|
|
incr x $off
|
|
}
|
|
}
|
|
}
|
|
|
|
incr index $rdlength
|
|
lappend r type $type class $class ttl $ttl rdlength $rdlength rdata $rdata
|
|
lappend result $r
|
|
}
|
|
return $result
|
|
}
|
|
|
|
|
|
# Read a 32bit integer from a DNS packet. These are compatible with
|
|
# the ReadName proc. Additionally - ReadULong takes measures to ensure
|
|
# the unsignedness of the value obtained.
|
|
#
|
|
proc ::dns::ReadLong {datavar index usedvar} {
|
|
upvar $datavar data
|
|
upvar $usedvar used
|
|
set r {}
|
|
set used 0
|
|
if {[binary scan $data @${index}I r]} {
|
|
set used 4
|
|
}
|
|
return $r
|
|
}
|
|
|
|
proc ::dns::ReadULong {datavar index usedvar} {
|
|
upvar $datavar data
|
|
upvar $usedvar used
|
|
set r {}
|
|
set used 0
|
|
if {[binary scan $data @${index}cccc b1 b2 b3 b4]} {
|
|
set used 4
|
|
# This gets us an unsigned value.
|
|
set r [expr {($b4 & 0xFF) + (($b3 & 0xFF) << 8)
|
|
+ (($b2 & 0xFF) << 16) + ($b1 << 24)}]
|
|
}
|
|
return $r
|
|
}
|
|
|
|
proc ::dns::ReadUShort {datavar index usedvar} {
|
|
upvar $datavar data
|
|
upvar $usedvar used
|
|
set r {}
|
|
set used 0
|
|
if {[binary scan [string range $data $index end] cc b1 b2]} {
|
|
set used 2
|
|
# This gets us an unsigned value.
|
|
set r [expr {(($b2 & 0xff) + (($b1 & 0xff) << 8)) & 0xffff}]
|
|
}
|
|
return $r
|
|
}
|
|
|
|
# Read off the NAME or QNAME element. This reads off each label in turn,
|
|
# dereferencing pointer labels until we have finished. The length of data
|
|
# used is passed back using the usedvar variable.
|
|
#
|
|
proc ::dns::ReadName {datavar index usedvar} {
|
|
upvar $datavar data
|
|
upvar $usedvar used
|
|
set startindex $index
|
|
|
|
set r {}
|
|
set len 1
|
|
set max [string length $data]
|
|
|
|
while {$len != 0 && $index < $max} {
|
|
# Read the label length (and preread the pointer offset)
|
|
binary scan [string range $data $index end] cc len lenb
|
|
set len [expr {$len & 0xFF}]
|
|
incr index
|
|
|
|
if {$len != 0} {
|
|
if {[expr {$len & 0xc0}]} {
|
|
binary scan [binary format cc [expr {$len & 0x3f}] [expr {$lenb & 0xff}]] S offset
|
|
incr index
|
|
lappend r [ReadName data $offset junk]
|
|
set len 0
|
|
} else {
|
|
lappend r [string range $data $index [expr {$index + $len - 1}]]
|
|
incr index $len
|
|
}
|
|
}
|
|
}
|
|
set used [expr {$index - $startindex}]
|
|
return [join $r .]
|
|
}
|
|
|
|
proc ::dns::ReadString {datavar index length} {
|
|
upvar $datavar data
|
|
set startindex $index
|
|
|
|
set r {}
|
|
set max [expr {$index + $length}]
|
|
|
|
while {$index < $max} {
|
|
binary scan [string range $data $index end] c len
|
|
set len [expr {$len & 0xFF}]
|
|
incr index
|
|
|
|
if {$len != 0} {
|
|
append r [string range $data $index [expr {$index + $len - 1}]]
|
|
incr index $len
|
|
}
|
|
}
|
|
return $r
|
|
}
|
|
|
|
# -------------------------------------------------------------------------
|
|
|
|
|
|
package provide dns $dns::version
|
|
|
|
# -------------------------------------------------------------------------
|
|
# Local Variables:
|
|
# indent-tabs-mode: nil
|
|
# End:
|