{-# LANGUAGE RecordWildCards #-}

module Network.DNS.LookupRaw (
  -- * Lookups returning requested RData
    lookup
  , lookupAuth
  -- * Lookups returning DNS Messages
  , lookupRaw
  , lookupRawCtl
  , lookupRawCtlRecv
  -- * DNS Message procesing
  , fromDNSMessage
  ) where

import Data.Hourglass (timeAdd, Seconds)
import Prelude hiding (lookup)
import Time.System (timeCurrent)
import Network.Socket (Socket)

import Network.DNS.IO
import Network.DNS.Imports hiding (lookup)
import Network.DNS.Memo
import Network.DNS.Transport
import Network.DNS.Types.Internal
import Network.DNS.Types.Resolver

-- $setup
-- >>> import Network.DNS.Resolver

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

-- | Look up resource records of a specified type for a domain,
--   collecting the results
--   from the ANSWER section of the response.
--   See the documentation of 'lookupRaw'
--   to understand the concrete behavior.
--   Cache is used if 'resolvCache' is 'Just'.
--
--   Example:
--
--   >>> rs <- makeResolvSeed defaultResolvConf
--   >>> withResolver rs $ \resolver -> lookup resolver "www.example.com" A
--   Right [93.184.216.34]
--
lookup :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])
lookup :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])
lookup = Section
-> Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])
lookupSection Section
Answer

-- | Look up resource records of a specified type for a domain,
--   collecting the results
--   from the AUTHORITY section of the response.
--   See the documentation of 'lookupRaw'
--   to understand the concrete behavior.
--   Cache is used even if 'resolvCache' is 'Just'.
lookupAuth :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])
lookupAuth :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])
lookupAuth = Section
-> Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])
lookupSection Section
Authority

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

-- | Looking up resource records of a domain. The first parameter is one of
--   the field accessors of the 'DNSMessage' type -- this allows you to
--   choose which section (answer, authority, or additional) you would like
--   to inspect for the result.

lookupSection :: Section
              -> Resolver
              -> Domain
              -> TYPE
              -> IO (Either DNSError [RData])
lookupSection :: Section
-> Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])
lookupSection Section
section Resolver
rlv Domain
dom TYPE
typ
  | Section
section forall a. Eq a => a -> a -> Bool
== Section
Authority = Resolver
-> Domain -> TYPE -> Section -> IO (Either DNSError [RData])
lookupFreshSection Resolver
rlv Domain
dom TYPE
typ Section
section
  | Bool
otherwise = case Maybe CacheConf
mcacheConf of
      Maybe CacheConf
Nothing           -> Resolver
-> Domain -> TYPE -> Section -> IO (Either DNSError [RData])
lookupFreshSection Resolver
rlv Domain
dom TYPE
typ Section
section
      Just CacheConf
cacheconf    -> Resolver
-> Domain -> TYPE -> CacheConf -> IO (Either DNSError [RData])
lookupCacheSection Resolver
rlv Domain
dom TYPE
typ CacheConf
cacheconf
  where
    mcacheConf :: Maybe CacheConf
mcacheConf = ResolvConf -> Maybe CacheConf
resolvCache forall a b. (a -> b) -> a -> b
$ ResolvSeed -> ResolvConf
resolvconf forall a b. (a -> b) -> a -> b
$ Resolver -> ResolvSeed
resolvseed Resolver
rlv

lookupFreshSection :: Resolver
                   -> Domain
                   -> TYPE
                   -> Section
                   -> IO (Either DNSError [RData])
lookupFreshSection :: Resolver
-> Domain -> TYPE -> Section -> IO (Either DNSError [RData])
lookupFreshSection Resolver
rlv Domain
dom TYPE
typ Section
section = do
    Either DNSError DNSMessage
eans <- Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage)
lookupRaw Resolver
rlv Domain
dom TYPE
typ
    case Either DNSError DNSMessage
eans of
      Left DNSError
err  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left DNSError
err
      Right DNSMessage
ans -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. DNSMessage -> (DNSMessage -> a) -> Either DNSError a
fromDNSMessage DNSMessage
ans DNSMessage -> [RData]
toRData
  where
    correct :: ResourceRecord -> Bool
correct ResourceRecord{CLASS
TTL
Domain
TYPE
RData
rrname :: ResourceRecord -> Domain
rrtype :: ResourceRecord -> TYPE
rrclass :: ResourceRecord -> CLASS
rrttl :: ResourceRecord -> TTL
rdata :: ResourceRecord -> RData
rdata :: RData
rrttl :: TTL
rrclass :: CLASS
rrtype :: TYPE
rrname :: Domain
..} = TYPE
rrtype forall a. Eq a => a -> a -> Bool
== TYPE
typ
    toRData :: DNSMessage -> [RData]
toRData = forall a b. (a -> b) -> [a] -> [b]
map ResourceRecord -> RData
rdata forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ResourceRecord -> Bool
correct forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSMessage -> [ResourceRecord]
sectionF
    sectionF :: DNSMessage -> [ResourceRecord]
sectionF = case Section
section of
      Section
Answer    -> DNSMessage -> [ResourceRecord]
answer
      Section
Authority -> DNSMessage -> [ResourceRecord]
authority

lookupCacheSection :: Resolver
                   -> Domain
                   -> TYPE
                   -> CacheConf
                   -> IO (Either DNSError [RData])
lookupCacheSection :: Resolver
-> Domain -> TYPE -> CacheConf -> IO (Either DNSError [RData])
lookupCacheSection Resolver
rlv Domain
dom TYPE
typ CacheConf
cconf = do
    Maybe (Prio, Either DNSError [RData])
mx <- Key -> Cache -> IO (Maybe (Prio, Either DNSError [RData]))
lookupCache (Domain
dom,TYPE
typ) Cache
c
    case Maybe (Prio, Either DNSError [RData])
mx of
      Maybe (Prio, Either DNSError [RData])
Nothing -> do
          Either DNSError DNSMessage
eans <- Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage)
lookupRaw Resolver
rlv Domain
dom TYPE
typ
          case Either DNSError DNSMessage
eans of
            Left  DNSError
err ->
                -- Probably a network error happens.
                -- We do not cache anything.
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left DNSError
err
            Right DNSMessage
ans -> do
                let ex :: Either DNSError [ResourceRecord]
ex = forall a. DNSMessage -> (DNSMessage -> a) -> Either DNSError a
fromDNSMessage DNSMessage
ans DNSMessage -> [ResourceRecord]
toRR
                case Either DNSError [ResourceRecord]
ex of
                  Left DNSError
NameError -> do
                      let v :: Either DNSError b
v = forall a b. a -> Either a b
Left DNSError
NameError
                      CacheConf
-> Cache -> Key -> Either DNSError [RData] -> DNSMessage -> IO ()
cacheNegative CacheConf
cconf Cache
c Key
key forall {b}. Either DNSError b
v DNSMessage
ans
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall {b}. Either DNSError b
v
                  Left DNSError
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left DNSError
e
                  Right [] -> do
                      let v :: Either a [a]
v = forall a b. b -> Either a b
Right []
                      CacheConf
-> Cache -> Key -> Either DNSError [RData] -> DNSMessage -> IO ()
cacheNegative CacheConf
cconf Cache
c Key
key forall {a} {a}. Either a [a]
v DNSMessage
ans
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall {a} {a}. Either a [a]
v
                  Right [ResourceRecord]
rss -> do
                      CacheConf -> Cache -> Key -> [ResourceRecord] -> IO ()
cachePositive CacheConf
cconf Cache
c Key
key [ResourceRecord]
rss
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ResourceRecord -> RData
rdata [ResourceRecord]
rss
      Just (Prio
_,Either DNSError [RData]
x) -> forall (m :: * -> *) a. Monad m => a -> m a
return Either DNSError [RData]
x
  where
    toRR :: DNSMessage -> [ResourceRecord]
toRR = forall a. (a -> Bool) -> [a] -> [a]
filter (TYPE
typ TYPE -> ResourceRecord -> Bool
`isTypeOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSMessage -> [ResourceRecord]
answer
    Just Cache
c = Resolver -> Maybe Cache
cache Resolver
rlv
    key :: Key
key = (Domain
dom,TYPE
typ)

cachePositive :: CacheConf -> Cache -> Key -> [ResourceRecord] -> IO ()
cachePositive :: CacheConf -> Cache -> Key -> [ResourceRecord] -> IO ()
cachePositive CacheConf
cconf Cache
c Key
key [ResourceRecord]
rss
  | TTL
ttl forall a. Eq a => a -> a -> Bool
== TTL
0  = forall (m :: * -> *) a. Monad m => a -> m a
return () -- does not cache anything
  | Bool
otherwise = CacheConf
-> Cache -> Key -> Either DNSError [RData] -> TTL -> IO ()
insertPositive CacheConf
cconf Cache
c Key
key (forall a b. b -> Either a b
Right [RData]
rds) TTL
ttl
  where
    rds :: [RData]
rds = forall a b. (a -> b) -> [a] -> [b]
map ResourceRecord -> RData
rdata [ResourceRecord]
rss
    ttl :: TTL
ttl = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ResourceRecord -> TTL
rrttl [ResourceRecord]
rss -- rss is non-empty

insertPositive :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO ()
insertPositive :: CacheConf
-> Cache -> Key -> Either DNSError [RData] -> TTL -> IO ()
insertPositive CacheConf{Int
TTL
maximumTTL :: CacheConf -> TTL
pruningDelay :: CacheConf -> Int
pruningDelay :: Int
maximumTTL :: TTL
..} Cache
c Key
k Either DNSError [RData]
v TTL
ttl = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TTL
ttl forall a. Eq a => a -> a -> Bool
/= TTL
0) forall a b. (a -> b) -> a -> b
$ do
    Prio
ctime <- IO Prio
timeCurrent
    let tim :: Prio
tim = Prio
ctime forall t ti. (Time t, TimeInterval ti) => t -> ti -> t
`timeAdd` Seconds
life
    Key -> Prio -> Either DNSError [RData] -> Cache -> IO ()
insertCache Key
k Prio
tim Either DNSError [RData]
v Cache
c
  where
    life :: Seconds
    life :: Seconds
life = forall a b. (Integral a, Num b) => a -> b
fromIntegral (TTL
maximumTTL forall a. Ord a => a -> a -> a
`min` TTL
ttl)

cacheNegative :: CacheConf -> Cache -> Key -> Entry -> DNSMessage -> IO ()
cacheNegative :: CacheConf
-> Cache -> Key -> Either DNSError [RData] -> DNSMessage -> IO ()
cacheNegative CacheConf
cconf Cache
c Key
key Either DNSError [RData]
v DNSMessage
ans = case [ResourceRecord]
soas of
  []    -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- does not cache anything
  ResourceRecord
soa:[ResourceRecord]
_ -> CacheConf
-> Cache -> Key -> Either DNSError [RData] -> TTL -> IO ()
insertNegative CacheConf
cconf Cache
c Key
key Either DNSError [RData]
v forall a b. (a -> b) -> a -> b
$ ResourceRecord -> TTL
rrttl ResourceRecord
soa
  where
    soas :: [ResourceRecord]
soas = forall a. (a -> Bool) -> [a] -> [a]
filter (TYPE
SOA TYPE -> ResourceRecord -> Bool
`isTypeOf`) forall a b. (a -> b) -> a -> b
$ DNSMessage -> [ResourceRecord]
authority DNSMessage
ans

insertNegative :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO ()
insertNegative :: CacheConf
-> Cache -> Key -> Either DNSError [RData] -> TTL -> IO ()
insertNegative CacheConf
_ Cache
c Key
k Either DNSError [RData]
v TTL
ttl = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TTL
ttl forall a. Eq a => a -> a -> Bool
/= TTL
0) forall a b. (a -> b) -> a -> b
$ do
    Prio
ctime <- IO Prio
timeCurrent
    let tim :: Prio
tim = Prio
ctime forall t ti. (Time t, TimeInterval ti) => t -> ti -> t
`timeAdd` Seconds
life
    Key -> Prio -> Either DNSError [RData] -> Cache -> IO ()
insertCache Key
k Prio
tim Either DNSError [RData]
v Cache
c
  where
    life :: Seconds
    life :: Seconds
life = forall a b. (Integral a, Num b) => a -> b
fromIntegral TTL
ttl

isTypeOf :: TYPE -> ResourceRecord -> Bool
isTypeOf :: TYPE -> ResourceRecord -> Bool
isTypeOf TYPE
t ResourceRecord{CLASS
TTL
Domain
TYPE
RData
rdata :: RData
rrttl :: TTL
rrclass :: CLASS
rrtype :: TYPE
rrname :: Domain
rrname :: ResourceRecord -> Domain
rrtype :: ResourceRecord -> TYPE
rrclass :: ResourceRecord -> CLASS
rrttl :: ResourceRecord -> TTL
rdata :: ResourceRecord -> RData
..} = TYPE
rrtype forall a. Eq a => a -> a -> Bool
== TYPE
t

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

-- | Look up a name and return the entire DNS Response.
--
-- For a given DNS server, the queries are done:
--
--  * A new UDP socket bound to a new local port is created and
--    a new identifier is created atomically from the cryptographically
--    secure pseudo random number generator for the target DNS server.
--    Then UDP queries are tried with the limitation of 'resolvRetry'
--    (use EDNS if specifiecd).
--    If it appears that the target DNS server does not support EDNS,
--    it falls back to traditional queries.
--
--  * If the response is truncated, a new TCP socket bound to a new
--    local port is created. Then exactly one TCP query is retried.
--
--
-- If multiple DNS servers are specified 'ResolvConf' ('RCHostNames ')
-- or found ('RCFilePath'), either sequential lookup or
-- concurrent lookup is carried out:
--
--  * In sequential lookup ('resolvConcurrent' is False),
--    the query procedure above is processed
--    in the order of the DNS servers sequentially until a successful
--    response is received.
--
--  * In concurrent lookup ('resolvConcurrent' is True),
--    the query procedure above is processed
--    for each DNS server concurrently.
--    The first received response is accepted even if
--    it is an error.
--
--  Cache is not used even if 'resolvCache' is 'Just'.
--
--
--   The example code:
--
--   @
--   rs <- makeResolvSeed defaultResolvConf
--   withResolver rs $ \\resolver -> lookupRaw resolver \"www.example.com\" A
--   @
--
--   And the (formatted) expected output:
--
--   @
--   Right (DNSMessage
--           { header = DNSHeader
--                        { identifier = 1,
--                          flags = DNSFlags
--                                    { qOrR = QR_Response,
--                                      opcode = OP_STD,
--                                      authAnswer = False,
--                                      trunCation = False,
--                                      recDesired = True,
--                                      recAvailable = True,
--                                      rcode = NoErr,
--                                      authenData = False
--                                    },
--                        },
--             question = [Question { qname = \"www.example.com.\",
--                                    qtype = A}],
--             answer = [ResourceRecord {rrname = \"www.example.com.\",
--                                       rrtype = A,
--                                       rrttl = 800,
--                                       rdlen = 4,
--                                       rdata = 93.184.216.119}],
--             authority = [],
--             additional = []})
--  @
--
--  AXFR requests cannot be performed with this interface.
--
--   >>> rs <- makeResolvSeed defaultResolvConf
--   >>> withResolver rs $ \resolver -> lookupRaw resolver "mew.org" AXFR
--   Left InvalidAXFRLookup
--
lookupRaw :: Resolver   -- ^ Resolver obtained via 'withResolver'
          -> Domain     -- ^ Query domain
          -> TYPE       -- ^ Query RRtype
          -> IO (Either DNSError DNSMessage)
lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage)
lookupRaw Resolver
rslv Domain
dom TYPE
typ = Resolver
-> Domain
-> TYPE
-> QueryControls
-> IO (Either DNSError DNSMessage)
lookupRawCtl Resolver
rslv Domain
dom TYPE
typ forall a. Monoid a => a
mempty

-- | Similar to 'lookupRaw', but the default values of the RD, AD, CD and DO
-- flag bits, as well as various EDNS features, can be adjusted via the
-- 'QueryControls' parameter.
--
lookupRawCtl :: Resolver      -- ^ Resolver obtained via 'withResolver'
             -> Domain        -- ^ Query domain
             -> TYPE          -- ^ Query RRtype
             -> QueryControls -- ^ Query flag and EDNS overrides
             -> IO (Either DNSError DNSMessage)
lookupRawCtl :: Resolver
-> Domain
-> TYPE
-> QueryControls
-> IO (Either DNSError DNSMessage)
lookupRawCtl Resolver
rslv Domain
dom TYPE
typ QueryControls
ctls = Resolver -> Domain -> TYPE -> Rslv0
resolve Resolver
rslv Domain
dom TYPE
typ QueryControls
ctls Socket -> IO DNSMessage
receive

-- | Similar to 'lookupRawCtl', but the recv action can be replaced with
-- something other than `Network.DNS.IO.receive`.
-- For example, in an environment where frequent retrieval of the current time
-- is a performance issue, you can pass the time from outside instead of
-- having `Network.DNS.IO.receive` retrieve the current time.
lookupRawCtlRecv :: Resolver                  -- ^ Resolver obtained via 'withResolver'
                 -> Domain                    -- ^ Query domain
                 -> TYPE                      -- ^ Query RRtype
                 -> QueryControls             -- ^ Query flag and EDNS overrides
                 -> (Socket -> IO DNSMessage) -- ^ Action to receive message from socket
                 -> IO (Either DNSError DNSMessage)
lookupRawCtlRecv :: Resolver -> Domain -> TYPE -> Rslv0
lookupRawCtlRecv = Resolver -> Domain -> TYPE -> Rslv0
resolve

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

-- | Messages with a non-error RCODE are passed to the supplied function
-- for processing.  Other messages are translated to 'DNSError' instances.
--
-- Note that 'NameError' is not a lookup error.  The lookup is successful,
-- bearing the sad news that the requested domain does not exist.  'NameError'
-- responses may return a meaningful AD bit, may contain useful data in the
-- authority section, and even initial CNAME records that lead to the
-- ultimately non-existent domain.  Applications that wish to process the
-- content of 'NameError' (NXDomain) messages will need to implement their
-- own RCODE handling.
--
fromDNSMessage :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a
fromDNSMessage :: forall a. DNSMessage -> (DNSMessage -> a) -> Either DNSError a
fromDNSMessage DNSMessage
ans DNSMessage -> a
conv = case DNSMessage -> RCODE
errcode DNSMessage
ans of
    RCODE
NoErr     -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ DNSMessage -> a
conv DNSMessage
ans
    RCODE
FormatErr -> forall a b. a -> Either a b
Left DNSError
FormatError
    RCODE
ServFail  -> forall a b. a -> Either a b
Left DNSError
ServerFailure
    RCODE
NameErr   -> forall a b. a -> Either a b
Left DNSError
NameError
    RCODE
NotImpl   -> forall a b. a -> Either a b
Left DNSError
NotImplemented
    RCODE
Refused   -> forall a b. a -> Either a b
Left DNSError
OperationRefused
    RCODE
BadVers   -> forall a b. a -> Either a b
Left DNSError
BadOptRecord
    RCODE
BadRCODE  -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> DNSError
DecodeError String
"Malformed EDNS message"
    RCODE
_         -> forall a b. a -> Either a b
Left DNSError
UnknownDNSError
  where
    errcode :: DNSMessage -> RCODE
errcode = DNSFlags -> RCODE
rcode forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSHeader -> DNSFlags
flags forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSMessage -> DNSHeader
header