From b9a0bdb13db165e0ba8971998dad6e1e77bb883e Mon Sep 17 00:00:00 2001 From: Steve Bennett Date: Thu, 26 May 2011 15:47:17 +1000 Subject: Add a dns/binary example This is take from the tcllib dns package and shows the high level of compatibility with Tcl. Signed-off-by: Steve Bennett --- examples/dns.tcl | 1206 ++++++++++++++++++++++++++++++++++++++++++++++++++ examples/dnstest.tcl | 22 + 2 files changed, 1228 insertions(+) create mode 100644 examples/dns.tcl create mode 100644 examples/dnstest.tcl (limited to 'examples') diff --git a/examples/dns.tcl b/examples/dns.tcl new file mode 100644 index 0000000..bc17762 --- /dev/null +++ b/examples/dns.tcl @@ -0,0 +1,1206 @@ +# dns.tcl - Steve Bennett +# +# Modified for Jim Tcl to: +# - use udp transport by default +# - use sendto/recvfrom +# - remove use of namespaces +# - remove support for dns uris and finding local nameservers + +# Based on: + +# dns.tcl - Copyright (C) 2002 Pat Thoyts +# +# 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 + +# Poor-man's variable for Jim Tcl +# Links a global variable, ::ns::var to a local variable, var +proc variable {ns var} { + uplevel 1 [list upvar #0 ${ns}::$var $var] +} + +set dns::version 1.3.3 +set dns::rcsid {$Id: dns.tcl,v 1.36 2008/11/22 12:28:54 mic42 Exp $} + +array set dns::options { + port 53 + timeout 30000 + protocol udp + search {} + nameserver {localhost} + loglevel warn +} + +array set dns::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 +} + +array set dns::classes { IN 1 CS 2 CH 3 HS 4 * 255} + +if {![info exists dns::uid]} { + set dns::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 dns options + variable dns 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) [dns::Pop args 1] + } + } + -po* { + if {$cget} { + return $options(port) + } else { + set options(port) [dns::Pop args 1] + } + } + -ti* { + if {$cget} { + return $options(timeout) + } else { + set options(timeout) [dns::Pop args 1] + } + } + -pr* { + if {$cget} { + return $options(protocol) + } else { + set proto [string tolower [dns::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) [dns::Pop args 1] + } + } + -log* { + if {$cget} { + return $options(loglevel) + } else { + set options(loglevel) [dns::Pop args 1] + ${log}::setlevel $options(loglevel) + } + } + -- { dns::Pop args ; break } + default { + set opts [join [lsort [array names options]] ", -"] + return -code error "bad option [lindex $args 0]:\ + must be one of -$opts" + } + } + dns::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 dns uid + variable dns options + variable dns log + + # get a guaranteed unique and non-present token id. + set id [incr uid] + while {[info exists [set token ::dns::$id]]} { + set id [incr uid] + } + # FRINK: nocheck + 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 + + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -n* - ns - + -ser* { set state(-nameserver) [dns::Pop args 1] } + -po* { set state(-port) [dns::Pop args 1] } + -ti* { set state(-timeout) [dns::Pop args 1] } + -co* { set state(-command) [dns::Pop args 1] } + -cl* { set state(-class) [dns::Pop args 1] } + -ty* { set state(-type) [dns::Pop args 1] } + -pr* { set state(-protocol) [dns::Pop args 1] } + -sea* { set state(-search) [dns::Pop args 1] } + -re* { set state(-recurse) [dns::Pop args 1] } + -inv* { set state(opcode) 1 } + -status {set state(opcode) 2} + -data { set state(qdata) [dns::Pop args 1] } + default { + set opts [join [lsort [array names state -*]] ", "] + return -code error "bad option [lindex $args 0]: \ + must be $opts" + } + } + dns::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 +# } + + dns::BuildMessage $token + + if {$state(-protocol) == "tcp"} { + dns::TcpTransmit $token + if {$state(-command) == {}} { + dns::wait $token + } + } else { + dns::UdpTransmit $token + dns::wait $token + } + + return $token +} + +# ------------------------------------------------------------------------- + +# Description: +# Return a list of domain names returned as results for the last query. +# +proc dns::name {token} { + set r {} + dns::Flags $token flags + array set reply [dns::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 [dns::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 [dns::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 dns::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 [dns::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 {}} + dns::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 dns $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 dns $token + upvar 0 $token state + variable dns types + variable dns classes + variable dns 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 [dns::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 dns types + variable dns classes + array set rr {name "" type A class IN ttl 0 rdlength 0 rdata ""} + array set rr $args + set data [dns::PackName $rr(name)] + + switch -exact -- $rr(type) { + CNAME - MB - MD - MF - MG - MR - NS - PTR { + set rr(rdata) [dns::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) [dns::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) [dns::PackName $r(MNAME)] + append rr(rdata) [dns::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 dns $token + upvar 0 $token state + + # setup the timeout + if {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) \ + [list dns::reset \ + $token timeout\ + "operation timed out"]] + } + + set s [socket stream $state(-nameserver):$state(-port)] + fileevent $s writable [list dns::TcpConnected $token $s] + set state(sock) $s + set state(status) connect + + return $token +} + +proc dns::TcpConnected {token s} { + variable dns $token + upvar 0 $token state + + fileevent $s writable {} + +# if {[catch {fconfigure $s -peername}]} { +# # TCP connection failed +# dns::Finish $token "can't connect to server" +# return +# } + +# fconfigure $s -blocking 0 -translation binary -buffering none + $s ndelay 1 + + # 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 + $s flush + + fileevent $s readable [list dns::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 dns $token + upvar 0 $token state + + # setup the timeout + if {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) \ + [list dns::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 dns::UdpEvent $token] + + return $token +} + +# ------------------------------------------------------------------------- + +# Description: +# Tidy up after a tcp transaction. +# +proc dns::Finish {token {errormsg ""}} { + # FRINK: nocheck + variable dns $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 dns $token + upvar 0 $token state + set state(status) eof + dns::Finish $token +} + +# ------------------------------------------------------------------------- + +# Description: +# Process a DNS reply packet (protocol independent) +# +proc dns::Receive {token} { + # FRINK: nocheck + variable dns $token + upvar 0 $token state + + binary scan $state(reply) SS id flags + set status [expr {$flags & 0x000F}] + + switch -- $status { + 0 { + set state(status) ok + dns::Finish $token + } + 1 { dns::Finish $token "Format error - unable to interpret the query." } + 2 { dns::Finish $token "Server failure - internal server error." } + 3 { dns::Finish $token "Name Error - domain does not exist" } + 4 { dns::Finish $token "Not implemented - the query type is not available." } + 5 { dns::Finish $token "Refused - your request has been refused by the server." } + default { + dns::Finish $token "unrecognised error code: $err" + } + } +} + +# ------------------------------------------------------------------------- + +# Description: +# file event handler for tcp socket. Wait for the reply data. +# +proc dns::TcpEvent {token} { + variable dns log + # FRINK: nocheck + variable dns $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" + dns::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 dns::$id + dns::Receive $token + } else { + ${log}::debug "Incomplete tcp read:\ + [string length $state(reply)] should be $state(size)" + } + } err]} { + dns::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!" + dns::Finish $token "Event error: this can't happen!" + } +} + +# ------------------------------------------------------------------------- + +# Description: +# file event handler for udp sockets. +proc dns::UdpEvent {token} { + # FRINK: nocheck + variable dns $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! + #dns::Receive dns::$id + dns::Receive $token +} + +# ------------------------------------------------------------------------- + +proc dns::Flags {token {varname {}}} { + # FRINK: nocheck + variable dns $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 dns log + # FRINK: nocheck + variable dns $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" + } + } + dns::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" + #puts $info + + set ndx 12 + set r {} + set QD [dns::ReadQuestion $nQD $state(reply) ndx] + lappend r QD $QD + set AN [dns::ReadAnswer $nAN $state(reply) ndx $opts(-rdata)] + lappend r AN $AN + set NS [dns::ReadAnswer $nNS $state(reply) ndx $opts(-rdata)] + lappend r NS $NS + set AR [dns::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 {&list {nth 0}} { + set r [lindex $list $nth] + set list [lreplace $list $nth $nth] + return $r +} + +# ------------------------------------------------------------------------- + +proc dns::KeyOf {&array value {default {}}} { + try { + dict get [lreverse $array] $value + } on error msg { + return $default + } +} + + +# ------------------------------------------------------------------------- +# 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 dns types + variable dns classes + upvar $indexvar index + set result {} + + for {set cn 0} {$cn < $nitems} {incr cn} { + set r {} + lappend r name [dns::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 [dns::KeyOf types $qtype $qtype] \ + class [dns::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 dns types + variable dns classes + upvar $indexvar index + set result {} + + for {set cn 0} {$cn < $nitems} {incr cn} { + set r {} + lappend r name [dns::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 [dns::KeyOf types $type $type] + + set class [expr {$class & 0xFFFF}] + set class [dns::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 [dns::Expand $rdata] .] + } + AAAA { + set rdata [ip::contract [ip::ToString $rdata]] + } + NS - CNAME - PTR { + set rdata [dns::ReadName data $index off] + } + MX { + binary scan $rdata S preference + set exchange [dns::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 [dns::ReadName data $x off] + incr x $off + } + TXT { + set rdata [ReadString data $index $rdlength] + } + SOA { + set x $index + set rdata [list MNAME [dns::ReadName data $x off]] + incr x $off + lappend rdata RNAME [dns::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 [dns::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 +} + +# ------------------------------------------------------------------------- + +catch {dns::configure -nameserver [lindex [dns::nameservers] 0]} + +# ------------------------------------------------------------------------- +# Local Variables: +# indent-tabs-mode: nil +# End: diff --git a/examples/dnstest.tcl b/examples/dnstest.tcl new file mode 100644 index 0000000..905ecb8 --- /dev/null +++ b/examples/dnstest.tcl @@ -0,0 +1,22 @@ +lappend auto_path [pwd] +package require dns + +# Use google's DNS +dns::configure -nameserver 8.8.8.8 + +puts "Resolve with udp" +set tok [dns::resolve www.tcl.tk] +puts status=[dns::status $tok] +puts address=[dns::address $tok] +puts names=[dns::name $tok] +dns::cleanup $tok + +# Now with tcp +dns::configure -protocol tcp + +puts "Resolve with tcp" +set tok [dns::resolve www.google.com] +puts status=[dns::status $tok] +puts address=[dns::address $tok] +puts names=[dns::name $tok] +dns::cleanup $tok -- cgit v1.1