Posted to tcl by colin at Tue Aug 28 23:09:36 GMT 2012view raw

  1. # dns query using Udp extension
  2. # Colin McCormack
  3.  
  4. lappend auto_path [pwd]/Udp
  5. package require Udp
  6. package require TclOO
  7. package provide Dns 1.1
  8.  
  9. oo::class create DNS {
  10. method decodeName {varname} {
  11. upvar 1 $varname text
  12. set line {}
  13. set suffix ""
  14. while {$text ne ""} {
  15. binary scan $text ca* len text
  16. if {$len < 0} {
  17. # compression
  18. binary scan $text ca* offset text
  19. set offset [expr {($len & 0x3F)<<8 | ($offset & 0xFF)}]
  20. variable response
  21. set reference [string range $response $offset end]
  22. set suffix .[my decodeName reference]
  23. break
  24. } elseif {$len} {
  25. lappend line [string range $text 0 $len-1]
  26. set text [string range $text $len end]
  27. } else {
  28. break
  29. }
  30. }
  31. return [join $line .]$suffix
  32. }
  33.  
  34. method decodeQD {varname qdcount} {
  35. upvar 1 $varname text
  36. set result {}
  37. while {$qdcount} {
  38. incr qdcount -1
  39. set name [my decodeName text]
  40. binary scan $text SSa* qtype qclass text
  41. lappend result [list $name $qtype $qclass]
  42. }
  43. return $result
  44. }
  45.  
  46. method decodeAddress {address} {
  47. catch {
  48. binary scan $address cccc a1 a2 a3 a4
  49. foreach v {a1 a2 a3 a4} {
  50. set $v [expr { [set $v] & 0xff }]
  51. }
  52. set result [join [list $a1 $a2 $a3 $a4] .]
  53. } e eo
  54. return $result
  55. }
  56.  
  57. method rdA {rd} {
  58. # a host address
  59. return [my decodeAddress $rd]
  60. }
  61.  
  62. method rdNS {rd} {
  63. # an authoritative name server
  64. return [my decodeName rd]
  65. }
  66.  
  67. method rdMD {rd} {
  68. # a mail destination (Obsolete - use MX)
  69. return [my decodeName rd]
  70. }
  71.  
  72. method rdMF {rd} {
  73. # a mail forwarder (Obsolete - use MX)
  74. return [my decodeName rd]
  75. }
  76.  
  77. method rdCNAME {rd} {
  78. # the canonical name for an alias
  79. return [my decodeName rd]
  80. }
  81.  
  82. method rdSOA {rd} {
  83. # marks the start of a zone of authority
  84. set mname [my decodeName rd]
  85. set rname [my decodeName rd]
  86. binary scan $rd IIIII serial refresh retry expire minimum
  87. return [list mname $mname rname $rname serial $serial refresh $refresh retry $retry expire $expire minimum $minimum]
  88. }
  89.  
  90. method rdMB {rd} {
  91. # a mailbox domain name (EXPERIMENTAL)
  92. return [my decodeName rd]
  93. }
  94.  
  95. method rdMG {rd} {
  96. # a mail group member (EXPERIMENTAL)
  97. return [my decodeName rd]
  98. }
  99.  
  100. method rdMR {rd} {
  101. # a mail rename domain name (EXPERIMENTAL)
  102. return [my decodeName rd]
  103. }
  104.  
  105. method rdNULL {rd} {
  106. # a null RR (EXPERIMENTAL)
  107. return $rd
  108. }
  109.  
  110. method rdWKS {rd} {
  111. # a well known service description
  112. binary scan $rd Ica* address protocol rd
  113. set address [my decodeAddress $rd]
  114. return [list address $address protocol $protocol bitmap $rd]
  115. }
  116.  
  117. method rdPTR {rd} {
  118. # a domain name pointer
  119. return [my decodeName rd]
  120. }
  121.  
  122. method rdHINFO {rd} {
  123. # host information
  124. set cpu [my decodeName rd]
  125. set os [my decodeName rd]
  126. return [list cpu $cpu os $os]
  127. }
  128.  
  129. method rdMINFO {rd} {
  130. # mailbox or mail list information
  131. set rmailbx [my decodeName rd]
  132. set emailbx [my decodeName rd]
  133. return [list rmailbx $rmailbx emailbx $emailbx]
  134. }
  135.  
  136. method rdMX {rd} {
  137. # mail exchange
  138. binary scan $rd S preference rd
  139. return [list preference $preference [my decodeName rd]]
  140. }
  141.  
  142. method rdTXT {rd} {
  143. # text strings
  144. set result {}
  145. while {$rd ne ""} {
  146. lappend result [my decodeName rd]
  147. }
  148. return $result
  149. }
  150.  
  151. method rr {varname count} {
  152. upvar 1 $varname text
  153. set result {}
  154.  
  155. while {$count && $text ne ""} {
  156. incr count -1
  157. set name [my decodeName text]
  158. binary scan $text SSISa* type class ttl rdlength text
  159. set type [string trimleft $type 0]
  160. variable qtypes; catch {set type [dict get $qtypes $type]}
  161. set class [string trimleft $class 0]
  162. variable qclasses; catch {set class [dict get $qclasses $class]}
  163.  
  164. set rdata [string range $text 0 $rdlength-1]
  165. catch {set rdata [my rd$type $rdata]}
  166.  
  167. set text [string range $text $rdlength end]
  168.  
  169. lappend result [list name $name type $type class $class ttl $ttl rdata $rdata]
  170. }
  171.  
  172. return $result
  173. }
  174.  
  175. method decode {payload from port} {
  176. variable response $payload
  177.  
  178. binary scan $payload SB8B8SSSS id h1 h2 qdcount ancount nscount arcount
  179. lassign [split $h1 ""] qr . . . . aa tc rd
  180. set rcode 0b0[string trimleft [string range $h2 4 end] 0]
  181. set rcode [expr {$rcode + 0}]
  182. set ra [string index $h2 0]
  183. set id [string trimleft $id 0]
  184. set result [list id $id qr $qr aa $aa tc $tc rd $rd ra $ra rcode $rcode qdcount $qdcount ancount $ancount nscount $nscount arcount $arcount]
  185. if {$rcode} {
  186. variable rcodes
  187. dict set result error [dict get $rcodes $rcode]
  188. }
  189.  
  190. set content [string range $payload 12 end]
  191.  
  192. dict set result qd [my decodeQD content $qdcount]
  193. dict set result an [my rr content $ancount]
  194. dict set result ns [my rr content $nscount]
  195. dict set result ar [my rr content $arcount]
  196. if {$content ne ""} {
  197. dict set result remainder $content
  198. }
  199. #puts stderr "RESPONSE: $result"
  200. return $result
  201. }
  202.  
  203. # response - get result and invoke callback
  204. method response {payload from port chan} {
  205. if {[catch {
  206. my decode $payload $from $port
  207. } result eo]} {
  208. puts stderr "$result ($eo)"
  209. } else {
  210. # got a complete response - invoke callback for it.
  211. variable callbacks
  212. set id [dict get $result id]
  213. if {[dict exists $callbacks $id]} {
  214. set callback [dict get $callbacks $id]
  215. dict unset callbacks $id
  216. {*}$callback $result
  217. }
  218. }
  219. }
  220.  
  221. method qhead {id {opcode QUERY} {recurse 1}} {
  222. if {$recurse} {
  223. set h 0x0100
  224. } else {
  225. set h 0
  226. }
  227. switch $opcode {
  228. QUERY {}
  229. IQUERY {
  230. set h [expr {$h | 0x10}]
  231. }
  232. STATUS {
  233. set h [expr {$h | 0x100}]
  234. }
  235. default {
  236. error "opcode must be one of QUERY, IQUERY, STATUS"
  237. }
  238. }
  239. return [binary format SS $id $h]
  240. }
  241.  
  242. method dquery {name {qtype A} {qclass IN}} {
  243. variable qtypes; variable qclasses
  244. set query ""
  245. foreach label [split $name .] {
  246. set len [string length $label]
  247. if {$len > 255} {
  248. error "name component too long: '$label'"
  249. }
  250. append query [binary format ca$len $len $label]
  251. }
  252. append query \0
  253. append query [binary format SS [dict get $qtypes $qtype] [dict get $qclasses $qclass]]
  254. return $query
  255. }
  256.  
  257. method dqueries {id args} {
  258. set count 0
  259. set opcode QUERY
  260. set qtype A
  261. set qclass *
  262. set recurse 1
  263. set query ""
  264. set skip 0
  265.  
  266. foreach arg $args {
  267. if {$skip} {
  268. set $var $arg
  269. set skip 0
  270. continue
  271. }
  272. switch $arg {
  273. -qtype -
  274. -qclass -
  275. -opcode -
  276. -callback -
  277. -recurse {
  278. incr skip
  279. set var [string trim $arg -]
  280. }
  281. default {
  282. append query [my dquery $arg $qtype $qclass]
  283. incr count
  284. }
  285. }
  286. }
  287.  
  288. if {[info exists callback]} {
  289. variable callbacks; dict set callbacks $id $callback
  290. }
  291.  
  292. set query "[my qhead $id $opcode $recurse][binary format SSSS $count 0 0 0]$query"
  293. return $query
  294. }
  295.  
  296. method query {dns args} {
  297. variable udp; variable domain
  298. variable qcount; incr qcount
  299. set query [my dqueries $qcount {*}$args]
  300. udp::send $udp $dns $domain $query
  301. }
  302.  
  303. destructor {
  304. variable udp
  305. catch {chan close $udp}
  306. }
  307.  
  308. constructor {args} {
  309. variable domain 53
  310. variable {*}$args
  311.  
  312. variable qcount 1
  313. variable udp [::udp create 0 [list [self] response]]
  314.  
  315. variable callbacks {}
  316. variable rcodes {
  317. 0 {No error condition}
  318. 1 {Format error - The name server was unable to interpret the query.}
  319. 2 {Server failure - The name server was unable to process this query due to a problem with the name server.}
  320. 3 {Name Error - Meaningful only for responses from an authoritative name server, this code signifies that the domain name referenced in the query does not exist.}
  321. 4 {Not Implemented - The name server does not support the requested kind of query.}
  322. 5 {Refused - The name server refuses to perform the specified operation for policy reasons. For example, a name server may not wish to provide the information to the particular requester, r a name server may not wish to perform a particular operation (e.g., zone transfer) for particular data.}
  323. }
  324.  
  325. variable qtypes
  326. foreach {n v d} {
  327. A 1 {a host address}
  328. NS 2 {an authoritative name server}
  329. MD 3 {a mail destination (Obsolete - use MX)}
  330. MF 4 {a mail forwarder (Obsolete - use MX)}
  331. CNAME 5 {the canonical name for an alias}
  332. SOA 6 {marks the start of a zone of authority}
  333. MB 7 {a mailbox domain name (EXPERIMENTAL)}
  334. MG 8 {a mail group member (EXPERIMENTAL)}
  335. MR 9 {a mail rename domain name (EXPERIMENTAL)}
  336. NULL 10 {a null RR (EXPERIMENTAL)}
  337. WKS 11 {a well known service description}
  338. PTR 12 {a domain name pointer}
  339. HINFO 13 {host information}
  340. MINFO 14 {mailbox or mail list information}
  341. MX 15 {mail exchange}
  342. TXT 16 {text strings}
  343. AXFR 252 {A request for a transfer of an entire zone}
  344. MAILB 253 {A request for mailbox-related records (MB, MG or MR)}
  345. MAILA 254 {A request for mail agent RRs (Obsolete - see MX)}
  346. * 255 {A request for all records}
  347. } {
  348. dict set qtypes $n $v
  349. dict set qtypes $v $n
  350. }
  351.  
  352. variable qclasses
  353. foreach {n v d} {
  354. IN 1 {the Internet}
  355. CS 2 {the CSNET class (Obsolete - used only for examples in some obsolete RFCs)}
  356. CH 3 {the CHAOS class}
  357. HS 4 {Hesiod [Dyer 87]}
  358. * 255 {any class}
  359. } {
  360. dict set qclasses $n $v
  361. dict set qclasses $v $n
  362. }
  363. }
  364. }
  365.  
  366. oo::class create DNSsimple {
  367. superclass DNS
  368.  
  369. method response {payload from port} {
  370. if {[catch {
  371. my decode $payload $from $port
  372. } result eo]} {
  373. puts stderr "$result ($eo)"
  374. } else {
  375. # got a complete response - invoke callback for it.
  376. variable callbacks
  377. set id [dict get $result id]
  378. if {[dict exists $callbacks $id]} {
  379. if {[dict exists $result error]} {
  380. # got an error
  381. set lookup [list [dict get $result error]]
  382. } else {
  383. # post-process the result to just give simplified answers
  384. set lookup {}
  385. foreach {v} [dict get $result an] {
  386. dict lappend lookup [string trimleft [dict get $v name] .] [dict get $v rdata]
  387. }
  388. }
  389.  
  390. set callback [dict get $callbacks $id]
  391. dict unset callbacks $id
  392. {*}$callback {*}$lookup
  393. }
  394. }
  395. }
  396.  
  397. method reverse {dns args} {
  398. set skip 0
  399. set rquery {-qtype PTR}
  400. foreach arg $args {
  401. if {$skip} {
  402. set skip 0
  403. } elseif {[string match -* $arg]} {
  404. if {$arg eq "-qtype"} {
  405. error "reverse queries cannot specify -qtype"
  406. }
  407. set skip 1
  408. } else {
  409. # got to be an IP address
  410. set arg [join [lreverse [split $arg .]] .].in-addr.arpa
  411. }
  412. lappend rquery $arg
  413. }
  414. my query $dns {*}$rquery
  415. }
  416.  
  417. constructor {args} {
  418. next {*}$args
  419. }
  420. }
  421.  
  422. if {[info exists argv0] && ($argv0 eq [info script])} {
  423. set dns 192.168.178.2 ;# your dns server
  424.  
  425. proc putss {where args} {
  426. puts $where DNS:$args
  427. }
  428.  
  429. # simple DNS query processing
  430. DNSsimple create dnss
  431. dnss query $dns -callback {putss stderr} google.com ;# make a simple query
  432. dnss reverse $dns -callback {putss stderr} 74.125.237.48
  433. dnss query $dns -callback {putss stderr} localhost
  434. dnss query $dns -callback {putss stderr} google.com localhost
  435.  
  436. # full DNS query processing
  437. DNS create dns
  438. dns query $dns -callback {puts stderr} thighbone ;# make a query
  439. dns query $dns -qtype A -callback {puts stderr} google.com ;# make a query
  440.  
  441. # unicode DNS query processing
  442. DNS create dnsu
  443. dnsu query $dns -qtype A -callback {puts stderr} [encoding convertto utf-8 .cr.yp.to] ;# make a query
  444.  
  445. DNS create dnsu1
  446. dnsu1 query $dns -qtype A -callback {puts stderr} \317\200.cr.yp.to ;# make a query
  447.  
  448.  
  449. vwait forever
  450. }