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