-- |
-- Module      : Net.DNSBase.Internal.Transport
-- Description : UDP/TCP query transport, retry, and TCP fallback
-- Copyright   : (c) IIJ Innovation Institute Inc., 2009
--               (c) Viktor Dukhovni, 2020-2026
-- License     : BSD-3-Clause
-- Maintainer  : ietf-dane@dukhovni.org
-- Stability   : unstable
{-# LANGUAGE RecordWildCards #-}

module Net.DNSBase.Internal.Transport
    ( lookupRawCtl_
    ) where

import qualified Data.IP as IP
import Control.Exception (bracket)
import Network.Socket (AddrInfo(..), SockAddr(..), Family(AF_INET, AF_INET6))
import Network.Socket (Socket, SocketType(Stream) , close, socket, connect)
import Network.Socket (defaultProtocol)
import System.IO.Error (annotateIOError)
import System.Timeout (timeout)
import Time.System (timeCurrent)
import Time.Types (Elapsed(..), Seconds(..))

import Net.DNSBase.Decode.Internal.Message
import Net.DNSBase.Decode.Internal.State
import Net.DNSBase.Internal.Domain
import Net.DNSBase.Internal.EDNS
import Net.DNSBase.Internal.Error
import Net.DNSBase.Internal.Flags
import Net.DNSBase.Internal.Message
import Net.DNSBase.Internal.RCODE
import Net.DNSBase.Internal.RRCLASS
import Net.DNSBase.Internal.RRTYPE
import Net.DNSBase.Internal.SockIO
import Net.DNSBase.Internal.Util
import Net.DNSBase.Resolver.Internal.Encoding
import Net.DNSBase.Resolver.Internal.Types

-- | Check response for a matching identifier and question.  If we ever do
-- pipelined TCP, we'll need to handle out of order responses.  See:
-- https://tools.ietf.org/html/rfc7766#section-7
--
checkResp :: DnsTriple -> QueryID -> DNSMessage -> Bool
checkResp :: DnsTriple -> Word16 -> DNSMessage -> Bool
checkResp DnsTriple
q Word16
qid = Maybe DNSError -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe DNSError -> Bool)
-> (DNSMessage -> Maybe DNSError) -> DNSMessage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DnsTriple -> Word16 -> DNSMessage -> Maybe DNSError
checkRespM DnsTriple
q Word16
qid

-- When the response @RCODE@ is @FORMERR@, the server did not understand our
-- query packet, and so is not expected to return a matching question.
--
checkRespM :: DnsTriple -> QueryID -> DNSMessage -> Maybe DNSError
checkRespM :: DnsTriple -> Word16 -> DNSMessage -> Maybe DNSError
checkRespM DnsTriple
q Word16
qid DNSMessage{[DnsTriple]
[RR]
Maybe EDNS
Word16
RCODE
Opcode
DNSFlags
dnsMsgId :: Word16
dnsMsgOp :: Opcode
dnsMsgRC :: RCODE
dnsMsgFl :: DNSFlags
dnsMsgEx :: Maybe EDNS
dnsMsgQu :: [DnsTriple]
dnsMsgAn :: [RR]
dnsMsgNs :: [RR]
dnsMsgAr :: [RR]
dnsMsgAr :: DNSMessage -> [RR]
dnsMsgNs :: DNSMessage -> [RR]
dnsMsgAn :: DNSMessage -> [RR]
dnsMsgQu :: DNSMessage -> [DnsTriple]
dnsMsgEx :: DNSMessage -> Maybe EDNS
dnsMsgFl :: DNSMessage -> DNSFlags
dnsMsgRC :: DNSMessage -> RCODE
dnsMsgOp :: DNSMessage -> Opcode
dnsMsgId :: DNSMessage -> Word16
..}
  | Word16
dnsMsgId Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word16
qid = DNSError -> Maybe DNSError
forall a. a -> Maybe a
Just (DNSError -> Maybe DNSError) -> DNSError -> Maybe DNSError
forall a b. (a -> b) -> a -> b
$ ProtocolContext -> DNSError
ProtocolError ProtocolContext
SequenceNumberMismatch
  | RCODE
FORMERR <- RCODE
dnsMsgRC
  , []        <- [DnsTriple]
dnsMsgQu    = Maybe DNSError
forall a. Maybe a
Nothing
  | [DnsTriple
q] [DnsTriple] -> [DnsTriple] -> Bool
forall a. Eq a => a -> a -> Bool
/= [DnsTriple]
dnsMsgQu          = DNSError -> Maybe DNSError
forall a. a -> Maybe a
Just (DNSError -> Maybe DNSError) -> DNSError -> Maybe DNSError
forall a b. (a -> b) -> a -> b
$ ProtocolContext -> DNSError
ProtocolError ProtocolContext
QuestionMismatch
  | Bool
otherwise                = Maybe DNSError
forall a. Maybe a
Nothing

----------------------------------------------------------------

type Retries = Int
type Timeout = Int

type TcpLookup = Timeout -> DnsTriple -> QueryControls -> ResolvSeed -> DNSIO DNSMessage
type UdpLookup = Retries -> TcpLookup

timeout' :: Timeout -> DNSIO a -> DNSIO (Maybe a)
timeout' :: forall a. Retries -> DNSIO a -> DNSIO (Maybe a)
timeout' Retries
tmout DNSIO a
act = IO (Either DNSError (Maybe a)) -> ExceptT DNSError IO (Maybe a)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either DNSError (Maybe a)) -> ExceptT DNSError IO (Maybe a))
-> IO (Either DNSError (Maybe a)) -> ExceptT DNSError IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe (Either DNSError a) -> Either DNSError (Maybe a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Maybe (f a) -> f (Maybe a)
sequenceA (Maybe (Either DNSError a) -> Either DNSError (Maybe a))
-> IO (Maybe (Either DNSError a)) -> IO (Either DNSError (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Retries -> IO (Either DNSError a) -> IO (Maybe (Either DNSError a))
forall a. Retries -> IO a -> IO (Maybe a)
timeout Retries
tmout (IO (Either DNSError a) -> IO (Maybe (Either DNSError a)))
-> IO (Either DNSError a) -> IO (Maybe (Either DNSError a))
forall a b. (a -> b) -> a -> b
$ DNSIO a -> IO (Either DNSError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT DNSIO a
act)

bracket' :: DNSIO a -> (a -> IO b) -> (a -> DNSIO c) -> DNSIO c
bracket' :: forall a b c. DNSIO a -> (a -> IO b) -> (a -> DNSIO c) -> DNSIO c
bracket' DNSIO a
get a -> IO b
end a -> DNSIO c
act = IO (Either DNSError c) -> DNSIO c
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either DNSError c) -> DNSIO c)
-> IO (Either DNSError c) -> DNSIO c
forall a b. (a -> b) -> a -> b
$ IO (Either DNSError a)
-> (Either DNSError a -> IO ())
-> (Either DNSError a -> IO (Either DNSError c))
-> IO (Either DNSError c)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (DNSIO a -> IO (Either DNSError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT DNSIO a
get) Either DNSError a -> IO ()
end' Either DNSError a -> IO (Either DNSError c)
act'
  where
    end' :: Either DNSError a -> IO ()
end' = \case
      Left DNSError
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Right a
x -> IO b -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO b -> IO ()) -> IO b -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> IO b
end a
x
    act' :: Either DNSError a -> IO (Either DNSError c)
act' = \case
      Left DNSError
err -> Either DNSError c -> IO (Either DNSError c)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DNSError c -> IO (Either DNSError c))
-> Either DNSError c -> IO (Either DNSError c)
forall a b. (a -> b) -> a -> b
$ DNSError -> Either DNSError c
forall a b. a -> Either a b
Left DNSError
err
      Right a
x  -> DNSIO c -> IO (Either DNSError c)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (DNSIO c -> IO (Either DNSError c))
-> DNSIO c -> IO (Either DNSError c)
forall a b. (a -> b) -> a -> b
$ a -> DNSIO c
act a
x

-- In lookup loop, we try UDP until we get a response.  If the response
-- is truncated, we try TCP once, with no further UDP 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.
--
-- This function merges the query flag overrides from the resolver
-- configuration with any additional overrides from the caller.
--
-- | Internal entry-point used by the public IO+Either wrappers in
-- "Net.DNSBase.Lookup".  Stays in 'DNSIO' because the inner pipeline
-- (socket bracketing, timeouts, retry, TCP fallback) composes cleanly
-- in @'ExceptT' 'DNSError' 'IO'@.
lookupRawCtl_ :: Resolver -> QueryControls -> Domain -> RRCLASS -> RRTYPE -> DNSIO DNSMessage
lookupRawCtl_ :: Resolver
-> QueryControls -> Domain -> RRCLASS -> RRTYPE -> DNSIO DNSMessage
lookupRawCtl_ Resolver{IO Word64
ResolvSeed
resolvSeed :: ResolvSeed
resolvRng :: IO Word64
resolvRng :: Resolver -> IO Word64
resolvSeed :: Resolver -> ResolvSeed
..} QueryControls
qctls Domain
dom RRCLASS
qclass RRTYPE
qtype
  | RRTYPE -> Bool
isIllegalQT RRTYPE
qtype = DNSError -> DNSIO DNSMessage
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DNSError -> DNSIO DNSMessage) -> DNSError -> DNSIO DNSMessage
forall a b. (a -> b) -> a -> b
$ UserContext -> DNSError
UserError (UserContext -> DNSError) -> UserContext -> DNSError
forall a b. (a -> b) -> a -> b
$ RRTYPE -> UserContext
InvalidQueryType RRTYPE
qtype
  | Bool
otherwise = case ResolvSeed -> NonEmpty Nameserver
seedServers ResolvSeed
resolvSeed of
      Nameserver
ns :| [] -> Nameserver -> IO Word16 -> UdpLookup
resolveOne Nameserver
ns IO Word16
gen Retries
retry Retries
tmout DnsTriple
q QueryControls
ctls ResolvSeed
resolvSeed
      NonEmpty Nameserver
nss      -> NonEmpty Nameserver -> IO Word16 -> UdpLookup
resolveSeq NonEmpty Nameserver
nss IO Word16
gen Retries
retry Retries
tmout DnsTriple
q QueryControls
ctls ResolvSeed
resolvSeed
  where
    gen :: IO Word16
gen            = (Word64 -> Word16) -> IO Word64 -> IO Word16
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral IO Word64
resolvRng
    conf :: ResolverConf
conf           = ResolvSeed -> ResolverConf
seedConfig ResolvSeed
resolvSeed
    tmout :: Retries
tmout          = ResolverConf -> Retries
rcTimeout ResolverConf
conf
    retry :: Retries
retry          = ResolverConf -> Retries
rcRetries ResolverConf
conf
    ctls :: QueryControls
ctls           = QueryControls
qctls QueryControls -> QueryControls -> QueryControls
forall a. Semigroup a => a -> a -> a
<> ResolverConf -> QueryControls
rcQryCtls ResolverConf
conf
    q :: DnsTriple
q              = Domain -> RRTYPE -> RRCLASS -> DnsTriple
DnsTriple Domain
dom RRTYPE
qtype RRCLASS
qclass

    isIllegalQT :: RRTYPE -> Bool
isIllegalQT (RRTYPE Word16
0) = Bool
True
    isIllegalQT RRTYPE
AXFR = Bool
True
    isIllegalQT RRTYPE
IXFR = Bool
True
    isIllegalQT RRTYPE
RRSIG = Bool
True
    isIllegalQT RRTYPE
OPT = Bool
True
    isIllegalQT RRTYPE
typ = RRTYPE
typ RRTYPE -> RRTYPE -> Bool
forall a. Ord a => a -> a -> Bool
>= RRTYPE
NXNAME Bool -> Bool -> Bool
&& RRTYPE
typ RRTYPE -> RRTYPE -> Bool
forall a. Ord a => a -> a -> Bool
< RRTYPE
MAILB


resolveSeq :: NonEmpty Nameserver -> IO QueryID -> UdpLookup
resolveSeq :: NonEmpty Nameserver -> IO Word16 -> UdpLookup
resolveSeq NonEmpty Nameserver
nss IO Word16
gen Retries
retry Retries
tmout DnsTriple
q QueryControls
qctls ResolvSeed
seed = NonEmpty Nameserver -> DNSIO DNSMessage
loop NonEmpty Nameserver
nss
  where
    loop :: NonEmpty Nameserver -> DNSIO DNSMessage
loop (Nameserver
ns :| []) = Nameserver -> IO Word16 -> UdpLookup
resolveOne Nameserver
ns IO Word16
gen Retries
retry Retries
tmout DnsTriple
q QueryControls
qctls ResolvSeed
seed
    loop (Nameserver
ns :| Nameserver
ns' : [Nameserver]
rest) =
        Nameserver -> IO Word16 -> UdpLookup
resolveOne Nameserver
ns IO Word16
gen Retries
retry Retries
tmout DnsTriple
q QueryControls
qctls ResolvSeed
seed
            DNSIO DNSMessage
-> (DNSError -> DNSIO DNSMessage) -> DNSIO DNSMessage
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
`catchE` DNSIO DNSMessage -> DNSError -> DNSIO DNSMessage
forall a b. a -> b -> a
const (NonEmpty Nameserver -> DNSIO DNSMessage
loop (Nameserver
ns' Nameserver -> [Nameserver] -> NonEmpty Nameserver
forall a. a -> [a] -> NonEmpty a
:| [Nameserver]
rest))

-- UDP attempts must use the same ID and accept delayed answers
-- but we use a fresh ID for each TCP lookup.
--
resolveOne :: Nameserver -> IO QueryID -> UdpLookup
resolveOne :: Nameserver -> IO Word16 -> UdpLookup
resolveOne Nameserver
ns IO Word16
gen Retries
retry Retries
tmout DnsTriple
q QueryControls
qctls ResolvSeed
seed = do
    ident <- IO Word16 -> ExceptT DNSError IO Word16
forall (m :: * -> *) a. Monad m => m a -> ExceptT DNSError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO Word16
gen
    udpLookup ns ident retry tmout q qctls seed

----------------------------------------------------------------

ioErrorToDNSError :: Nameserver -> String -> DNSError -> DNSIO DNSMessage
ioErrorToDNSError :: Nameserver -> String -> DNSError -> DNSIO DNSMessage
ioErrorToDNSError Nameserver
ns String
protoName = \case
    NetworkError (NetworkFailure IOException
err) ->
      let loc :: String
loc  = String
protoName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"@" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Nameserver -> String
forall a. Show a => a -> String
show Nameserver
ns
          err' :: IOException
err' = IOException
-> String -> Maybe Handle -> Maybe String -> IOException
annotateIOError IOException
err String
loc Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
       in DNSError -> DNSIO DNSMessage
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DNSError -> DNSIO DNSMessage) -> DNSError -> DNSIO DNSMessage
forall a b. (a -> b) -> a -> b
$ NetworkContext -> DNSError
NetworkError (NetworkContext -> DNSError) -> NetworkContext -> DNSError
forall a b. (a -> b) -> a -> b
$ IOException -> NetworkContext
NetworkFailure IOException
err'
    DNSError
err -> DNSError -> DNSIO DNSMessage
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE DNSError
err

----------------------------------------------------------------

udpOpen :: AddrInfo -> DNSIO Socket
udpOpen :: AddrInfo -> DNSIO Socket
udpOpen AddrInfo
ai = IO Socket -> DNSIO Socket
forall (m :: * -> *) a. Monad m => m a -> ExceptT DNSError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Socket -> DNSIO Socket) -> IO Socket -> DNSIO Socket
forall a b. (a -> b) -> a -> b
$ do
    sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
ai) (AddrInfo -> SocketType
addrSocketType AddrInfo
ai) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
ai)
    connect sock (addrAddress ai)
    return sock

-- | Enabled unless explicitly disabled.
hasEDNS :: QueryControls -> Bool
hasEDNS :: QueryControls -> Bool
hasEDNS QueryControls
EdnsDisabled = Bool
False
hasEDNS QueryControls
_            = Bool
True

-- | Perform a UDP lookup, retrying over TCP on TC=1 or without EDNS on FORMERR.
--
-- XXX: With multiple available IP endpoints, the retry strategy is suboptimal,
-- we should try another server before trying the same server again!
--
udpLookup :: Nameserver -> QueryID -> UdpLookup
udpLookup :: Nameserver -> Word16 -> UdpLookup
udpLookup Nameserver
ns Word16
ident Retries
retry Retries
tmout DnsTriple
q QueryControls
qctls ResolvSeed
seed =
    case Word16 -> QueryControls -> DnsTriple -> Either DNSError ByteString
encodeQuestion Word16
ident QueryControls
qctls DnsTriple
q of
      Left DNSError
err -> DNSError -> DNSIO DNSMessage
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE DNSError
err
      Right ByteString
qry -> do
        (DNSIO DNSMessage
 -> (DNSError -> DNSIO DNSMessage) -> DNSIO DNSMessage)
-> (DNSError -> DNSIO DNSMessage)
-> DNSIO DNSMessage
-> DNSIO DNSMessage
forall a b c. (a -> b -> c) -> b -> a -> c
flip DNSIO DNSMessage
-> (DNSError -> DNSIO DNSMessage) -> DNSIO DNSMessage
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE (Nameserver -> String -> DNSError -> DNSIO DNSMessage
ioErrorToDNSError Nameserver
ns String
"udp") (DNSIO DNSMessage -> DNSIO DNSMessage)
-> DNSIO DNSMessage -> DNSIO DNSMessage
forall a b. (a -> b) -> a -> b
$
            DNSIO Socket
-> (Socket -> IO ())
-> (Socket -> DNSIO DNSMessage)
-> DNSIO DNSMessage
forall a b c. DNSIO a -> (a -> IO b) -> (a -> DNSIO c) -> DNSIO c
bracket' do AddrInfo -> DNSIO Socket
udpOpen (Nameserver -> AddrInfo
nsAddr Nameserver
ns)
                     do close
                     do \Socket
sock -> Socket
-> Retries -> ByteString -> QueryControls -> DNSIO DNSMessage
loop Socket
sock Retries
0 ByteString
qry QueryControls
qctls
  where
    loop :: Socket
-> Retries -> ByteString -> QueryControls -> DNSIO DNSMessage
loop Socket
sock !Retries
ntries ByteString
qry QueryControls
ctls
      | Retries
ntries Retries -> Retries -> Bool
forall a. Eq a => a -> a -> Bool
== Retries
retry = DNSError -> DNSIO DNSMessage
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DNSError -> DNSIO DNSMessage) -> DNSError -> DNSIO DNSMessage
forall a b. (a -> b) -> a -> b
$ NetworkContext -> DNSError
NetworkError NetworkContext
RetryLimitExceeded
      | Bool
otherwise       = do
          mres <- Retries -> DNSIO DNSMessage -> DNSIO (Maybe DNSMessage)
forall a. Retries -> DNSIO a -> DNSIO (Maybe a)
timeout' Retries
tmout (Socket -> ByteString -> DNSIO ()
sendUDP Socket
sock ByteString
qry DNSIO () -> DNSIO DNSMessage -> DNSIO DNSMessage
forall a b.
ExceptT DNSError IO a
-> ExceptT DNSError IO b -> ExceptT DNSError IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> QueryControls -> Socket -> DNSIO DNSMessage
getAns QueryControls
ctls Socket
sock)
          case mres of
              Maybe DNSMessage
Nothing  -> Socket
-> Retries -> ByteString -> QueryControls -> DNSIO DNSMessage
loop Socket
sock (Retries
ntries Retries -> Retries -> Retries
forall a. Num a => a -> a -> a
+ Retries
1) ByteString
qry QueryControls
ctls
              Just DNSMessage
res -> do
                      let fl :: DNSFlags
fl = DNSMessage -> DNSFlags
dnsMsgFl DNSMessage
res
                          tc :: Bool
tc = DNSFlags -> DNSFlags -> Bool
hasAnyFlags DNSFlags
TCflag DNSFlags
fl
                          rc :: RCODE
rc = DNSMessage -> RCODE
dnsMsgRC DNSMessage
res
                          eh :: Maybe EDNS
eh = DNSMessage -> Maybe EDNS
dnsMsgEx DNSMessage
res
                          cs :: QueryControls
cs = QueryControls
EdnsDisabled QueryControls -> QueryControls -> QueryControls
forall a. Semigroup a => a -> a -> a
<> QueryControls
ctls
                      if | Bool
tc -> Nameserver -> Word16 -> TcpLookup
tcpLookup Nameserver
ns Word16
ident Retries
tmout DnsTriple
q QueryControls
qctls ResolvSeed
seed
                         | RCODE
rc RCODE -> RCODE -> Bool
forall a. Eq a => a -> a -> Bool
== RCODE
FORMERR Bool -> Bool -> Bool
&& Maybe EDNS -> Bool
forall a. Maybe a -> Bool
isNothing Maybe EDNS
eh Bool -> Bool -> Bool
&& QueryControls -> Bool
hasEDNS QueryControls
ctls
                         , Bool
False <- DNSFlags -> DNSFlags -> Bool
hasAnyFlags DNSFlags
DOflag (DNSFlags -> Bool) -> DNSFlags -> Bool
forall a b. (a -> b) -> a -> b
$ QueryControls -> DNSFlags
makeQueryFlags QueryControls
qctls
                         , Right ByteString
qry' <- Word16 -> QueryControls -> DnsTriple -> Either DNSError ByteString
encodeQuestion Word16
ident QueryControls
cs DnsTriple
q
                            -- Retry without EDNS when DNSSEC was not requested
                            -- and a non-EDNS response to an EDNS query
                            -- returned FORMERR.
                         -> Socket
-> Retries -> ByteString -> QueryControls -> DNSIO DNSMessage
loop Socket
sock Retries
ntries ByteString
qry' QueryControls
cs
                         | Bool
otherwise -> DNSMessage -> DNSIO DNSMessage
forall a. a -> ExceptT DNSError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DNSMessage
res

    -- | Closed UDP ports are occasionally re-used for a new query, with
    -- the nameserver returning an unexpected answer to the wrong socket.
    -- Such answers should be simply dropped, with the client continuing
    -- to wait for the right answer, without resending the question.
    -- Note, this eliminates sequence mismatch as a UDP error condition,
    -- instead we'll time out if no matching answer arrives.
    --
    getAns :: QueryControls -> Socket -> DNSIO DNSMessage
    getAns :: QueryControls -> Socket -> DNSIO DNSMessage
getAns QueryControls
ctls Socket
sock = do
        bs <- Word16 -> Socket -> DNSIO ByteString
receiveUDP Word16
maxsz Socket
sock
        msg <- decodeMsg bs seed DnsOverUDP ns
        if | checkResp q ident msg -> pure msg
           | otherwise             -> getAns ctls sock
      where
        maxsz :: Word16
maxsz | QueryControls
EdnsDisabled   <- QueryControls
ctls = Word16
minUdpSize
              | EdnsUdpSize Word16
sz <- QueryControls
ctls = Word16
sz
              | Bool
otherwise = EDNS -> Word16
ednsUdpSize EDNS
defaultEDNS

----------------------------------------------------------------

-- Create a TCP socket with the given socket address.
tcpOpen :: SockAddr -> DNSIO Socket
tcpOpen :: SockAddr -> DNSIO Socket
tcpOpen SockAddr
peer = case SockAddr
peer of
    SockAddrInet{}  -> IO Socket -> DNSIO Socket
forall (m :: * -> *) a. Monad m => m a -> ExceptT DNSError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Socket -> DNSIO Socket) -> IO Socket -> DNSIO Socket
forall a b. (a -> b) -> a -> b
$ Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_INET  SocketType
Stream ProtocolNumber
defaultProtocol
    SockAddrInet6{} -> IO Socket -> DNSIO Socket
forall (m :: * -> *) a. Monad m => m a -> ExceptT DNSError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Socket -> DNSIO Socket) -> IO Socket -> DNSIO Socket
forall a b. (a -> b) -> a -> b
$ Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_INET6 SocketType
Stream ProtocolNumber
defaultProtocol
    SockAddr
_               -> DNSError -> DNSIO Socket
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DNSError -> DNSIO Socket) -> DNSError -> DNSIO Socket
forall a b. (a -> b) -> a -> b
$ NetworkContext -> DNSError
NetworkError NetworkContext
ServerFailure

-- Perform a DNS query over TCP, if we were successful in creating
-- the TCP socket.
-- This throws DNSError only.
tcpLookup :: Nameserver -> QueryID -> TcpLookup
tcpLookup :: Nameserver -> Word16 -> TcpLookup
tcpLookup Nameserver
ns Word16
ident Retries
tmout DnsTriple
q QueryControls
qctls ResolvSeed
seed =
    (DNSIO DNSMessage
 -> (DNSError -> DNSIO DNSMessage) -> DNSIO DNSMessage)
-> (DNSError -> DNSIO DNSMessage)
-> DNSIO DNSMessage
-> DNSIO DNSMessage
forall a b c. (a -> b -> c) -> b -> a -> c
flip DNSIO DNSMessage
-> (DNSError -> DNSIO DNSMessage) -> DNSIO DNSMessage
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE (Nameserver -> String -> DNSError -> DNSIO DNSMessage
ioErrorToDNSError Nameserver
ns String
"tcp") (DNSIO DNSMessage -> DNSIO DNSMessage)
-> DNSIO DNSMessage -> DNSIO DNSMessage
forall a b. (a -> b) -> a -> b
$ do
        res <- DNSIO Socket
-> (Socket -> IO ())
-> (Socket -> DNSIO DNSMessage)
-> DNSIO DNSMessage
forall a b c. DNSIO a -> (a -> IO b) -> (a -> DNSIO c) -> DNSIO c
bracket' do SockAddr -> DNSIO Socket
tcpOpen (SockAddr -> DNSIO Socket) -> SockAddr -> DNSIO Socket
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress (AddrInfo -> SockAddr) -> AddrInfo -> SockAddr
forall a b. (a -> b) -> a -> b
$ Nameserver -> AddrInfo
nsAddr Nameserver
ns
                        do close
                        do QueryControls -> Socket -> DNSIO DNSMessage
perform QueryControls
qctls
        let rc = DNSMessage -> RCODE
dnsMsgRC DNSMessage
res
            eh = DNSMessage -> Maybe EDNS
dnsMsgEx DNSMessage
res
            cs = QueryControls
EdnsDisabled QueryControls -> QueryControls -> QueryControls
forall a. Semigroup a => a -> a -> a
<> QueryControls
qctls
        -- If we first tried with EDNS, retry without on FORMERR.
        -- XXX: Move the retry into "perform", where we can reuse
        -- the same connection.
        if | rc == FORMERR && isNothing eh
           , EdnsEnabled <- qctls
             -> bracket' (tcpOpen addr) close (perform cs)
           | otherwise
             -> pure res
  where
    addr :: SockAddr
addr = AddrInfo -> SockAddr
addrAddress (AddrInfo -> SockAddr) -> AddrInfo -> SockAddr
forall a b. (a -> b) -> a -> b
$ Nameserver -> AddrInfo
nsAddr Nameserver
ns
    perform :: QueryControls -> Socket -> DNSIO DNSMessage
perform QueryControls
ctls Socket
sock =
        case Word16 -> QueryControls -> DnsTriple -> Either DNSError ByteString
encodeQuestionLP Word16
ident QueryControls
ctls DnsTriple
q of
            Left DNSError
err -> DNSError -> DNSIO DNSMessage
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE DNSError
err
            Right ByteString
qry -> do
                mres <- Retries -> DNSIO ByteString -> DNSIO (Maybe ByteString)
forall a. Retries -> DNSIO a -> DNSIO (Maybe a)
timeout' Retries
tmout (DNSIO ByteString -> DNSIO (Maybe ByteString))
-> DNSIO ByteString -> DNSIO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ do
                    IO () -> DNSIO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT DNSError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> DNSIO ()) -> IO () -> DNSIO ()
forall a b. (a -> b) -> a -> b
$ Socket -> SockAddr -> IO ()
connect Socket
sock SockAddr
addr
                    Socket -> ByteString -> DNSIO ()
sendTCP Socket
sock ByteString
qry
                    Socket -> DNSIO ByteString
receiveTCP Socket
sock
                case mres of
                    Maybe ByteString
Nothing -> DNSError -> DNSIO DNSMessage
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DNSError -> DNSIO DNSMessage) -> DNSError -> DNSIO DNSMessage
forall a b. (a -> b) -> a -> b
$ NetworkContext -> DNSError
NetworkError NetworkContext
TimeoutExpired
                    Just ByteString
bs -> do
                        msg <- ByteString
-> ResolvSeed -> DnsXprt -> Nameserver -> DNSIO DNSMessage
decodeMsg ByteString
bs ResolvSeed
seed DnsXprt
DnsOverTCP Nameserver
ns
                        maybe (pure msg) throwE $ checkRespM q ident msg

decodeMsg :: ByteString
          -> ResolvSeed
          -> DnsXprt
          -> Nameserver
          -> DNSIO DNSMessage
decodeMsg :: ByteString
-> ResolvSeed -> DnsXprt -> Nameserver -> DNSIO DNSMessage
decodeMsg ByteString
bs ResolvSeed
seed DnsXprt
dnsPeerXprt ns :: Nameserver
ns@(AddrInfo -> SockAddr
addrAddress (AddrInfo -> SockAddr)
-> (Nameserver -> AddrInfo) -> Nameserver -> SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nameserver -> AddrInfo
nsAddr -> SockAddrInet PortNumber
sin_port HostAddress
sin_addr) = do
    Elapsed (Seconds now) <- IO Elapsed -> ExceptT DNSError IO Elapsed
forall (m :: * -> *) a. Monad m => m a -> ExceptT DNSError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO Elapsed
timeCurrent
    either throwE pure $ decodeAtWith now True dec bs
  where
    dnsPeerAddr :: IP
dnsPeerAddr = IPv4 -> IP
IP.IPv4 (IPv4 -> IP) -> IPv4 -> IP
forall a b. (a -> b) -> a -> b
$ HostAddress -> IPv4
IP.fromHostAddress HostAddress
sin_addr
    dnsPeerPort :: Word16
dnsPeerPort = PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
sin_port
    dnsPeerName :: Maybe String
dnsPeerName = Nameserver -> Maybe String
nsName Nameserver
ns
    dec :: SGet DNSMessage
dec = (SGetEnv -> SGetEnv) -> SGet DNSMessage -> SGet DNSMessage
forall a. (SGetEnv -> SGetEnv) -> SGet a -> SGet a
local (MessageSource -> SGetEnv -> SGetEnv
setDecodeSource MessageSource{Maybe String
Word16
IP
DnsXprt
dnsPeerXprt :: DnsXprt
dnsPeerAddr :: IP
dnsPeerPort :: Word16
dnsPeerName :: Maybe String
dnsPeerPort :: Word16
dnsPeerAddr :: IP
dnsPeerName :: Maybe String
dnsPeerXprt :: DnsXprt
..})
                (RDataMap -> OptionMap -> SGet DNSMessage
getMessage (ResolvSeed -> RDataMap
seedRDataMap ResolvSeed
seed) (ResolvSeed -> OptionMap
seedOptionMap ResolvSeed
seed))

decodeMsg ByteString
bs ResolvSeed
seed DnsXprt
dnsPeerXprt ns :: Nameserver
ns@(AddrInfo -> SockAddr
addrAddress (AddrInfo -> SockAddr)
-> (Nameserver -> AddrInfo) -> Nameserver -> SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nameserver -> AddrInfo
nsAddr -> SockAddrInet6 PortNumber
sin6_port HostAddress
_ HostAddress6
sin6_addr HostAddress
_) = do
    Elapsed (Seconds now) <- IO Elapsed -> ExceptT DNSError IO Elapsed
forall (m :: * -> *) a. Monad m => m a -> ExceptT DNSError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO Elapsed
timeCurrent
    either throwE pure $ decodeAtWith now True dec bs
  where
    dnsPeerAddr :: IP
dnsPeerAddr = IPv6 -> IP
IP.IPv6 (IPv6 -> IP) -> IPv6 -> IP
forall a b. (a -> b) -> a -> b
$ HostAddress6 -> IPv6
IP.fromHostAddress6 HostAddress6
sin6_addr
    dnsPeerPort :: Word16
dnsPeerPort = PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
sin6_port
    dnsPeerName :: Maybe String
dnsPeerName = Nameserver -> Maybe String
nsName Nameserver
ns
    dec :: SGet DNSMessage
dec = (SGetEnv -> SGetEnv) -> SGet DNSMessage -> SGet DNSMessage
forall a. (SGetEnv -> SGetEnv) -> SGet a -> SGet a
local (MessageSource -> SGetEnv -> SGetEnv
setDecodeSource MessageSource{Maybe String
Word16
IP
DnsXprt
dnsPeerPort :: Word16
dnsPeerAddr :: IP
dnsPeerName :: Maybe String
dnsPeerXprt :: DnsXprt
dnsPeerXprt :: DnsXprt
dnsPeerAddr :: IP
dnsPeerPort :: Word16
dnsPeerName :: Maybe String
..})
                (RDataMap -> OptionMap -> SGet DNSMessage
getMessage (ResolvSeed -> RDataMap
seedRDataMap ResolvSeed
seed) (ResolvSeed -> OptionMap
seedOptionMap ResolvSeed
seed))

decodeMsg ByteString
bs ResolvSeed
seed DnsXprt
_ Nameserver
_ = do
    Elapsed (Seconds now) <- IO Elapsed -> ExceptT DNSError IO Elapsed
forall (m :: * -> *) a. Monad m => m a -> ExceptT DNSError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO Elapsed
timeCurrent
    either throwE pure $ decodeAtWith now True dec bs
  where
    dec :: SGet DNSMessage
dec = RDataMap -> OptionMap -> SGet DNSMessage
getMessage (ResolvSeed -> RDataMap
seedRDataMap ResolvSeed
seed) (ResolvSeed -> OptionMap
seedOptionMap ResolvSeed
seed)