Index: modules/dns/dns.tcl ================================================================== --- modules/dns/dns.tcl +++ modules/dns/dns.tcl @@ -13,10 +13,11 @@ # 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. # @@ -46,10 +47,16 @@ 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) } @@ -152,10 +159,24 @@ 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]:\ @@ -200,18 +221,21 @@ 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" } @@ -218,10 +242,13 @@ 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] } @@ -240,19 +267,27 @@ } 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 .] @@ -680,20 +715,56 @@ 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 +} - fileevent $s readable [list [namespace current]::TcpEvent $token] +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 @@ -826,10 +897,11 @@ 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] @@ -1366,11 +1438,11 @@ } # Handle the nameserver specification if {[string match "//*" $uri]} { set uri [string range $uri 2 end] - array set tmp [GetHostPort uri] + array set tmp [GetUPHP uri] set parts(nameserver) $tmp(host) set parts(port) $tmp(port) } # what's left is the query domain name. @@ -1406,11 +1478,11 @@ # ------------------------------------------------------------------------- catch {dns::configure -nameserver [lindex [dns::nameservers] 0]} -package provide dns 1.3.5 +package provide dns 1.4.0 # ------------------------------------------------------------------------- # Local Variables: # indent-tabs-mode: nil # End: Index: modules/dns/pkgIndex.tcl ================================================================== --- modules/dns/pkgIndex.tcl +++ modules/dns/pkgIndex.tcl @@ -1,9 +1,9 @@ # 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.3.5 [list source [file join $dir dns.tcl]] +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]] Index: modules/dns/tcllib_dns.man ================================================================== --- modules/dns/tcllib_dns.man +++ modules/dns/tcllib_dns.man @@ -1,14 +1,15 @@ -[vset DNS_VERSION 1.3.5] +[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] @@ -38,11 +39,18 @@ [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. +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] @@ -78,10 +86,27 @@ 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"]]] @@ -106,10 +131,16 @@ 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. @@ -192,10 +223,22 @@ ::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}] @@ -230,13 +273,19 @@ [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]