Tcl DNS server

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 I'll 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 Jacob Levy'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 you'll see, all the DNS entries are stored in an array, which makes the records easy to retrieve. For now, it's 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

You'll notice I convert the binary queries to hex-ascii and back, e.g.: a single binary byte with a value of 65 is converted to a 2-byte string "65". This makes it easier to parse and build the packets. Ok, easier for me anyways....

Right now the server responds to queries for A, NS, CNAME, MX and HINFO records. Im at 172 lines of code with 10 hours coding. Hmm, 17 lines per hour! Damn I'm slow!.

To test its operation, I use dig. Here are 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} {
      udp_conf $::sock $host $port
      puts -nonewline $::sock $data
  }

  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

update 09-Jul-2003 Although I thought otherwise, running a DNS server that only resolves hostnames that it is authoritative for IS acceptable, as long as no clients point to it to resolve non-authoritative queries. Its simply refered to as a non-recursive DNS server. In other words, its only used on servers that reply to requests for domains that it has records for.

(07-09-2003 means some time in september over here :) PT)

update 11-Jul-2003 Ok, while writing a recursive lookup procedure, I realised that dig was working, but ping and any other app that uses libresolv was not, which means just about everything, web browsers etc. After staring at tcpdumps for several hours, I spotted the problem: libresolv expects the reply from the dns to come from port 53! I was letting the the tcludp set the reply port on a secondary socket. I'm fixing the code above to reuse the original socket handle for replies. Problem solved. Now I can finish work on the recursive resolver. SRIV

[drisu] - 2015-06-05 14:23:59

I am getting error on running this code.Pls help me.

 invalid command name "dig"
    while executing  "dig  -t a  test.linuxsys.net @localhost     #reverse lookup a hostname"

AMG: "dig" is an external program, not a Tcl command. See [1]. Surprised you don't have it, though maybe you're on Windows.

[drisu] - 2015-06-06 10:09:25

No sir,I am in Ubuntu.Actualy dig command is working for me when i am calling from terminal.Actually one sir gave me the code like this

 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}}

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

  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} {
      udp_conf $::sock $host $port
      puts -nonewline $::sock $data
  }

  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 67]
  vwait forever
  close $::sock

set ns_ [new Simulator] set tracefd [open swtich1.tr w] set namtrace [open switch1.nam w]

$ns_ trace-all $tracefd $ns_ namtrace-all-wireless $namtrace $val(x) $val(y)

# set up topography object set topo [new Topography]

#$topo load_flatgrid 500 500 $topo load_flatgrid $val(x) $val(y)

Sir actualy what i have to do to run this code.I am new to ns2.Pls help me

[drisu] - 2015-06-06 10:26:13

Sir, i need to implement a switch that swich has to communicate with DNS server.How i can do it?

Category Application

Category Internet