Tcl Library Source Code

#
# Support for SPF (http://spf.pobox.com/rfcs.html) will need updating
# if or when the proposed draft becomes accepted.
#
# Support added for RFC1886 - DNS Extensions to support IP version 6
# Support added for RFC2782 - DNS RR for specifying the location of services
# Support added for RFC1995 - Incremental Zone Transfer in DNS
# Support added for RFC7858 - DNS over Transport Layer Security
#
# TODO:
#  - When using tcp we should make better use of the open connection and
#    send multiple queries along the same connection.
#
#  - We must switch to using TCP for truncated UDP packets.
#

        array set options {
            port       53
            timeout    30000
            protocol   tcp
            search     {}
            nameserver {localhost}
            loglevel   warn
            usetls     0
            cafile     ""
            cadir      ""
        }
        if {[file exists /etc/ssl/certs/ca-certificates.crt]} {
            set options(cafile) /etc/ssl/certs/ca-certificates.crt
        }
        variable log [logger::init dns]
        ${log}::setlevel $options(loglevel)
    }

    # We can use either ceptcl or tcludp for UDP support.
    if {![catch {package require udp 1.0.4} msg]} { ;# tcludp 1.0.4+

            -log* {
                if {$cget} {
                    return $options(loglevel)
                } else {
                    set options(loglevel) [Pop args 1]
                    ${log}::setlevel $options(loglevel)
                }
            }
            -cafile {
                if {$cget} {
                    return $options(cafile)
                } else {
                    set options(cafile) [Pop args 1]
                }
            }
            -cadir {
                if {$cget} {
                    return $options(cadir)
                } else {
                    set options(cadir) [Pop args 1]
                }
            }
            --    { Pop args ; break }
            default {
                set opts [join [lsort [array names options]] ", -"]
                return -code error "bad option [lindex $args 0]:\
                        must be one of -$opts"
            }

    set state(-recurse)    1;                   # Recursion Desired
    set state(-command)    {};                  # asynchronous handler
    set state(-timeout)    $options(timeout);   # connection timeout default.
    set state(-nameserver) $options(nameserver);# default nameserver
    set state(-port)       $options(port);      # default namerservers port
    set state(-search)     $options(search);    # domain search list
    set state(-protocol)   $options(protocol);  # which protocol udp/tcp
    set state(-usetls)     $options(usetls);    # use RFC7858 privacy
    set state(-cafile)     $options(cafile);    # certificate authority file
    set state(-cadir)      $options(cadir);     # certificate authority dir

    # Handle DNS URL's
    if {[string match "dns:*" $query]} {
        array set URI [uri::split $query]
        foreach {opt value} [uri::split $query] {
            if {$value != {} && [info exists state(-$opt)]} {
                set state(-$opt) $value
            }
        }
        set state(query) $URI(query)
        ${log}::debug "parsed query: $query"
    }

    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -n* - ns -
            -ser* { set state(-nameserver) [Pop args 1] }
            -po*  { set state(-port) [Pop args 1] }
            -usetls { set state(-usetls) [Pop args 1] }
            -cafile { set state(-cafile) [Pop args 1] }
            -cadir { set state(-cadir) [Pop args 1] }
            -ti*  { set state(-timeout) [Pop args 1] }
            -co*  { set state(-command) [Pop args 1] }
            -cl*  { set state(-class) [Pop args 1] }
            -ty*  { set state(-type) [Pop args 1] }
            -pr*  { set state(-protocol) [Pop args 1] }
            -sea* { set state(-search) [Pop args 1] }
            -re*  { set state(-recurse) [Pop args 1] }

        }
        Pop args
    }

    if {$state(-nameserver) == {}} {
        return -code error "no nameserver specified"
    }

    if {$state(-usetls)} {
        package require tls
        set state(-protocol) "tcp"
        if {$state(-port) == $options(port)} {
            set state(-port) 853
        }
    }

    if {$state(-protocol) == "udp"} {
        if {[llength [package provide ceptcl]] == 0 \
                && [llength [package provide udp]] == 0} {
            return -code error "udp support is not available,\
                get ceptcl or tcludp"
        }
    }

    # Check for reverse lookups
    if {[regexp {^(?:\d{0,3}\.){3}\d{0,3}$} $state(query)]} {
        set addr [lreverse [split $state(query) .]]
        lappend addr in-addr arpa
        set state(query) [join $addr .]
        set state(-type) PTR
    }

    fileevent $s writable {}
    if {[catch {fconfigure $s -peername}]} {
	# TCP connection failed
        Finish $token "can't connect to server"
	return
    }

    if {$state(-usetls)} {
        tls::import $s -server false -request 1 \
            -cadir $state(-cadir) \
            -cafile $state(-cafile) \
            -ssl2 false -ssl3 false -tls1 true \
            -command [list ::dns::TlsCallback $token]
        if {[catch {tls::handshake $s} err]} {
            Finish $token $err
            return
        }
    }

    fconfigure $s -blocking 0 -translation binary -buffering none

    # For TCP the message must be prefixed with a 16bit length field.
    set req [binary format S [string length $state(request)]]
    append req $state(request)

    fileevent $s readable [list [namespace current]::TcpEvent $token]
    puts -nonewline $s $req
}

proc ::dns::TlsCallback {token cmd channel args} {
    variable log
    variable $token
    upvar 0 $token state
    switch -exact -- $cmd {
        info {
            foreach {major minor message} $args break
            ${log}::debug "TLS: $major/$minor $message"
        }
        verify {
            foreach {depth cert status error} $args break
            lappend state(certChain) \
                [list depth $depth status $status error $error cert $cert]
            return $status
        }
        error {
            return -code error "tls error: $args"
        }
        default {
            return -code error "unexpected message type \"$cmd\" in TLS callback"
        }
    }
    return 1
}

# -------------------------------------------------------------------------
# Description:
#  Transmit a DNS request using UDP datagrams
#
# Note:

    }

    set status [catch {read $state(sock)} result]
    if {$status != 0} {
        ${log}::debug "Event error: $result"
        Finish $token "error reading data: $result"
    } elseif { [string length $result] >= 0 } {
        ${log}::debug "read [string length $result] bytes for $token"
        if {[catch {
            # Handle incomplete reads - check the size and keep reading.
            if {![info exists state(size)]} {
                binary scan $result S state(size)
                set result [string range $result 2 end]            
            }
            append state(reply) $result

                set parts(type) $type
            }
        }

        # Handle the nameserver specification
        if {[string match "//*" $uri]} {
            set uri [string range $uri 2 end]
            array set tmp [GetUPHP uri]
            set parts(nameserver) $tmp(host)
            set parts(port) $tmp(port)
        }
        
        # what's left is the query domain name.
        set parts(query) [string trimleft $uri /]
    }

    return "dns:$query"
}

# -------------------------------------------------------------------------

catch {dns::configure -nameserver [lindex [dns::nameservers] 0]}

package provide dns 1.4.0

# -------------------------------------------------------------------------
# Local Variables:
#   indent-tabs-mode: nil
# End:

# pkgIndex.tcl -
#
# $Id: pkgIndex.tcl,v 1.21 2010/08/16 17:35:18 andreas_kupries Exp $

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded dns    1.4.0 [list source [file join $dir dns.tcl]]
package ifneeded resolv 1.0.3 [list source [file join $dir resolv.tcl]]
package ifneeded ip     1.4   [list source [file join $dir ip.tcl]]
package ifneeded spf    1.1.1 [list source [file join $dir spf.tcl]]

[vset DNS_VERSION 1.4.0]
[manpage_begin dns n [vset DNS_VERSION]]
[see_also resolver(5)]
[keywords DNS]
[keywords {domain name service}]
[keywords resolver]
[keywords {rfc 1034}]
[keywords {rfc 1035}]
[keywords {rfc 1886}]
[keywords {rfc 7858}]
[copyright {2002, Pat Thoyts}]
[moddesc   {Domain Name Service}]
[titledesc {Tcl Domain Name Service Client}]
[category  Networking]
[require Tcl 8.2]
[require dns [opt [vset DNS_VERSION]]]
[description]

[para]

[emph Note:] The package defaults to using DNS over TCP
connections. If you wish to use UDP you will need to have the
[package tcludp] package installed and have a version that
correctly handles binary data (> 1.0.4).
This is available at [uri http://tcludp.sourceforge.net/].
If the [package udp] package is present then UDP will be used by
default.

[para]

[emph Note:] The package supports DNS over TLS (RFC 7858) for
enhanced privacy of DNS queries. Using this feature requires
the TLS package.

[section COMMANDS]

[list_begin definitions]

[call [cmd ::dns::resolve] [arg query] [opt [arg "options"]]]

  of IN for internet domain names, CS, CH, HS or * for any class.
[def "[cmd -recurse] [arg boolean]"]
  Set to [arg false] if you do not want the name server to recursively
  act upon your request. Normally set to [arg true].
[def "[cmd -command] [arg procname]"]
  Set a procedure to be called upon request completion. The procedure
  will be passed the token as its only argument.
[def "[cmd -usetls] [arg boolean]"]
  Set the [arg true] to use DNS over TLS. This will force the use of
  TCP and change the default port to 853. Certificate validation is
  required so a source of trusted certificate authority certificates
  must be provided using [arg -cafile ] or [arg -cadir].
[def "[cmd -cafile] [arg filepath]"]
  Specify a file containing a collection of trusted certificate
  authority certficates. See the [cmd update-ca-certificates] command
  manual page for details or the [cmd -CAfile] option help from
  [cmd openssl].
[def "[cmd -cadir] [arg dirpath]"]
  Specify a directory containing trusted certificate authority
  certificates. This must be provided if [cmd -cafile] is not
  specified for certificate validation to work when [cmd -usetls] is
  enabled. See the [cmd openssl] documentation for the required
  structure of this directory.

[list_end]

[para]
[call [cmd ::dns::configure] [opt [arg "options"]]]

The [cmd ::dns::configure] command is used to setup the dns
package. The server to query, the protocol and domain search path are

  Set the domain search list. This is currently not used.
[def "[cmd -timeout] [arg milliseconds]"]
  Set the default timeout value for DNS lookups. Default is 30 seconds.
[def "[cmd -loglevel] [arg level]"]
  Set the log level used for emitting diagnostic messages from this
  package. The default is [term warn]. See the [package log] package
  for details of the available levels.
[def "[cmd -cafile] [arg filepath]"]
   Set the default file path to be used for the [cmd -cafile]
   option to [cmd dns::resolve].
[def "[cmd -cadir] [arg dirpath]"]
   Set the default directory path to be used for the [cmd -cadir]
   option to [cmd dns::resolve].
[list_end]

[para]
[call [cmd ::dns::name] [arg token]]
  Returns a list of all domain names returned as an answer to your query.

[para]

[example {
% set tok [dns::resolve 127.0.0.1]
::dns::1
% dns::name $tok
localhost
% dns::cleanup $tok
}]

[para]
Using DNS over TLS (RFC 7858):
[example {
% set tok [dns::resolve www.tcl.tk -nameserver dns-tls.bitwiseshift.net \
  -usetls 1 -cafile /etc/ssl/certs/ca-certificates.crt]
::dns::12
% dns::wait $tok
ok
% dns::address $tok
104.25.119.118 104.25.120.118
}]

[comment { -----------------------------------------------------------  }]

[section {REFERENCES}]

[list_begin enumerated]

    ([uri http://www.ietf.org/rfc/rfc2782.txt])

[enum]
    Ohta, M. "Incremental Zone Transfer in DNS",
    RFC 1995, August 1996,
    ([uri http://www.ietf.org/rfc/rfc1995.txt])

[enum]
    Hu, Z., etc al.
    "Specification for DNS over Transport Layer Security (TLS)",
    RFC 7858, May 2016,
    ([uri http://www.ietf.org/rfc/rfc7858.txt])

[list_end]

[section AUTHORS]
Pat Thoyts

[vset CATEGORY dns]
[include ../doctools2base/include/feedback.inc]
[manpage_end]