examples/dns.tcl

   1 # dns.tcl - Steve Bennett <steveb@workware.net.au>
   2 #
   3 # Modified for Jim Tcl to:
   4 # - use udp transport by default
   5 # - use sendto/recvfrom
   6 # - don't try to determine local nameservers
   7 # - remove support for dns uris and finding local nameservers
   8 # - remove logging calls
   9 #   (both of these in order to remove dependencies on tcllib)
  10
  11 # Based on:
  12
  13 # dns.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
  14 #
  15 # Provide a Tcl only Domain Name Service client. See RFC 1034 and RFC 1035
  16 # for information about the DNS protocol. This should insulate Tcl scripts
  17 # from problems with using the system library resolver for slow name servers.
  18 #
  19 # This implementation uses TCP only for DNS queries. The protocol reccommends
  20 # that UDP be used in these cases but Tcl does not include UDP sockets by
  21 # default. The package should be simple to extend to use a TclUDP extension
  22 # in the future.
  23 #
  24 # Support for SPF (http://spf.pobox.com/rfcs.html) will need updating
  25 # if or when the proposed draft becomes accepted.
  26 #
  27 # Support added for RFC1886 - DNS Extensions to support IP version 6
  28 # Support added for RFC2782 - DNS RR for specifying the location of services
  29 # Support added for RFC1995 - Incremental Zone Transfer in DNS
  30 #
  31 # TODO:
  32 #  - When using tcp we should make better use of the open connection and
  33 #    send multiple queries along the same connection.
  34 #
  35 #  - We must switch to using TCP for truncated UDP packets.
  36 #
  37 #  - Read RFC 2136 - dynamic updating of DNS
  38 #
  39 # -------------------------------------------------------------------------
  40 # See the file "license.terms" for information on usage and redistribution
  41 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  42 # -------------------------------------------------------------------------
  43 #
  44 # $Id: dns.tcl,v 1.36 2008/11/22 12:28:54 mic42 Exp $
  45
  46 package require binary
  47 package require namespace
  48
  49 namespace eval ::dns {
  50     variable version 1.3.3-jim2
  51     variable rcsid {$Id: dns.tcl,v 1.36 2008/11/22 12:28:54 mic42 Exp $}
  52
  53     namespace export configure resolve name address cname \
  54         status reset wait cleanup errorcode
  55
  56     variable options
  57     if {![info exists options]} {
  58         array set options {
  59             port       53
  60             timeout    30000
  61             protocol   udp
  62             search     {}
  63             nameserver {localhost}
  64             loglevel   warn
  65         }
  66         #variable log [logger::init dns]
  67         #${log}::setlevel $options(loglevel)
  68     }
  69
  70     variable types
  71     array set types {
  72         A 1  NS 2  MD 3  MF 4  CNAME 5  SOA 6  MB 7  MG 8  MR 9
  73         NULL 10  WKS 11  PTR 12  HINFO 13  MINFO 14  MX 15  TXT 16
  74         SPF 16 AAAA 28 SRV 33 IXFR 251 AXFR 252  MAILB 253  MAILA 254
  75         ANY 255 * 255
  76     }
  77
  78     variable classes
  79     array set classes { IN 1  CS 2  CH  3  HS 4  * 255}
  80
  81     variable uid
  82     if {![info exists uid]} {
  83         set uid 0
  84     }
  85 }
  86
  87 # -------------------------------------------------------------------------
  88
  89 # Description:
  90 #  Configure the DNS package. In particular the local nameserver will need
  91 #  to be set. With no options, returns a list of all current settings.
  92 #
  93 proc ::dns::configure {args} {
  94     variable options
  95     variable log
  96
  97     if {[llength $args] < 1} {
  98         set r {}
  99         foreach opt [lsort [array names options]] {
 100             lappend r -$opt $options($opt)
 101         }
 102         return $r
 103     }
 104
 105     set cget 0
 106     if {[llength $args] == 1} {
 107         set cget 1
 108     }
 109
 110     while {[string match -* [lindex $args 0]]} {
 111         switch -glob -- [lindex $args 0] {
 112             -n* -
 113             -ser* {
 114                 if {$cget} {
 115                     return $options(nameserver)
 116                 } else {
 117                     set options(nameserver) [Pop args 1]
 118                 }
 119             }
 120             -po*  {
 121                 if {$cget} {
 122                     return $options(port)
 123                 } else {
 124                     set options(port) [Pop args 1]
 125                 }
 126             }
 127             -ti*  {
 128                 if {$cget} {
 129                     return $options(timeout)
 130                 } else {
 131                     set options(timeout) [Pop args 1]
 132                 }
 133             }
 134             -pr*  {
 135                 if {$cget} {
 136                     return $options(protocol)
 137                 } else {
 138                     set proto [string tolower [Pop args 1]]
 139                     if {[string compare udp $proto] == 0 \
 140                             && [string compare tcp $proto] == 0} {
 141                         return -code error "invalid protocol \"$proto\":\
 142                             protocol must be either \"udp\" or \"tcp\""
 143                     }
 144                     set options(protocol) $proto
 145                 }
 146             }
 147             -sea* {
 148                 if {$cget} {
 149                     return $options(search)
 150                 } else {
 151                     set options(search) [Pop args 1]
 152                 }
 153             }
 154             -log* {
 155                 if {$cget} {
 156                     return $options(loglevel)
 157                 } else {
 158                     set options(loglevel) [Pop args 1]
 159                     ${log}::setlevel $options(loglevel)
 160                 }
 161             }
 162             --    { Pop args ; break }
 163             default {
 164                 set opts [join [lsort [array names options]] ", -"]
 165                 return -code error "bad option [lindex $args 0]:\
 166                         must be one of -$opts"
 167             }
 168         }
 169         Pop args
 170     }
 171
 172     return
 173 }
 174
 175 # -------------------------------------------------------------------------
 176
 177 # Description:
 178 #  Create a DNS query and send to the specified name server. Returns a token
 179 #  to be used to obtain any further information about this query.
 180 #
 181 proc ::dns::resolve {query args} {
 182     variable uid
 183     variable options
 184     variable log
 185
 186     # get a guaranteed unique and non-present token id.
 187     set id [incr uid]
 188     while {[info exists [set token [namespace current]::$id]]} {
 189         set id [incr uid]
 190     }
 191     # FRINK: nocheck
 192     variable $token
 193     upvar 0 $token state
 194
 195     # Setup token/state defaults.
 196     set state(id)          $id
 197     set state(query)       $query
 198     set state(qdata)       ""
 199     set state(opcode)      0;                   # 0 = query, 1 = inverse query.
 200     set state(-type)       A;                   # DNS record type (A address)
 201     set state(-class)      IN;                  # IN (internet address space)
 202     set state(-recurse)    1;                   # Recursion Desired
 203     set state(-command)    {};                  # asynchronous handler
 204     set state(-timeout)    $options(timeout);   # connection timeout default.
 205     set state(-nameserver) $options(nameserver);# default nameserver
 206     set state(-port)       $options(port);      # default namerservers port
 207     set state(-search)     $options(search);    # domain search list
 208     set state(-protocol)   $options(protocol);  # which protocol udp/tcp
 209
 210     # Support for DNS URL's removed
 211
 212     while {[string match -* [lindex $args 0]]} {
 213         switch -glob -- [lindex $args 0] {
 214             -n* - ns -
 215             -ser* { set state(-nameserver) [Pop args 1] }
 216             -po*  { set state(-port) [Pop args 1] }
 217             -ti*  { set state(-timeout) [Pop args 1] }
 218             -co*  { set state(-command) [Pop args 1] }
 219             -cl*  { set state(-class) [Pop args 1] }
 220             -ty*  { set state(-type) [Pop args 1] }
 221             -pr*  { set state(-protocol) [Pop args 1] }
 222             -sea* { set state(-search) [Pop args 1] }
 223             -re*  { set state(-recurse) [Pop args 1] }
 224             -inv* { set state(opcode) 1 }
 225             -status {set state(opcode) 2}
 226             -data { set state(qdata) [Pop args 1] }
 227             default {
 228                 set opts [join [lsort [array names state -*]] ", "]
 229                 return -code error "bad option [lindex $args 0]: \
 230                         must be $opts"
 231             }
 232         }
 233         Pop args
 234     }
 235
 236     if {$state(-nameserver) == {}} {
 237         return -code error "no nameserver specified"
 238     }
 239
 240     # Check for reverse lookups
 241     if {[regexp {^(?:\d{0,3}\.){3}\d{0,3}$} $state(query)]} {
 242         set addr [lreverse [split $state(query) .]]
 243         lappend addr in-addr arpa
 244         set state(query) [join $addr .]
 245         set state(-type) PTR
 246     }
 247
 248     BuildMessage $token
 249
 250     if {$state(-protocol) == "tcp"} {
 251         TcpTransmit $token
 252         if {$state(-command) == {}} {
 253             wait $token
 254         }
 255     } else {
 256         UdpTransmit $token
 257         wait $token
 258     }
 259
 260     return $token
 261 }
 262
 263 # -------------------------------------------------------------------------
 264
 265 # Description:
 266 #  Return a list of domain names returned as results for the last query.
 267 #
 268 proc ::dns::name {token} {
 269     set r {}
 270     Flags $token flags
 271     array set reply [Decode $token]
 272
 273     switch -exact -- $flags(opcode) {
 274         0 {
 275             # QUERY
 276             foreach answer $reply(AN) {
 277                 array set AN $answer
 278                 if {![info exists AN(type)]} {set AN(type) {}}
 279                 switch -exact -- $AN(type) {
 280                     MX - NS - PTR {
 281                         if {[info exists AN(rdata)]} {lappend r $AN(rdata)}
 282                     }
 283                     default {
 284                         if {[info exists AN(name)]} {
 285                             lappend r $AN(name)
 286                         }
 287                     }
 288                 }
 289             }
 290         }
 291
 292         1 {
 293             # IQUERY
 294             foreach answer $reply(QD) {
 295                 array set QD $answer
 296                 lappend r $QD(name)
 297             }
 298         }
 299         default {
 300             return -code error "not supported for this query type"
 301         }
 302     }
 303     return $r
 304 }
 305
 306 # Description:
 307 #  Return a list of the IP addresses returned for this query.
 308 #
 309 proc ::dns::address {token} {
 310     set r {}
 311     array set reply [Decode $token]
 312     foreach answer $reply(AN) {
 313         array set AN $answer
 314
 315         if {[info exists AN(type)]} {
 316             switch -exact -- $AN(type) {
 317                 "A" {
 318                     lappend r $AN(rdata)
 319                 }
 320                 "AAAA" {
 321                     lappend r $AN(rdata)
 322                 }
 323             }
 324         }
 325     }
 326     return $r
 327 }
 328
 329 # Description:
 330 #  Return a list of all CNAME results returned for this query.
 331 #
 332 proc ::dns::cname {token} {
 333     set r {}
 334     array set reply [Decode $token]
 335     foreach answer $reply(AN) {
 336         array set AN $answer
 337
 338         if {[info exists AN(type)]} {
 339             if {$AN(type) == "CNAME"} {
 340                 lappend r $AN(rdata)
 341             }
 342         }
 343     }
 344     return $r
 345 }
 346
 347 # Description:
 348 #   Return the decoded answer records. This can be used for more complex
 349 #   queries where the answer isn't supported byb cname/address/name.
 350 proc ::dns::result {token args} {
 351     array set reply [eval [linsert $args 0 Decode $token]]
 352     return $reply(AN)
 353 }
 354
 355 # -------------------------------------------------------------------------
 356
 357 # Description:
 358 #  Get the status of the request.
 359 #
 360 proc ::dns::status {token} {
 361     upvar #0 $token state
 362     return $state(status)
 363 }
 364
 365 # Description:
 366 #  Get the error message. Empty if no error.
 367 #
 368 proc ::dns::error {token} {
 369     upvar #0 $token state
 370     if {[info exists state(error)]} {
 371         return $state(error)
 372     }
 373     return ""
 374 }
 375
 376 # Description
 377 #  Get the error code. This is 0 for a successful transaction.
 378 #
 379 proc ::dns::errorcode {token} {
 380     upvar #0 $token state
 381     set flags [Flags $token]
 382     set ndx [lsearch -exact $flags errorcode]
 383     incr ndx
 384     return [lindex $flags $ndx]
 385 }
 386
 387 # Description:
 388 #  Reset a connection with optional reason.
 389 #
 390 proc ::dns::reset {token {why reset} {errormsg {}}} {
 391     upvar #0 $token state
 392     set state(status) $why
 393     if {[string length $errormsg] > 0 && ![info exists state(error)]} {
 394         set state(error) $errormsg
 395     }
 396     catch {fileevent $state(sock) readable {}}
 397     Finish $token
 398 }
 399
 400 # Description:
 401 #  Wait for a request to complete and return the status.
 402 #
 403 proc ::dns::wait {token} {
 404     upvar #0 $token state
 405
 406     if {$state(status) == "connect"} {
 407         vwait [subst $token](status)
 408     }
 409
 410     return $state(status)
 411 }
 412
 413 # Description:
 414 #  Remove any state associated with this token.
 415 #
 416 proc ::dns::cleanup {token} {
 417     upvar #0 $token state
 418     if {[info exists state]} {
 419         catch {close $state(sock)}
 420         catch {after cancel $state(after)}
 421         unset state
 422     }
 423 }
 424
 425 # -------------------------------------------------------------------------
 426
 427 # Description:
 428 #  Dump the raw data of the request and reply packets.
 429 #
 430 proc ::dns::dump {args} {
 431     if {[llength $args] == 1} {
 432         set type -reply
 433         set token [lindex $args 0]
 434     } elseif { [llength $args] == 2 } {
 435         set type [lindex $args 0]
 436         set token [lindex $args 1]
 437     } else {
 438         return -code error "wrong # args:\
 439             should be \"dump ?option? methodName\""
 440     }
 441
 442     # FRINK: nocheck
 443     variable $token
 444     upvar 0 $token state
 445
 446     set result {}
 447     switch -glob -- $type {
 448         -qu*    -
 449         -req*   {
 450             set result [DumpMessage $state(request)]
 451         }
 452         -rep*   {
 453             set result [DumpMessage $state(reply)]
 454         }
 455         default {
 456             error "unrecognised option: must be one of \
 457                     \"-query\", \"-request\" or \"-reply\""
 458         }
 459     }
 460
 461     return $result
 462 }
 463
 464 # Description:
 465 #  Perform a hex dump of binary data.
 466 #
 467 proc ::dns::DumpMessage {data} {
 468     set result {}
 469     binary scan $data c* r
 470     foreach c $r {
 471         append result [format "%02x " [expr {$c & 0xff}]]
 472     }
 473     return $result
 474 }
 475
 476 # -------------------------------------------------------------------------
 477
 478 # Description:
 479 #  Contruct a DNS query packet.
 480 #
 481 proc ::dns::BuildMessage {token} {
 482     # FRINK: nocheck
 483     variable $token
 484     upvar 0 $token state
 485     variable types
 486     variable classes
 487     variable options
 488
 489     if {! [info exists types($state(-type))] } {
 490         return -code error "invalid DNS query type"
 491     }
 492
 493     if {! [info exists classes($state(-class))] } {
 494         return -code error "invalid DNS query class"
 495     }
 496
 497     set qdcount 0
 498     set qsection {}
 499     set nscount 0
 500     set nsdata {}
 501
 502     # In theory we can send multiple queries. In practice, named doesn't
 503     # appear to like that much. If it did work we'd do this:
 504     #  foreach domain [linsert $options(search) 0 {}] ...
 505
 506
 507     # Pack the query: QNAME QTYPE QCLASS
 508     set qsection [PackName $state(query)]
 509     append qsection [binary format SS \
 510                          $types($state(-type))\
 511                          $classes($state(-class))]
 512     incr qdcount
 513
 514     if {[string length $state(qdata)] > 0} {
 515         set nsdata [eval [linsert $state(qdata) 0 PackRecord]]
 516         incr nscount
 517     }
 518
 519     switch -exact -- $state(opcode) {
 520         0 {
 521             # QUERY
 522             set state(request) [binary format SSSSSS $state(id) \
 523                 [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
 524                                     $qdcount 0 $nscount 0]
 525             append state(request) $qsection $nsdata
 526         }
 527         1 {
 528             # IQUERY
 529             set state(request) [binary format SSSSSS $state(id) \
 530                 [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
 531                 0 $qdcount 0 0 0]
 532             append state(request) \
 533                 [binary format cSSI 0 \
 534                      $types($state(-type)) $classes($state(-class)) 0]
 535             switch -exact -- $state(-type) {
 536                 A {
 537                     append state(request) \
 538                         [binary format Sc4 4 [split $state(query) .]]
 539                 }
 540                 PTR {
 541                     append state(request) \
 542                         [binary format Sc4 4 [split $state(query) .]]
 543                 }
 544                 default {
 545                     return -code error "inverse query not supported for this type"
 546                 }
 547             }
 548         }
 549         default {
 550             return -code error "operation not supported"
 551         }
 552     }
 553
 554     return
 555 }
 556
 557 # Pack a human readable dns name into a DNS resource record format.
 558 proc ::dns::PackName {name} {
 559     set data ""
 560     foreach part [split [string trim $name .] .] {
 561         set len [string length $part]
 562         append data [binary format ca$len $len $part]
 563     }
 564     append data \x00
 565     return $data
 566 }
 567
 568 # Pack a character string - byte length prefixed
 569 proc ::dns::PackString {text} {
 570     set len [string length $text]
 571     set data [binary format ca$len $len $text]
 572     return $data
 573 }
 574
 575 # Pack up a single DNS resource record. See RFC1035: 3.2 for the format
 576 # of each type.
 577 # eg: PackRecord name wiki.tcl.tk type MX class IN rdata {10 mail.example.com}
 578 #
 579 proc ::dns::PackRecord {args} {
 580     variable types
 581     variable classes
 582     array set rr {name "" type A class IN ttl 0 rdlength 0 rdata ""}
 583     array set rr $args
 584     set data [PackName $rr(name)]
 585
 586     switch -exact -- $rr(type) {
 587         CNAME - MB - MD - MF - MG - MR - NS - PTR {
 588             set rr(rdata) [PackName $rr(rdata)]
 589         }
 590         HINFO {
 591             array set r {CPU {} OS {}}
 592             array set r $rr(rdata)
 593             set rr(rdata) [PackString $r(CPU)]
 594             append rr(rdata) [PackString $r(OS)]
 595         }
 596         MINFO {
 597             array set r {RMAILBX {} EMAILBX {}}
 598             array set r $rr(rdata)
 599             set rr(rdata) [PackString $r(RMAILBX)]
 600             append rr(rdata) [PackString $r(EMAILBX)]
 601         }
 602         MX {
 603             foreach {pref exch} $rr(rdata) break
 604             set rr(rdata) [binary format S $pref]
 605             append rr(rdata) [PackName $exch]
 606         }
 607         TXT {
 608             set str $rr(rdata)
 609             set len [string length [set str $rr(rdata)]]
 610             set rr(rdata) ""
 611             for {set n 0} {$n < $len} {incr n} {
 612                 set s [string range $str $n [incr n 253]]
 613                 append rr(rdata) [PackString $s]
 614             }
 615         }
 616         NULL {}
 617         SOA {
 618             array set r {MNAME {} RNAME {}
 619                 SERIAL 0 REFRESH 0 RETRY 0 EXPIRE 0 MINIMUM 0}
 620             array set r $rr(rdata)
 621             set rr(rdata) [PackName $r(MNAME)]
 622             append rr(rdata) [PackName $r(RNAME)]
 623             append rr(rdata) [binary format IIIII $r(SERIAL) \
 624                                   $r(REFRESH) $r(RETRY) $r(EXPIRE) $r(MINIMUM)]
 625         }
 626     }
 627
 628     # append the root label and the type flag and query class.
 629     append data [binary format SSIS $types($rr(type)) \
 630                      $classes($rr(class)) $rr(ttl) [string length $rr(rdata)]]
 631     append data $rr(rdata)
 632     return $data
 633 }
 634
 635 # -------------------------------------------------------------------------
 636
 637 # Description:
 638 #  Transmit a DNS request over a tcp connection.
 639 #
 640 proc ::dns::TcpTransmit {token} {
 641     # FRINK: nocheck
 642     variable $token
 643     upvar 0 $token state
 644
 645     # setup the timeout
 646     if {$state(-timeout) > 0} {
 647         set state(after) [after $state(-timeout) \
 648                               [list [namespace origin reset] \
 649                                    $token timeout\
 650                                    "operation timed out"]]
 651     }
 652
 653     # Jim Tcl has no async connect ...
 654
 655     set s [socket stream $state(-nameserver):$state(-port)]
 656     fileevent $s writable [list [namespace origin TcpConnected] $token $s]
 657     set state(sock) $s
 658     set state(status) connect
 659
 660     return $token
 661 }
 662
 663 proc ::dns::TcpConnected {token s} {
 664     variable $token
 665     upvar 0 $token state
 666
 667     fileevent $s writable {}
 668
 669     # Jim Tcl has no async connect ...
 670 #    if {[catch {fconfigure $s -peername}]} {
 671 #       # TCP connection failed
 672 #        Finish $token "can't connect to server"
 673 #       return
 674 #    }
 675
 676     fconfigure $s -blocking 0 -translation binary -buffering none
 677
 678     # For TCP the message must be prefixed with a 16bit length field.
 679     set req [binary format S [string length $state(request)]]
 680     append req $state(request)
 681
 682     puts -nonewline $s $req
 683
 684     fileevent $s readable [list [namespace current]::TcpEvent $token]
 685 }
 686
 687 # -------------------------------------------------------------------------
 688 # Description:
 689 #  Transmit a DNS request using UDP datagrams
 690 #
 691 # Note:
 692 #  This requires a UDP implementation that can transmit binary data.
 693 #  As yet I have been unable to test this myself and the tcludp package
 694 #  cannot do this.
 695 #
 696 proc ::dns::UdpTransmit {token} {
 697     # FRINK: nocheck
 698     variable $token
 699     upvar 0 $token state
 700
 701     # setup the timeout
 702     if {$state(-timeout) > 0} {
 703         set state(after) [after $state(-timeout) \
 704                               [list [namespace origin reset] \
 705                                    $token timeout\
 706                                   "operation timed out"]]
 707     }
 708
 709     set state(sock) [socket dgram]
 710     #fconfigure $state(sock) -translation binary -buffering none
 711     set state(status) connect
 712     $state(sock) sendto $state(request) $state(-nameserver):$state(-port)
 713
 714     fileevent $state(sock) readable [list [namespace current]::UdpEvent $token]
 715
 716     return $token
 717 }
 718
 719 # -------------------------------------------------------------------------
 720
 721 # Description:
 722 #  Tidy up after a tcp transaction.
 723 #
 724 proc ::dns::Finish {token {errormsg ""}} {
 725     # FRINK: nocheck
 726     variable $token
 727     upvar 0 $token state
 728     global errorInfo errorCode
 729
 730     if {[string length $errormsg] != 0} {
 731         set state(error) $errormsg
 732         set state(status) error
 733     }
 734     catch {close $state(sock)}
 735     catch {after cancel $state(after)}
 736     if {[info exists state(-command)] && $state(-command) != {}} {
 737         if {[catch {eval $state(-command) {$token}} err]} {
 738             if {[string length $errormsg] == 0} {
 739                 set state(error) [list $err $errorInfo $errorCode]
 740                 set state(status) error
 741             }
 742         }
 743         if {[info exists state(-command)]} {
 744             unset state(-command)
 745         }
 746     }
 747 }
 748
 749 # -------------------------------------------------------------------------
 750
 751 # Description:
 752 #  Handle end-of-file on a tcp connection.
 753 #
 754 proc ::dns::Eof {token} {
 755     # FRINK: nocheck
 756     variable $token
 757     upvar 0 $token state
 758     set state(status) eof
 759     Finish $token
 760 }
 761
 762 # -------------------------------------------------------------------------
 763
 764 # Description:
 765 #  Process a DNS reply packet (protocol independent)
 766 #
 767 proc ::dns::Receive {token} {
 768     # FRINK: nocheck
 769     variable $token
 770     upvar 0 $token state
 771
 772     binary scan $state(reply) SS id flags
 773     set status [expr {$flags & 0x000F}]
 774
 775     switch -- $status {
 776         0 {
 777             set state(status) ok
 778             Finish $token
 779         }
 780         1 { Finish $token "Format error - unable to interpret the query." }
 781         2 { Finish $token "Server failure - internal server error." }
 782         3 { Finish $token "Name Error - domain does not exist" }
 783         4 { Finish $token "Not implemented - the query type is not available." }
 784         5 { Finish $token "Refused - your request has been refused by the server." }
 785         default {
 786             Finish $token "unrecognised error code: $err"
 787         }
 788     }
 789 }
 790
 791 # -------------------------------------------------------------------------
 792
 793 # Description:
 794 #  file event handler for tcp socket. Wait for the reply data.
 795 #
 796 proc ::dns::TcpEvent {token} {
 797     variable log
 798     # FRINK: nocheck
 799     variable $token
 800     upvar 0 $token state
 801     set s $state(sock)
 802
 803     if {[eof $s]} {
 804         Eof $token
 805         return
 806     }
 807
 808     set status [catch {read $state(sock)} result]
 809     if {$status != 0} {
 810         ${log}::debug "Event error: $result"
 811         Finish $token "error reading data: $result"
 812     } elseif { [string length $result] >= 0 } {
 813         if {[catch {
 814             # Handle incomplete reads - check the size and keep reading.
 815             if {![info exists state(size)]} {
 816                 binary scan $result S state(size)
 817                 set result [string range $result 2 end]
 818             }
 819             append state(reply) $result
 820
 821             # check the length and flags and chop off the tcp length prefix.
 822             if {[string length $state(reply)] >= $state(size)} {
 823                 binary scan $result S id
 824                 set id [expr {$id & 0xFFFF}]
 825                 if {$id != [expr {$state(id) & 0xFFFF}]} {
 826                     ${log}::error "received packed with incorrect id"
 827                 }
 828                 # bug #1158037 - doing this causes problems > 65535 requests!
 829                 #Receive [namespace current]::$id
 830                 Receive $token
 831             } else {
 832                 ${log}::debug "Incomplete tcp read:\
 833                    [string length $state(reply)] should be $state(size)"
 834             }
 835         } err]} {
 836             Finish $token "Event error: $err"
 837         }
 838     } elseif { [eof $state(sock)] } {
 839         Eof $token
 840     } elseif { [fblocked $state(sock)] } {
 841         ${log}::debug "Event blocked"
 842     } else {
 843         ${log}::critical "Event error: this can't happen!"
 844         Finish $token "Event error: this can't happen!"
 845     }
 846 }
 847
 848 # -------------------------------------------------------------------------
 849
 850 # Description:
 851 #  file event handler for udp sockets.
 852 proc ::dns::UdpEvent {token} {
 853     # FRINK: nocheck
 854     variable $token
 855     upvar 0 $token state
 856     set s $state(sock)
 857
 858     set payload [$state(sock) recvfrom 1500]
 859     append state(reply) $payload
 860
 861     binary scan $payload S id
 862     set id [expr {$id & 0xFFFF}]
 863     if {$id != [expr {$state(id) & 0xFFFF}]} {
 864         ${log}::error "received packed with incorrect id"
 865     }
 866     # bug #1158037 - doing this causes problems > 65535 requests!
 867     #Receive [namespace current]::$id
 868     Receive $token
 869 }
 870
 871 # -------------------------------------------------------------------------
 872
 873 proc ::dns::Flags {token {varname {}}} {
 874     # FRINK: nocheck
 875     variable $token
 876     upvar 0 $token state
 877
 878     if {$varname != {}} {
 879         upvar $varname flags
 880     }
 881
 882     array set flags {query 0 opcode 0 authoritative 0 errorcode 0
 883         truncated 0 recursion_desired 0 recursion_allowed 0}
 884
 885     binary scan $state(reply) SSSSSS mid hdr nQD nAN nNS nAR
 886
 887     set flags(response)           [expr {($hdr & 0x8000) >> 15}]
 888     set flags(opcode)             [expr {($hdr & 0x7800) >> 11}]
 889     set flags(authoritative)      [expr {($hdr & 0x0400) >> 10}]
 890     set flags(truncated)          [expr {($hdr & 0x0200) >> 9}]
 891     set flags(recursion_desired)  [expr {($hdr & 0x0100) >> 8}]
 892     set flags(recursion_allowed)  [expr {($hdr & 0x0080) >> 7}]
 893     set flags(errorcode)          [expr {($hdr & 0x000F)}]
 894
 895     return [array get flags]
 896 }
 897
 898 # -------------------------------------------------------------------------
 899
 900 # Description:
 901 #  Decode a DNS packet (either query or response).
 902 #
 903 proc ::dns::Decode {token args} {
 904     variable log
 905     # FRINK: nocheck
 906     variable $token
 907     upvar 0 $token state
 908
 909     array set opts {-rdata 0 -query 0}
 910     while {[string match -* [set option [lindex $args 0]]]} {
 911         switch -exact -- $option {
 912             -rdata { set opts(-rdata) 1 }
 913             -query { set opts(-query) 1 }
 914             default {
 915                 return -code error "bad option \"$option\":\
 916                     must be -rdata"
 917             }
 918         }
 919         Pop args
 920     }
 921
 922     if {$opts(-query)} {
 923         binary scan $state(request) SSSSSSc* mid hdr nQD nAN nNS nAR data
 924     } else {
 925         binary scan $state(reply) SSSSSSc* mid hdr nQD nAN nNS nAR data
 926     }
 927
 928     set fResponse      [expr {($hdr & 0x8000) >> 15}]
 929     set fOpcode        [expr {($hdr & 0x7800) >> 11}]
 930     set fAuthoritative [expr {($hdr & 0x0400) >> 10}]
 931     set fTrunc         [expr {($hdr & 0x0200) >> 9}]
 932     set fRecurse       [expr {($hdr & 0x0100) >> 8}]
 933     set fCanRecurse    [expr {($hdr & 0x0080) >> 7}]
 934     set fRCode         [expr {($hdr & 0x000F)}]
 935     set flags ""
 936
 937     if {$fResponse} {set flags "QR"} else {set flags "Q"}
 938     set opcodes [list QUERY IQUERY STATUS]
 939     lappend flags [lindex $opcodes $fOpcode]
 940     if {$fAuthoritative} {lappend flags "AA"}
 941     if {$fTrunc} {lappend flags "TC"}
 942     if {$fRecurse} {lappend flags "RD"}
 943     if {$fCanRecurse} {lappend flags "RA"}
 944
 945     set info "ID: $mid\
 946               Fl: [format 0x%02X [expr {$hdr & 0xFFFF}]] ($flags)\
 947               NQ: $nQD\
 948               NA: $nAN\
 949               NS: $nNS\
 950               AR: $nAR"
 951     #${log}::debug $info
 952
 953     set ndx 12
 954     set r {}
 955     set QD [ReadQuestion $nQD $state(reply) ndx]
 956     lappend r QD $QD
 957     set AN [ReadAnswer $nAN $state(reply) ndx $opts(-rdata)]
 958     lappend r AN $AN
 959     set NS [ReadAnswer $nNS $state(reply) ndx $opts(-rdata)]
 960     lappend r NS $NS
 961     set AR [ReadAnswer $nAR $state(reply) ndx $opts(-rdata)]
 962     lappend r AR $AR
 963     return $r
 964 }
 965
 966 # -------------------------------------------------------------------------
 967
 968 proc ::dns::Expand {data} {
 969     set r {}
 970     binary scan $data c* d
 971     foreach c $d {
 972         lappend r [expr {$c & 0xFF}]
 973     }
 974     return $r
 975 }
 976
 977
 978 # -------------------------------------------------------------------------
 979 # Description:
 980 #  Pop the nth element off a list. Used in options processing.
 981 #
 982 proc ::dns::Pop {varname {nth 0}} {
 983     upvar $varname args
 984     set r [lindex $args $nth]
 985     set args [lreplace $args $nth $nth]
 986     return $r
 987 }
 988
 989 # -------------------------------------------------------------------------
 990
 991 proc ::dns::KeyOf {arrayname value {default {}}} {
 992     upvar $arrayname array
 993     set lst [array get array]
 994     set ndx [lsearch -exact $lst $value]
 995     if {$ndx != -1} {
 996         incr ndx -1
 997         set r [lindex $lst $ndx]
 998     } else {
 999         set r $default
1000     }
1001     return $r
1002 }
1003
1004
1005 # -------------------------------------------------------------------------
1006 # Read the question section from a DNS message. This always starts at index
1007 # 12 of a message but may be of variable length.
1008 #
1009 proc ::dns::ReadQuestion {nitems data indexvar} {
1010     variable types
1011     variable classes
1012     upvar $indexvar index
1013     set result {}
1014
1015     for {set cn 0} {$cn < $nitems} {incr cn} {
1016         set r {}
1017         lappend r name [ReadName data $index offset]
1018         incr index $offset
1019
1020         # Read off QTYPE and QCLASS for this query.
1021         set ndx $index
1022         incr index 3
1023         binary scan [string range $data $ndx $index] SS qtype qclass
1024         set qtype [expr {$qtype & 0xFFFF}]
1025         set qclass [expr {$qclass & 0xFFFF}]
1026         incr index
1027         lappend r type [KeyOf types $qtype $qtype] \
1028                   class [KeyOf classes $qclass $qclass]
1029         lappend result $r
1030     }
1031     return $result
1032 }
1033
1034 # -------------------------------------------------------------------------
1035
1036 # Read an answer section from a DNS message.
1037 #
1038 proc ::dns::ReadAnswer {nitems data indexvar {raw 0}} {
1039     variable types
1040     variable classes
1041     upvar $indexvar index
1042     set result {}
1043
1044     for {set cn 0} {$cn < $nitems} {incr cn} {
1045         set r {}
1046         lappend r name [ReadName data $index offset]
1047         incr index $offset
1048
1049         # Read off TYPE, CLASS, TTL and RDLENGTH
1050         binary scan [string range $data $index end] SSIS type class ttl rdlength
1051
1052         set type [expr {$type & 0xFFFF}]
1053         set type [KeyOf types $type $type]
1054
1055         set class [expr {$class & 0xFFFF}]
1056         set class [KeyOf classes $class $class]
1057
1058         set ttl [expr {$ttl & 0xFFFFFFFF}]
1059         set rdlength [expr {$rdlength & 0xFFFF}]
1060         incr index 10
1061         set rdata [string range $data $index [expr {$index + $rdlength - 1}]]
1062
1063         if {! $raw} {
1064             switch -- $type {
1065                 A {
1066                     set rdata [join [Expand $rdata] .]
1067                 }
1068                 AAAA {
1069                     set rdata [ip::contract [ip::ToString $rdata]]
1070                 }
1071                 NS - CNAME - PTR {
1072                     set rdata [ReadName data $index off]
1073                 }
1074                 MX {
1075                     binary scan $rdata S preference
1076                     set exchange [ReadName data [expr {$index + 2}] off]
1077                     set rdata [list $preference $exchange]
1078                 }
1079                 SRV {
1080                     set x $index
1081                     set rdata [list priority [ReadUShort data $x off]]
1082                     incr x $off
1083                     lappend rdata weight [ReadUShort data $x off]
1084                     incr x $off
1085                     lappend rdata port [ReadUShort data $x off]
1086                     incr x $off
1087                     lappend rdata target [ReadName data $x off]
1088                     incr x $off
1089                 }
1090                 TXT {
1091                     set rdata [ReadString data $index $rdlength]
1092                 }
1093                 SOA {
1094                     set x $index
1095                     set rdata [list MNAME [ReadName data $x off]]
1096                     incr x $off
1097                     lappend rdata RNAME [ReadName data $x off]
1098                     incr x $off
1099                     lappend rdata SERIAL [ReadULong data $x off]
1100                     incr x $off
1101                     lappend rdata REFRESH [ReadLong data $x off]
1102                     incr x $off
1103                     lappend rdata RETRY [ReadLong data $x off]
1104                     incr x $off
1105                     lappend rdata EXPIRE [ReadLong data $x off]
1106                     incr x $off
1107                     lappend rdata MINIMUM [ReadULong data $x off]
1108                     incr x $off
1109                 }
1110             }
1111         }
1112
1113         incr index $rdlength
1114         lappend r type $type class $class ttl $ttl rdlength $rdlength rdata $rdata
1115         lappend result $r
1116     }
1117     return $result
1118 }
1119
1120
1121 # Read a 32bit integer from a DNS packet. These are compatible with
1122 # the ReadName proc. Additionally - ReadULong takes measures to ensure
1123 # the unsignedness of the value obtained.
1124 #
1125 proc ::dns::ReadLong {datavar index usedvar} {
1126     upvar $datavar data
1127     upvar $usedvar used
1128     set r {}
1129     set used 0
1130     if {[binary scan $data @${index}I r]} {
1131         set used 4
1132     }
1133     return $r
1134 }
1135
1136 proc ::dns::ReadULong {datavar index usedvar} {
1137     upvar $datavar data
1138     upvar $usedvar used
1139     set r {}
1140     set used 0
1141     if {[binary scan $data @${index}cccc b1 b2 b3 b4]} {
1142         set used 4
1143         # This gets us an unsigned value.
1144         set r [expr {($b4 & 0xFF) + (($b3 & 0xFF) << 8)
1145                      + (($b2 & 0xFF) << 16) + ($b1 << 24)}]
1146     }
1147     return $r
1148 }
1149
1150 proc ::dns::ReadUShort {datavar index usedvar} {
1151     upvar $datavar data
1152     upvar $usedvar used
1153     set r {}
1154     set used 0
1155     if {[binary scan [string range $data $index end] cc b1 b2]} {
1156         set used 2
1157         # This gets us an unsigned value.
1158         set r [expr {(($b2 & 0xff) + (($b1 & 0xff) << 8)) & 0xffff}]
1159     }
1160     return $r
1161 }
1162
1163 # Read off the NAME or QNAME element. This reads off each label in turn,
1164 # dereferencing pointer labels until we have finished. The length of data
1165 # used is passed back using the usedvar variable.
1166 #
1167 proc ::dns::ReadName {datavar index usedvar} {
1168     upvar $datavar data
1169     upvar $usedvar used
1170     set startindex $index
1171
1172     set r {}
1173     set len 1
1174     set max [string length $data]
1175
1176     while {$len != 0 && $index < $max} {
1177         # Read the label length (and preread the pointer offset)
1178         binary scan [string range $data $index end] cc len lenb
1179         set len [expr {$len & 0xFF}]
1180         incr index
1181
1182         if {$len != 0} {
1183             if {[expr {$len & 0xc0}]} {
1184                 binary scan [binary format cc [expr {$len & 0x3f}] [expr {$lenb & 0xff}]] S offset
1185                 incr index
1186                 lappend r [ReadName data $offset junk]
1187                 set len 0
1188             } else {
1189                 lappend r [string range $data $index [expr {$index + $len - 1}]]
1190                 incr index $len
1191             }
1192         }
1193     }
1194     set used [expr {$index - $startindex}]
1195     return [join $r .]
1196 }
1197
1198 proc ::dns::ReadString {datavar index length} {
1199     upvar $datavar data
1200     set startindex $index
1201
1202     set r {}
1203     set max [expr {$index + $length}]
1204
1205     while {$index < $max} {
1206         binary scan [string range $data $index end] c len
1207         set len [expr {$len & 0xFF}]
1208         incr index
1209
1210         if {$len != 0} {
1211             append r [string range $data $index [expr {$index + $len - 1}]]
1212             incr index $len
1213         }
1214     }
1215     return $r
1216 }
1217
1218 # -------------------------------------------------------------------------
1219
1220
1221 package provide dns $dns::version
1222
1223 # -------------------------------------------------------------------------
1224 # Local Variables:
1225 #   indent-tabs-mode: nil
1226 # End: