-- |
-- Module      : Net.DNSBase.Internal.Error
-- Description : DNS protocol and library error types
-- 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.Error
    ( DNSError(..)
    , DecodeContext(..)
    , DnsSection(..)
    , DnsXprt(..)
    , MessageSource(..)
    , NetworkContext(..)
    , ProtocolContext(..)
    , UserContext(..)
    , EncodeErr(..)
    , EncodeContext(..)
    ) where

import Control.Exception (Exception, IOException)

import Net.DNSBase.Internal.Domain
import Net.DNSBase.Internal.Peer
import Net.DNSBase.Internal.Present
import Net.DNSBase.Internal.RCODE (RCODE)
import Net.DNSBase.Internal.RRTYPE (RRTYPE)
import Net.DNSBase.Internal.Util

-- | DNS API errors.
--
data DNSError
    = BadConfiguration String
      -- ^ Resolver misconfiguration.
    | BadNameserver IOException
      -- ^ Nameserver name -> address lookup failure.
    | DecodeError DecodeContext String
      -- ^ Error while decoding from wire form.
    | EncodeError EncodeContext
      -- ^ Error while encoding to wire form.
    | InvalidDomain String
      -- ^ Invalid domain name presentation form.
    | NetworkError NetworkContext
      -- ^ Error in connection establishment, data transmission or a timeout.
    | ProtocolError ProtocolContext
      -- ^ Unexpected DNS message.
    | ResponseError RCODE
      -- ^ DNS message indicates a remote error condition.
    | UserError UserContext
      -- ^ Invalid request.
    deriving (DNSError -> DNSError -> Bool
(DNSError -> DNSError -> Bool)
-> (DNSError -> DNSError -> Bool) -> Eq DNSError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DNSError -> DNSError -> Bool
== :: DNSError -> DNSError -> Bool
$c/= :: DNSError -> DNSError -> Bool
/= :: DNSError -> DNSError -> Bool
Eq)

instance Exception DNSError
instance Show DNSError where
    showsPrec :: Int -> DNSError -> ShowS
showsPrec Int
_ (BadConfiguration String
rc) = String -> ShowS
showString String
"Configuration error: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                        String -> ShowS
showString String
rc
    showsPrec Int
_ (BadNameserver IOException
io)    = String -> ShowS
showString String
"Unusable nameserver: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                        IOException -> ShowS
forall a. Show a => a -> ShowS
shows IOException
io
    showsPrec Int
_ (DecodeError DecodeContext
ctx String
str) = String -> ShowS
showString String
"Decode error: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                        DecodeContext -> ShowS
forall a. Presentable a => a -> ShowS
presentString DecodeContext
ctx ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
str
    showsPrec Int
_ (EncodeError EncodeContext
ec)      = String -> ShowS
showString String
"encoding error: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                        EncodeContext -> ShowS
forall a. Show a => a -> ShowS
shows EncodeContext
ec
    showsPrec Int
_ (InvalidDomain String
ed)    = String -> ShowS
showString String
"invalid domain: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                        String -> ShowS
showString String
ed
    showsPrec Int
_ (NetworkError NetworkContext
en)     = NetworkContext -> ShowS
forall a. Show a => a -> ShowS
shows NetworkContext
en
    showsPrec Int
_ (ProtocolError ProtocolContext
ep)    = ProtocolContext -> ShowS
forall a. Show a => a -> ShowS
shows ProtocolContext
ep
    showsPrec Int
_ (ResponseError RCODE
rc)    = String -> ShowS
showString String
"server error: rcode = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                        String -> ShowS
showString (RCODE -> ShowS
forall a. Presentable a => a -> ShowS
presentString RCODE
rc String
forall a. Monoid a => a
mempty)
    showsPrec Int
_ (UserError UserContext
eu)        = UserContext -> ShowS
forall a. Show a => a -> ShowS
shows UserContext
eu

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

-- | Request or response context in which a failure occurred.  The
-- `decodeTriple` holds the name, class and type of the problem RR, provided
-- the error was not in one of those fields.
data DecodeContext
    = DecodeContext
    { DecodeContext -> DnsSection
decodeSection :: DnsSection
    , DecodeContext -> Maybe MessageSource
decodeSource  :: Maybe MessageSource
    , DecodeContext -> Maybe DnsTriple
decodeTriple  :: Maybe DnsTriple
    } deriving (DecodeContext -> DecodeContext -> Bool
(DecodeContext -> DecodeContext -> Bool)
-> (DecodeContext -> DecodeContext -> Bool) -> Eq DecodeContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecodeContext -> DecodeContext -> Bool
== :: DecodeContext -> DecodeContext -> Bool
$c/= :: DecodeContext -> DecodeContext -> Bool
/= :: DecodeContext -> DecodeContext -> Bool
Eq)

instance Presentable DecodeContext where
    present :: DecodeContext -> Builder -> Builder
present DecodeContext {Maybe MessageSource
Maybe DnsTriple
DnsSection
decodeTriple :: DecodeContext -> Maybe DnsTriple
decodeSection :: DecodeContext -> DnsSection
decodeSource :: DecodeContext -> Maybe MessageSource
decodeSection :: DnsSection
decodeSource :: Maybe MessageSource
decodeTriple :: Maybe DnsTriple
..} =
        (Builder -> Builder)
-> (MessageSource -> Builder -> Builder)
-> Maybe MessageSource
-> Builder
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder -> Builder
forall a. a -> a
id ((forall a. Presentable a => a -> Builder -> Builder
present @String String
"from" (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Builder -> Builder) -> Builder -> Builder)
-> (MessageSource -> Builder -> Builder)
-> MessageSource
-> Builder
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageSource -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
presentSp) Maybe MessageSource
decodeSource
        (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Presentable a => a -> Builder -> Builder
presentSp @String String
"in" (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DnsSection -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
presentSp DnsSection
decodeSection
        (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder -> Builder)
-> (DnsTriple -> Builder -> Builder)
-> Maybe DnsTriple
-> Builder
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder -> Builder
forall a. a -> a
id ((forall a. Presentable a => a -> Builder -> Builder
presentSp @String String
"at" (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Builder -> Builder) -> Builder -> Builder)
-> (DnsTriple -> Builder -> Builder)
-> DnsTriple
-> Builder
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DnsTriple -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
presentSp) Maybe DnsTriple
decodeTriple

-- | Message /section/ for error reporting.  The message header and EDNS @OPT@
-- record are also considered /sections/ in this context.
data DnsSection
    = DnsHeaderSection
      -- ^ While parsing the message header.
    | DnsQuestionSection
      -- ^ While parsing the question section.
    | DnsAnswerSection
      -- ^ While parsing the answer section.
    | DnsAuthoritySection
      -- ^ While parsing the authority section.
    | DnsAdditionalSection
      -- ^ While parsing the additional section.
    | DnsEDNSSection
      -- ^ While parsing the EDNS OPT record.
    | DnsNonSection
      -- ^ While parsing a wire-form message fragment.
  deriving (DnsSection -> DnsSection -> Bool
(DnsSection -> DnsSection -> Bool)
-> (DnsSection -> DnsSection -> Bool) -> Eq DnsSection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DnsSection -> DnsSection -> Bool
== :: DnsSection -> DnsSection -> Bool
$c/= :: DnsSection -> DnsSection -> Bool
/= :: DnsSection -> DnsSection -> Bool
Eq, Int -> DnsSection -> ShowS
[DnsSection] -> ShowS
DnsSection -> String
(Int -> DnsSection -> ShowS)
-> (DnsSection -> String)
-> ([DnsSection] -> ShowS)
-> Show DnsSection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DnsSection -> ShowS
showsPrec :: Int -> DnsSection -> ShowS
$cshow :: DnsSection -> String
show :: DnsSection -> String
$cshowList :: [DnsSection] -> ShowS
showList :: [DnsSection] -> ShowS
Show)

instance Presentable DnsSection where
    present :: DnsSection -> Builder -> Builder
present DnsSection
DnsHeaderSection     = forall a. Presentable a => a -> Builder -> Builder
present @String String
"the message header"
    present DnsSection
DnsQuestionSection   = forall a. Presentable a => a -> Builder -> Builder
present @String String
"the question section"
    present DnsSection
DnsAnswerSection     = forall a. Presentable a => a -> Builder -> Builder
present @String String
"the answer section"
    present DnsSection
DnsAuthoritySection  = forall a. Presentable a => a -> Builder -> Builder
present @String String
"the authority section"
    present DnsSection
DnsAdditionalSection = forall a. Presentable a => a -> Builder -> Builder
present @String String
"the additional section"
    present DnsSection
DnsEDNSSection       = forall a. Presentable a => a -> Builder -> Builder
present @String String
"an EDNS OPT pseudo-RR"
    present DnsSection
DnsNonSection        = forall a. Presentable a => a -> Builder -> Builder
present @String String
"a wire-form fragment"

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

data NetworkContext =
    -- | The number of retries for the request was exceeded.
    RetryLimitExceeded
    -- | TCP fallback request timed out.
  | TimeoutExpired
    -- | Network failure.
  | NetworkFailure IOException
  | ServerFailure
  deriving (NetworkContext -> NetworkContext -> Bool
(NetworkContext -> NetworkContext -> Bool)
-> (NetworkContext -> NetworkContext -> Bool) -> Eq NetworkContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NetworkContext -> NetworkContext -> Bool
== :: NetworkContext -> NetworkContext -> Bool
$c/= :: NetworkContext -> NetworkContext -> Bool
/= :: NetworkContext -> NetworkContext -> Bool
Eq, Int -> NetworkContext -> ShowS
[NetworkContext] -> ShowS
NetworkContext -> String
(Int -> NetworkContext -> ShowS)
-> (NetworkContext -> String)
-> ([NetworkContext] -> ShowS)
-> Show NetworkContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkContext -> ShowS
showsPrec :: Int -> NetworkContext -> ShowS
$cshow :: NetworkContext -> String
show :: NetworkContext -> String
$cshowList :: [NetworkContext] -> ShowS
showList :: [NetworkContext] -> ShowS
Show)

data ProtocolContext =
    -- ^ The sequence number of the answer doesn't match our query. This
    --   could indicate foul play.
    SequenceNumberMismatch
    -- ^ The question section of the response doesn't match our query. This
    --   could indicate foul play.
  | QuestionMismatch
  deriving (ProtocolContext -> ProtocolContext -> Bool
(ProtocolContext -> ProtocolContext -> Bool)
-> (ProtocolContext -> ProtocolContext -> Bool)
-> Eq ProtocolContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProtocolContext -> ProtocolContext -> Bool
== :: ProtocolContext -> ProtocolContext -> Bool
$c/= :: ProtocolContext -> ProtocolContext -> Bool
/= :: ProtocolContext -> ProtocolContext -> Bool
Eq, Int -> ProtocolContext -> ShowS
[ProtocolContext] -> ShowS
ProtocolContext -> String
(Int -> ProtocolContext -> ShowS)
-> (ProtocolContext -> String)
-> ([ProtocolContext] -> ShowS)
-> Show ProtocolContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProtocolContext -> ShowS
showsPrec :: Int -> ProtocolContext -> ShowS
$cshow :: ProtocolContext -> String
show :: ProtocolContext -> String
$cshowList :: [ProtocolContext] -> ShowS
showList :: [ProtocolContext] -> ShowS
Show)

data UserContext =
    -- | The RRTYPE requested is invalid for queries.
    InvalidQueryType RRTYPE
    -- | The domain for query is illegal.
  | IllegalDomain String
    -- | The response message question count is not equal to 1.
  | BadResponseQuestionCount Int
  deriving (UserContext -> UserContext -> Bool
(UserContext -> UserContext -> Bool)
-> (UserContext -> UserContext -> Bool) -> Eq UserContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UserContext -> UserContext -> Bool
== :: UserContext -> UserContext -> Bool
$c/= :: UserContext -> UserContext -> Bool
/= :: UserContext -> UserContext -> Bool
Eq, Int -> UserContext -> ShowS
[UserContext] -> ShowS
UserContext -> String
(Int -> UserContext -> ShowS)
-> (UserContext -> String)
-> ([UserContext] -> ShowS)
-> Show UserContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserContext -> ShowS
showsPrec :: Int -> UserContext -> ShowS
$cshow :: UserContext -> String
show :: UserContext -> String
$cshowList :: [UserContext] -> ShowS
showList :: [UserContext] -> ShowS
Show)

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

-- | Encoding error, polymorphic over the context type
data EncodeErr r where
    -- | message or field too long
    EncodeTooLong :: (Typeable r, Show r, Eq r) => r -> EncodeErr r
    -- | Invalid input
    CantEncode    :: (Typeable r, Show r, Eq r) => r -> EncodeErr r
    -- | Unencodable reserved type
    ReservedType  :: (Typeable r, Show r, Eq r) => RRTYPE -> r -> EncodeErr r
    -- | RCODE or flags require EDNS
    EDNSRequired  :: EncodeErr r

deriving instance (Eq r) => Eq (EncodeErr r)
deriving instance (Show r) => Show (EncodeErr r)

data EncodeContext = forall r. (Typeable r, Show r, Eq r) => EncodeContext (EncodeErr r)

instance Show EncodeContext where
    show :: EncodeContext -> String
show (EncodeContext EncodeErr r
err) = EncodeErr r -> String
forall a. Show a => a -> String
show EncodeErr r
err

instance Eq EncodeContext where
    (EncodeContext (EncodeTooLong (r
_a :: a))) == :: EncodeContext -> EncodeContext -> Bool
== (EncodeContext (EncodeTooLong (r
_b :: b))) =
        case teq a b of
            Just r :~: r
Refl -> r
_a r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
r
_b
            Maybe (r :~: r)
_         -> Bool
False
    (EncodeContext (CantEncode (r
_a :: a))) == (EncodeContext (CantEncode (r
_b :: b))) =
        case teq a b of
            Just r :~: r
Refl -> r
_a r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
r
_b
            Maybe (r :~: r)
_         -> Bool
False
    (EncodeContext EncodeErr r
EDNSRequired) == (EncodeContext EncodeErr r
EDNSRequired) = Bool
True
    EncodeContext
_ == EncodeContext
_ = Bool
False