diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -1,3 +1,5 @@ +2.0.9 + - Implemented TCP fallback after a truncated UDP response. [#46](https://github.com/kazu-yamamoto/dns/pull/46) 2.0.8 - Better handling of encoding and decoding the "root" domain ".". [#45](https://github.com/kazu-yamamoto/dns/pull/45) 2.0.7 diff --git a/Network/DNS/Decode.hs b/Network/DNS/Decode.hs --- a/Network/DNS/Decode.hs +++ b/Network/DNS/Decode.hs @@ -4,6 +4,7 @@ decode , decodeMany , receive + , receiveVC ) where import Control.Applicative (many) @@ -15,8 +16,9 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BL -import Data.Conduit (($$), Source) +import Data.Conduit (($$), ($$+), ($$+-), (=$), Source) import Data.Conduit.Network (sourceSocket) +import qualified Data.Conduit.Binary as CB import Data.IP (IP(..), toIPv4, toIPv6b) import Data.Typeable (Typeable) import Data.Word (Word16) @@ -42,6 +44,19 @@ receive :: Socket -> IO DNSMessage receive = receiveDNSFormat . sourceSocket + +-- | Receive and parse a single virtual-circuit (TCP) response. It +-- is up to the caller to implement any desired timeout. This +-- (and the other response decoding functions) may throw ParseError +-- when the server response is incomplete or malformed. + +receiveVC :: Socket -> IO DNSMessage +receiveVC sock = runResourceT $ do + (src, lenbytes) <- sourceSocket sock $$+ CB.take 2 + let len = case (map fromIntegral $ BL.unpack lenbytes) of + hi:lo:[] -> 256 * hi + lo + _ -> 0 + src $$+- CB.isolate len =$ sinkSGet decodeResponse >>= return . fst ---------------------------------------------------------------- diff --git a/Network/DNS/Encode.hs b/Network/DNS/Encode.hs --- a/Network/DNS/Encode.hs +++ b/Network/DNS/Encode.hs @@ -2,6 +2,7 @@ module Network.DNS.Encode ( encode + , encodeVC , composeQuery , composeQueryAD ) where @@ -60,6 +61,11 @@ encode :: DNSMessage -> ByteString encode msg = runSPut (encodeDNSMessage msg) + +encodeVC :: ByteString -> ByteString +encodeVC query = + let len = BB.toLazyByteString $ BB.int16BE $ fromIntegral $ BL.length query + in len <> query ---------------------------------------------------------------- diff --git a/Network/DNS/Internal.hs b/Network/DNS/Internal.hs --- a/Network/DNS/Internal.hs +++ b/Network/DNS/Internal.hs @@ -115,9 +115,8 @@ -- | The name server was unable to process this query due to a -- problem with the name server. | ServerFailure - -- | Meaningful only for responses from an authoritative name - -- server, this code signifies that the - -- domain name referenced in the query does not exist. + -- | This code signifies that the domain name referenced in the + -- query does not exist. | NameError -- | The name server does not support the requested kind of query. | NotImplemented diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs --- a/Network/DNS/Lookup.hs +++ b/Network/DNS/Lookup.hs @@ -373,8 +373,9 @@ ---------------------------------------------------------------- --- | Look up all \'SRV\' records for the given hostname. A SRV record --- comprises four fields, +-- | Look up all \'SRV\' records for the given hostname. SRV records +-- consist (see ) of the +-- following four fields: -- -- * Priority (lower is more-preferred) -- @@ -391,12 +392,18 @@ -- -- Examples: -- --- >>> let hostname = Data.ByteString.Char8.pack "_sip._tcp.cisco.com" +-- >>> let q = Data.ByteString.Char8.pack "_xmpp-server._tcp.jabber.ietf.org" -- >>> -- >>> rs <- makeResolvSeed defaultResolvConf --- >>> withResolver rs $ \resolver -> lookupSRV resolver hostname --- Right [(1,0,5060,"vcsgw.cisco.com.")] --- +-- >>> withResolver rs $ \resolver -> lookupSRV resolver q +-- Right [(5,0,5269,"jabber.ietf.org.")] + +-- Though the "jabber.ietf.orgs" SRV record may prove reasonably stable, as +-- with anything else published in DNS it is subject to change. Also, this +-- example only works when connected to the Internet. Perhaps the above +-- example should be displayed in a format that is not recognized as a test +-- by "doctest". + lookupSRV :: Resolver -> Domain -> IO (Either DNSError [(Int,Int,Int,Domain)]) lookupSRV rlv dom = do erds <- DNS.lookup rlv dom SRV diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs --- a/Network/DNS/Resolver.hs +++ b/Network/DNS/Resolver.hs @@ -28,8 +28,11 @@ import Network.DNS.Encode import Network.DNS.Internal import qualified Data.ByteString.Char8 as BS -import Network.Socket (HostName, Socket, SocketType(Datagram), close, socket, connect) -import Network.Socket (AddrInfoFlag(..), AddrInfo(..), SockAddr(..), PortNumber(..), defaultHints, getAddrInfo) +import Network.Socket (HostName, Socket, SocketType(Stream, Datagram)) +import Network.Socket (AddrInfoFlag(..), AddrInfo(..), SockAddr(..)) +import Network.Socket (Family(AF_INET, AF_INET6), PortNumber(..)) +import Network.Socket (close, socket, connect, getPeerName, getAddrInfo) +import Network.Socket (defaultHints, defaultProtocol) import Prelude hiding (lookup) import System.Random (getStdRandom, randomR) import System.Timeout (timeout) @@ -267,10 +270,14 @@ lookupAuth = lookupSection authority --- | Look up a name and return the entire DNS Response. Sample output --- is included below, however it is /not/ tested -- the sequence --- number is unpredictable (it has to be!). +-- | Look up a name and return the entire DNS Response. If the +-- initial UDP query elicits a truncated answer, the query is +-- retried over TCP. The TCP retry may extend the total time +-- taken by one more timeout beyond timeout * tries. -- +-- Sample output is included below, however it is /not/ tested +-- the sequence number is unpredictable (it has to be!). +-- -- The example code: -- -- @ @@ -310,10 +317,30 @@ lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage) lookupRaw = lookupRawInternal receive False +-- | Same as lookupRaw, but the query sets the AD bit, which solicits the +-- the authentication status in the server reply. In most applications +-- (other than diagnostic tools) that want authenticated data It is +-- unwise to trust the AD bit in the responses of non-local servers, this +-- interface should in most cases only be used with a loopback resolver. +-- lookupRawAD :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage) lookupRawAD = lookupRawInternal receive True - +-- Lookup loop, we try UDP until we get a response. If the response +-- is truncated, we try TCP once, with no further UDP retries. +-- EDNS0 support would significantly reduce the need for TCP retries. +-- +-- For now, we optimize for low latency high-availability caches +-- (e.g. running on a loopback interface), where TCP is cheap +-- enough. We could attempt to complete the TCP lookup within the +-- original time budget of the truncated UDP query, by wrapping both +-- within a a single 'timeout' thereby staying within the original +-- time budget, but it seems saner to give TCP a full opportunity to +-- return results. TCP latency after a truncated UDP reply will be +-- atypical. +-- +-- Future improvements might also include support for TCP on the +-- initial query, and of course support for multiple nameservers. lookupRawInternal :: (Socket -> IO DNSMessage) @@ -342,15 +369,37 @@ Nothing -> loop query checkSeqno (cnt + 1) False Just res -> do let valid = checkSeqno res - if valid then - return $ Right res - else - loop query checkSeqno (cnt + 1) False + case valid of + False -> loop query checkSeqno (cnt + 1) False + True | False <- trunCation $ flags $ header res + -> return $ Right res + _ -> tcpRetry query sock = dnsSock rlv tm = dnsTimeout rlv retry = dnsRetry rlv q = makeQuestion dom typ check seqno res = identifier (header res) == seqno + tcpRetry query = do + peer <- getPeerName sock + bracket (tcpOpen peer) + (maybe (return ()) close) + (tcpLookup query peer) + tcpOpen peer = do + case (peer) of + SockAddrInet _ _ -> + socket AF_INET Stream defaultProtocol >>= return . Just + SockAddrInet6 _ _ _ _ -> + socket AF_INET6 Stream defaultProtocol >>= return . Just + _ -> return Nothing -- Only IPv4 and IPv6 are possible + tcpLookup _ _ Nothing = return $ Left ServerFailure -- can't happen + tcpLookup query peer (Just vc) = do + response <- timeout tm $ do + connect vc $ peer + sendAll vc $ encodeVC query + receiveVC vc + case response of + Nothing -> return $ Left TimeoutExpired + Just res -> return $ Right res #if mingw32_HOST_OS == 1 -- Windows does not support sendAll in Network.ByteString.Lazy. diff --git a/dns.cabal b/dns.cabal --- a/dns.cabal +++ b/dns.cabal @@ -1,5 +1,5 @@ Name: dns -Version: 2.0.8 +Version: 2.0.9 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3