Here is the first snapshot of my Tcl DNS server. It requires the tcludp extension. If you have a problem compiling it yourself, let me know and Ill send you a copy of mine. I'll compile it on Windows as a test later. I really doubt this is production server ready, but Its posted here at JYL's request now. I'll be posting the enhancements/fixes as soon as I make them. My intention IS to run this on a production machine. My experiences in writing an email anti-spam proxy has proven to me that tcl is capable of handling continuous traffic on a low volume server like the ones I maintain (a thousand or so emails per day).
Setup: As youll see, all the DNS entries are stored in an array, which makes the records easy to retrieve. For now, Its probably best to place them in a separate file and source them on startup. If I get time, I'll make a "Bind hosts file" to "Tcl DNS" converter app. I really hope someone beats me to it :) SRIV
Right now the server responds to queries for A, NS, CNAME, MX and HINFO records.
To test its operation, I use dig. Heres some examples, assuming you're running the server on your workstation (localhost):
dig -t a test.linuxsys.net @localhost #reverse lookup a hostname dig -t cname dns.linuxsys.net @localhost #find the real hostname dig -t mx linuxsys.net @localhost #returns the mail servers for the domain dig -t ns dns.linuxsys.net @localhost #returns the dns servers for the domain
package require udp
array set ::db {0 ""}
set ::db(linuxsys.net,soa) {dns2.sr-tech.com}
set ::db(linuxsys.net,email) {hostmaster.sr-tech.com}
set ::db(linuxsys.net,serial) 2002032103
set ::db(linuxsys.net,refresh) 1800
set ::db(linuxsys.net,retry) 3600
set ::db(linuxsys.net,expire) 2400
set ::db(linuxsys.net,ttl) 3600
set ::db(linuxsys.net,NS) {dns.sr-tech.com dns3.sr-tech.com}
set ::db(linuxsys.net,MX) {{5 mail.sr-tech.com} {10 mail2.sr-tech.com}}
set ::db(linuxsys.net,A,) {69.3.36.102}
set ::db(linuxsys.net,A,www) {69.3.36.98}
set ::db(linuxsys.net,A,mail) {69.3.36.99}
set ::db(linuxsys.net,A,test) {69.3.36.100}
set ::db(linuxsys.net,CNAME,dns) {ns.sr-tech.com}
set ::db(linuxsys.net,CNAME,dns2) {dns2.sr-tech.com}
set ::db(linuxsys.net,PTR) ""
set ::db(linuxsys.net,HINFO,www) {{1.1ghz Intel P4} {SR Tech Linux}}
proc cvtname {dnsname} {
#convert from binary dns hostname format to readable string
set result ""
set chr 0
while {$chr < [string length $dnsname]} {
binary scan [string index $dnsname $chr] c* groupcnt
if {$chr > 0} {set dnsname [string replace $dnsname $chr $chr "."]}
incr chr +$groupcnt
incr chr
}
return [string range $dnsname 1 end]
}
proc cvthostnamedns {hostname} {
#convert from text hostname format to dns binary format
set result ""
set hostname [split $hostname "."]
foreach part $hostname {
append result "[format %c [string length $part]]$part"
}
return $result
}
proc cvtaddressdns {address} {
#convert from text dotted address format to dns binary format
set result ""
set address [split $address "."]
foreach octet $address {
append result "[format %c $octet]"
}
return $result
}
proc process_dns {host port pkt} {
#[binary format H* $reply]
binary scan $pkt H* cvt_data
#puts $cvt_data
set transid [string range $cvt_data 0 3]
set params [string range $cvt_data 4 7]
set quests [string range $cvt_data 8 11]
set answers [string range $cvt_data 12 15]
set authors [string range $cvt_data 16 19]
set addits [string range $cvt_data 20 23]
set queryname [string range $cvt_data 24 end-8]
set querytype [string range $cvt_data end-7 end-4]
set queryclass [string range $cvt_data end-3 end]
switch $querytype {
0001 {set qtype A}
0002 {set qtype NS}
0005 {set qtype CNAME}
000c {set qtype PTR}
000d {set qtype HINFO}
000f {set qtype MX}
default {set qtype error}
}
set qname [split [cvtname [string range $pkt 12 end-4]] "."]
set llen [llength $qname]
set qhost [string map {" " .} [lrange $qname 0 end-3]]
set qdomain [string map {" " .} [lrange $qname end-2 end-1]]
puts "Rec query from $host on port $port for host $qhost at $qdomain type $qtype"
set answer "0001"
set author "0000"
set params "8180" ; #this indicates a successful query
set class $queryclass
set type $querytype
#heres all the brains of the lookup
set error 0
if {! [info exists ::db($qdomain,soa)]} {
#domain doesnt exist, so resolve elsewhere if
set params "8181"; #this indicates an error
set error 1
set answer "0000"
puts "error: no domain entry found"
}
if {! [info exists ::db($qdomain,$qtype,$qhost)] && $qtype != "NS" && $qtype != "MX"} {
#host doesnt exist, so return an error reply in bits 13-16=0001
set params "8181"; #this indicates an error
set error 1
set answer "0000"
puts "error: no host entry found"
}
set resp_answer ""
set recindex 0
while {! $error} {
#return a response for each record found
switch $qtype {
A {set lookup [cvtaddressdns [lindex $::db($qdomain,$qtype,$qhost) $recindex]]}
MX {set mxprefix [lindex [lindex $::db($qdomain,$qtype) $recindex] 0]
set lookup [cvthostnamedns [lindex [lindex $::db($qdomain,$qtype) $recindex] 1]]
}
NS {set lookup [cvthostnamedns [lindex $::db($qdomain,$qtype) $recindex]]}
CNAME {set lookup [cvthostnamedns [lindex $::db($qdomain,$qtype,$qhost) $recindex]]}
HINFO {set lookup [lindex $::db($qdomain,$qtype,$qhost) $recindex]}
}
#test for no more records, then break to sent accumulated response
if {$lookup == ""} {break}
set len [string length $lookup]
binary scan $lookup H* hexlookup
switch $qtype {
A {set data $hexlookup}
NS {set data "${hexlookup}00"
incr len
}
CNAME {set data "${hexlookup}00"
incr len
}
MX {set data "[format %04x $mxprefix]${hexlookup}00"
incr len +3
}
HINFO {incr recindex
set data "[format %02x $len]${hexlookup}"
set lookup [lindex $::db($qdomain,$qtype,$qhost) $recindex]
set len [string length $lookup]
binary scan $lookup H* hexlookup
append data "[format %02x $len]${hexlookup}00"
set len [expr [string length $data] / 2 -1]
}
}
set len [format %04x $len]
set ttl [format %08x $::db($qdomain,ttl)]
#puts "${type} ${class} ${ttl} $len $data"
append resp_answer "C00C${type}${class}${ttl}${len}${data}"
incr recindex
set answer [format %04x $recindex]
}
set resp_author ""
set resp_addit ""
set response "[string range $cvt_data 0 3]${params}[string range $cvt_data 8 11]${answer}${author}[string range $cvt_data 20 end]"
udp_puts $host $port [binary format H* ${response}${resp_answer}${resp_author}${resp_addit}]
}
# Send data to a remote UDP socket
proc udp_puts {host port data} {
set s [udp_open]
fconfigure $s -translation binary
udp_conf $s $host $port
puts -nonewline $s $data
close $s
}
proc udpEventHandler {sock} {
set pkt [read $sock]
set peer [udp_conf $sock -peer]
process_dns [lindex $peer 0] [lindex $peer 1] $pkt
return
}
proc udp_listen {port} {
set srv [udp_open $port]
fconfigure $srv -buffering none -translation binary
fileevent $srv readable [list ::udpEventHandler $srv]
puts "Listening on udp port: [udp_conf $srv -myport]"
return $srv
}
set sock [udp_listen 53]
vwait forever
close $sock