{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}

module Network.DNS.Types.Internal where

import Control.Exception (Exception, IOException)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS
import Data.Char (intToDigit)
import qualified Data.Hourglass as H
import Data.IP (IP(..), IPv4, IPv6)
import qualified Data.Semigroup as Sem

import qualified Network.DNS.Base32Hex as B32
import Network.DNS.Imports

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

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

-- | This type holds the /presentation form/ of fully-qualified DNS domain
-- names encoded as ASCII A-labels, with \'.\' separators between labels.
-- Non-printing characters are escaped as @\\DDD@ (a backslash, followed by
-- three decimal digits). The special characters: @ \", \$, (, ), ;, \@,@ and
-- @\\@ are escaped by prepending a backslash.  The trailing \'.\' is optional
-- on input, but is recommended, and is always added when decoding from
-- /wire form/.
--
-- The encoding of domain names to /wire form/, e.g. for transmission in a
-- query, requires the input encodings to be valid, otherwise a 'DecodeError'
-- may be thrown. Domain names received in wire form in DNS messages are
-- escaped to this presentation form as part of decoding the 'DNSMessage'.
--
-- This form is ASCII-only. Any conversion between A-label 'ByteString's,
-- and U-label 'Text' happens at whatever layer maps user input to DNS
-- names, or presents /friendly/ DNS names to the user.  Not all users
-- can read all scripts, and applications that default to U-label form
-- should ideally give the user a choice to see the A-label form.
-- Examples:
--
-- @
-- www.example.org.           -- Ordinary DNS name.
-- \_25.\_tcp.mx1.example.net.  -- TLSA RR initial labels have \_ prefixes.
-- \\001.exotic.example.       -- First label is Ctrl-A!
-- just\\.one\\.label.example.  -- First label is \"just.one.label\"
-- @
--
type Domain = ByteString

-- | Type for a mailbox encoded on the wire as a DNS name, but the first label
-- is conceptually the local part of an email address, and may contain internal
-- periods that are not label separators. Therefore, in mailboxes \@ is used as
-- the separator between the first and second labels, and any \'.\' characters
-- in the first label are not escaped.  The encoding is otherwise the same as
-- 'Domain' above. This is most commonly seen in the /mrname/ of @SOA@ records.
-- On input, if there is no unescaped \@ character in the 'Mailbox', it is
-- reparsed with \'.\' as the first label separator. Thus the traditional
-- format with all labels separated by dots is also accepted, but decoding from
-- wire form always uses \@ between the first label and the domain-part of the
-- address.  Examples:
--
-- @
-- hostmaster\@example.org.  -- First label is simply @hostmaster@
-- john.smith\@examle.com.   -- First label is @john.smith@
-- @
--
type Mailbox = ByteString

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

#if __GLASGOW_HASKELL__ >= 800
-- | Types for resource records.
newtype TYPE = TYPE {
    -- | From type to number.
    TYPE -> Word16
fromTYPE :: Word16
  } deriving (TYPE -> TYPE -> Bool
(TYPE -> TYPE -> Bool) -> (TYPE -> TYPE -> Bool) -> Eq TYPE
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TYPE -> TYPE -> Bool
$c/= :: TYPE -> TYPE -> Bool
== :: TYPE -> TYPE -> Bool
$c== :: TYPE -> TYPE -> Bool
Eq, Eq TYPE
Eq TYPE =>
(TYPE -> TYPE -> Ordering)
-> (TYPE -> TYPE -> Bool)
-> (TYPE -> TYPE -> Bool)
-> (TYPE -> TYPE -> Bool)
-> (TYPE -> TYPE -> Bool)
-> (TYPE -> TYPE -> TYPE)
-> (TYPE -> TYPE -> TYPE)
-> Ord TYPE
TYPE -> TYPE -> Bool
TYPE -> TYPE -> Ordering
TYPE -> TYPE -> TYPE
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TYPE -> TYPE -> TYPE
$cmin :: TYPE -> TYPE -> TYPE
max :: TYPE -> TYPE -> TYPE
$cmax :: TYPE -> TYPE -> TYPE
>= :: TYPE -> TYPE -> Bool
$c>= :: TYPE -> TYPE -> Bool
> :: TYPE -> TYPE -> Bool
$c> :: TYPE -> TYPE -> Bool
<= :: TYPE -> TYPE -> Bool
$c<= :: TYPE -> TYPE -> Bool
< :: TYPE -> TYPE -> Bool
$c< :: TYPE -> TYPE -> Bool
compare :: TYPE -> TYPE -> Ordering
$ccompare :: TYPE -> TYPE -> Ordering
$cp1Ord :: Eq TYPE
Ord)

-- https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-4

-- | IPv4 address
pattern A :: TYPE
pattern $bA :: TYPE
$mA :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
A          = TYPE   1
-- | An authoritative name serve
pattern NS :: TYPE
pattern $bNS :: TYPE
$mNS :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
NS         = TYPE   2
-- | The canonical name for an alias
pattern CNAME :: TYPE
pattern $bCNAME :: TYPE
$mCNAME :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
CNAME      = TYPE   5
-- | Marks the start of a zone of authority
pattern SOA :: TYPE
pattern $bSOA :: TYPE
$mSOA :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
SOA        = TYPE   6
-- | A null RR (EXPERIMENTAL)
pattern NULL :: TYPE
pattern $bNULL :: TYPE
$mNULL :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
NULL       = TYPE  10
-- | A domain name pointer
pattern PTR :: TYPE
pattern $bPTR :: TYPE
$mPTR :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
PTR        = TYPE  12
-- | Mail exchange
pattern MX :: TYPE
pattern $bMX :: TYPE
$mMX :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
MX         = TYPE  15
-- | Text strings
pattern TXT :: TYPE
pattern $bTXT :: TYPE
$mTXT :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
TXT        = TYPE  16
-- | IPv6 Address
pattern AAAA :: TYPE
pattern $bAAAA :: TYPE
$mAAAA :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
AAAA       = TYPE  28
-- | Server Selection (RFC2782)
pattern SRV :: TYPE
pattern $bSRV :: TYPE
$mSRV :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
SRV        = TYPE  33
-- | DNAME (RFC6672)
pattern DNAME :: TYPE
pattern $bDNAME :: TYPE
$mDNAME :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
DNAME      = TYPE  39 -- RFC 6672
-- | OPT (RFC6891)
pattern OPT :: TYPE
pattern $bOPT :: TYPE
$mOPT :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
OPT        = TYPE  41 -- RFC 6891
-- | Delegation Signer (RFC4034)
pattern DS :: TYPE
pattern $bDS :: TYPE
$mDS :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
DS         = TYPE  43 -- RFC 4034
-- | RRSIG (RFC4034)
pattern RRSIG :: TYPE
pattern $bRRSIG :: TYPE
$mRRSIG :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
RRSIG      = TYPE  46 -- RFC 4034
-- | NSEC (RFC4034)
pattern NSEC :: TYPE
pattern $bNSEC :: TYPE
$mNSEC :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
NSEC       = TYPE  47 -- RFC 4034
-- | DNSKEY (RFC4034)
pattern DNSKEY :: TYPE
pattern $bDNSKEY :: TYPE
$mDNSKEY :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
DNSKEY     = TYPE  48 -- RFC 4034
-- | NSEC3 (RFC5155)
pattern NSEC3 :: TYPE
pattern $bNSEC3 :: TYPE
$mNSEC3 :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
NSEC3      = TYPE  50 -- RFC 5155
-- | NSEC3PARAM (RFC5155)
pattern NSEC3PARAM :: TYPE
pattern $bNSEC3PARAM :: TYPE
$mNSEC3PARAM :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
NSEC3PARAM = TYPE  51 -- RFC 5155
-- | TLSA (RFC6698)
pattern TLSA :: TYPE
pattern $bTLSA :: TYPE
$mTLSA :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
TLSA       = TYPE  52 -- RFC 6698
-- | Child DS (RFC7344)
pattern CDS :: TYPE
pattern $bCDS :: TYPE
$mCDS :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
CDS        = TYPE  59 -- RFC 7344
-- | DNSKEY(s) the Child wants reflected in DS (RFC7344)
pattern CDNSKEY :: TYPE
pattern $bCDNSKEY :: TYPE
$mCDNSKEY :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
CDNSKEY    = TYPE  60 -- RFC 7344
-- | Child-To-Parent Synchronization (RFC7477)
pattern CSYNC :: TYPE
pattern $bCSYNC :: TYPE
$mCSYNC :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
CSYNC      = TYPE  62 -- RFC 7477
-- | Zone transfer (RFC5936)
pattern AXFR :: TYPE
pattern $bAXFR :: TYPE
$mAXFR :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
AXFR       = TYPE 252 -- RFC 5936
-- | A request for all records the server/cache has available
pattern ANY :: TYPE
pattern $bANY :: TYPE
$mANY :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
ANY        = TYPE 255
-- | Certification Authority Authorization (RFC6844)
pattern CAA :: TYPE
pattern $bCAA :: TYPE
$mCAA :: forall r. TYPE -> (Void# -> r) -> (Void# -> r) -> r
CAA        = TYPE 257 -- RFC 6844

-- | From number to type.
toTYPE :: Word16 -> TYPE
toTYPE :: Word16 -> TYPE
toTYPE = Word16 -> TYPE
TYPE
#else
-- | Types for resource records.
data TYPE = A          -- ^ IPv4 address
          | NS         -- ^ An authoritative name serve
          | CNAME      -- ^ The canonical name for an alias
          | SOA        -- ^ Marks the start of a zone of authority
          | NULL       -- ^ A null RR (EXPERIMENTAL)
          | PTR        -- ^ A domain name pointer
          | MX         -- ^ Mail exchange
          | TXT        -- ^ Text strings
          | AAAA       -- ^ IPv6 Address
          | SRV        -- ^ Server Selection (RFC2782)
          | DNAME      -- ^ DNAME (RFC6672)
          | OPT        -- ^ OPT (RFC6891)
          | DS         -- ^ Delegation Signer (RFC4034)
          | RRSIG      -- ^ RRSIG (RFC4034)
          | NSEC       -- ^ NSEC (RFC4034)
          | DNSKEY     -- ^ DNSKEY (RFC4034)
          | NSEC3      -- ^ NSEC3 (RFC5155)
          | NSEC3PARAM -- ^ NSEC3PARAM (RFC5155)
          | TLSA       -- ^ TLSA (RFC6698)
          | CDS        -- ^ Child DS (RFC7344)
          | CDNSKEY    -- ^ DNSKEY(s) the Child wants reflected in DS (RFC7344)
          | CSYNC      -- ^ Child-To-Parent Synchronization (RFC7477)
          | AXFR       -- ^ Zone transfer (RFC5936)
          | ANY        -- ^ A request for all records the server/cache
                       --   has available
          | CAA        -- ^ Certification Authority Authorization (RFC6844)
          | UnknownTYPE Word16  -- ^ Unknown type
          deriving (Eq, Ord, Read)

-- | From type to number.
fromTYPE :: TYPE -> Word16
fromTYPE A          =  1
fromTYPE NS         =  2
fromTYPE CNAME      =  5
fromTYPE SOA        =  6
fromTYPE NULL       = 10
fromTYPE PTR        = 12
fromTYPE MX         = 15
fromTYPE TXT        = 16
fromTYPE AAAA       = 28
fromTYPE SRV        = 33
fromTYPE DNAME      = 39
fromTYPE OPT        = 41
fromTYPE DS         = 43
fromTYPE RRSIG      = 46
fromTYPE NSEC       = 47
fromTYPE DNSKEY     = 48
fromTYPE NSEC3      = 50
fromTYPE NSEC3PARAM = 51
fromTYPE TLSA       = 52
fromTYPE CDS        = 59
fromTYPE CDNSKEY    = 60
fromTYPE CSYNC      = 62
fromTYPE AXFR       = 252
fromTYPE ANY        = 255
fromTYPE CAA        = 257
fromTYPE (UnknownTYPE x) = x

-- | From number to type.
toTYPE :: Word16 -> TYPE
toTYPE  1 = A
toTYPE  2 = NS
toTYPE  5 = CNAME
toTYPE  6 = SOA
toTYPE 10 = NULL
toTYPE 12 = PTR
toTYPE 15 = MX
toTYPE 16 = TXT
toTYPE 28 = AAAA
toTYPE 33 = SRV
toTYPE 39 = DNAME
toTYPE 41 = OPT
toTYPE 43 = DS
toTYPE 46 = RRSIG
toTYPE 47 = NSEC
toTYPE 48 = DNSKEY
toTYPE 50 = NSEC3
toTYPE 51 = NSEC3PARAM
toTYPE 52 = TLSA
toTYPE 59 = CDS
toTYPE 60 = CDNSKEY
toTYPE 62 = CSYNC
toTYPE 252 = AXFR
toTYPE 255 = ANY
toTYPE 257 = CAA
toTYPE x   = UnknownTYPE x
#endif

instance Show TYPE where
    show :: TYPE -> String
show A          = "A"
    show NS         = "NS"
    show CNAME      = "CNAME"
    show SOA        = "SOA"
    show NULL       = "NULL"
    show PTR        = "PTR"
    show MX         = "MX"
    show TXT        = "TXT"
    show AAAA       = "AAAA"
    show SRV        = "SRV"
    show DNAME      = "DNAME"
    show OPT        = "OPT"
    show DS         = "DS"
    show RRSIG      = "RRSIG"
    show NSEC       = "NSEC"
    show DNSKEY     = "DNSKEY"
    show NSEC3      = "NSEC3"
    show NSEC3PARAM = "NSEC3PARAM"
    show TLSA       = "TLSA"
    show CDS        = "CDS"
    show CDNSKEY    = "CDNSKEY"
    show CSYNC      = "CSYNC"
    show AXFR       = "AXFR"
    show ANY        = "ANY"
    show CAA        = "CAA"
    show x :: TYPE
x          = "TYPE" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show (TYPE -> Word16
fromTYPE TYPE
x)

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

-- | An enumeration of all possible DNS errors that can occur.
data DNSError =
    -- | 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
    -- | A zone tranfer, i.e., a request of type AXFR, was attempted with the
    -- "lookup" interface. Zone transfer is different enough from "normal"
    -- requests that it requires a different interface.
  | InvalidAXFRLookup
    -- | The number of retries for the request was exceeded.
  | RetryLimitExceeded
    -- | TCP fallback request timed out.
  | TimeoutExpired
    -- | The answer has the correct sequence number, but returned an
    --   unexpected RDATA format.
  | UnexpectedRDATA
    -- | The domain for query is illegal.
  | IllegalDomain
    -- | The name server was unable to interpret the query.
  | FormatError
    -- | The name server was unable to process this query due to a
    --   problem with the name server.
  | ServerFailure
    -- | 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
    -- | The name server refuses to perform the specified operation for
    --   policy reasons.  For example, a name
    --   server may not wish to provide the
    --   information to the particular requester,
    --   or a name server may not wish to perform
    --   a particular operation (e.g., zone transfer) for particular data.
  | OperationRefused
    -- | The server does not support the OPT RR version or content
  | BadOptRecord
    -- | Configuration is wrong.
  | BadConfiguration
    -- | Network failure.
  | NetworkFailure IOException
    -- | Error is unknown
  | DecodeError String
  | UnknownDNSError
  deriving (DNSError -> DNSError -> Bool
(DNSError -> DNSError -> Bool)
-> (DNSError -> DNSError -> Bool) -> Eq DNSError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DNSError -> DNSError -> Bool
$c/= :: DNSError -> DNSError -> Bool
== :: DNSError -> DNSError -> Bool
$c== :: DNSError -> DNSError -> Bool
Eq, Int -> DNSError -> ShowS
[DNSError] -> ShowS
DNSError -> String
(Int -> DNSError -> ShowS)
-> (DNSError -> String) -> ([DNSError] -> ShowS) -> Show DNSError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DNSError] -> ShowS
$cshowList :: [DNSError] -> ShowS
show :: DNSError -> String
$cshow :: DNSError -> String
showsPrec :: Int -> DNSError -> ShowS
$cshowsPrec :: Int -> DNSError -> ShowS
Show, Typeable)

instance Exception DNSError


-- | Data type representing the optional EDNS pseudo-header of a 'DNSMessage'
-- When a single well-formed @OPT@ 'ResourceRecord' was present in the
-- message's additional section, it is decoded to an 'EDNS' record and and
-- stored in the message 'ednsHeader' field.  The corresponding @OPT RR@ is
-- then removed from the additional section.
--
-- When the constructor is 'NoEDNS', no @EDNS OPT@ record was present in the
-- message additional section.  When 'InvalidEDNS', the message holds either a
-- malformed OPT record or more than one OPT record, which can still be found
-- in (have not been removed from) the message additional section.
--
-- The EDNS OPT record augments the message error status with an 8-bit field
-- that forms 12-bit extended RCODE when combined with the 4-bit RCODE from the
-- unextended DNS header.  In EDNS messages it is essential to not use just the
-- bare 4-bit 'RCODE' from the original DNS header.  Therefore, in order to
-- avoid potential misinterpretation of the response 'RCODE', when the OPT
-- record is decoded, the upper eight bits of the error status are
-- automatically combined with the 'rcode' of the message header, so that there
-- is only one place in which to find the full 12-bit result.  Therefore, the
-- decoded 'EDNS' pseudo-header, does not hold any error status bits.
--
-- The reverse process occurs when encoding messages.  The low four bits of the
-- message header 'rcode' are encoded into the wire-form DNS header, while the
-- upper eight bits are encoded as part of the OPT record.  In DNS responses with
-- an 'rcode' larger than 15, EDNS extensions SHOULD be enabled by providing a
-- value for 'ednsHeader' with a constructor of 'EDNSheader'.  If EDNS is not
-- enabled in such a message, in order to avoid truncation of 'RCODE' values
-- that don't fit in the non-extended DNS header, the encoded wire-form 'RCODE'
-- is set to 'FormatErr'.
--
-- When encoding messages for transmission, the 'ednsHeader' is used to
-- generate the additional OPT record.  Do not add explicit @OPT@ records
-- to the aditional section, configure EDNS via the 'EDNSheader' instead.
--
-- >>> let getopts eh = mapEDNS eh ednsOptions []
-- >>> let optsin     = [OD_ClientSubnet 24 0 $ read "192.0.2.1"]
-- >>> let masked     = [OD_ClientSubnet 24 0 $ read "192.0.2.0"]
-- >>> let message    = makeEmptyQuery $ ednsSetOptions $ ODataSet optsin
-- >>> let optsout    = getopts. ednsHeader <$> (decode $ encode message)
-- >>> optsout       == Right masked
-- True
--
data EDNSheader = EDNSheader EDNS -- ^ A valid EDNS message
                | NoEDNS          -- ^ A valid non-EDNS message
                | InvalidEDNS     -- ^ Multiple or bad additional @OPT@ RRs
    deriving (EDNSheader -> EDNSheader -> Bool
(EDNSheader -> EDNSheader -> Bool)
-> (EDNSheader -> EDNSheader -> Bool) -> Eq EDNSheader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EDNSheader -> EDNSheader -> Bool
$c/= :: EDNSheader -> EDNSheader -> Bool
== :: EDNSheader -> EDNSheader -> Bool
$c== :: EDNSheader -> EDNSheader -> Bool
Eq, Int -> EDNSheader -> ShowS
[EDNSheader] -> ShowS
EDNSheader -> String
(Int -> EDNSheader -> ShowS)
-> (EDNSheader -> String)
-> ([EDNSheader] -> ShowS)
-> Show EDNSheader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EDNSheader] -> ShowS
$cshowList :: [EDNSheader] -> ShowS
show :: EDNSheader -> String
$cshow :: EDNSheader -> String
showsPrec :: Int -> EDNSheader -> ShowS
$cshowsPrec :: Int -> EDNSheader -> ShowS
Show)


-- | Return the second argument for EDNS messages, otherwise the third.
ifEDNS :: EDNSheader -- ^ EDNS pseudo-header
       -> a          -- ^ Value to return for EDNS messages
       -> a          -- ^ Value to return for non-EDNS messages
       -> a
ifEDNS :: EDNSheader -> a -> a -> a
ifEDNS (EDNSheader _) a :: a
a _ = a
a
ifEDNS             _  _ b :: a
b = a
b
{-# INLINE ifEDNS #-}


-- | Return the output of a function applied to the EDNS pseudo-header if EDNS
--   is enabled, otherwise return a default value.
mapEDNS :: EDNSheader  -- ^ EDNS pseudo-header
        -> (EDNS -> a) -- ^ Function to apply to 'EDNS' value
        -> a           -- ^ Default result for non-EDNS messages
        -> a
mapEDNS :: EDNSheader -> (EDNS -> a) -> a -> a
mapEDNS (EDNSheader eh :: EDNS
eh) f :: EDNS -> a
f _ = EDNS -> a
f EDNS
eh
mapEDNS               _ _ a :: a
a = a
a
{-# INLINE mapEDNS #-}


-- | DNS message format for queries and replies.
--
data DNSMessage = DNSMessage {
    DNSMessage -> DNSHeader
header     :: !DNSHeader        -- ^ Header with extended 'RCODE'
  , DNSMessage -> EDNSheader
ednsHeader :: EDNSheader        -- ^ EDNS pseudo-header
  , DNSMessage -> [Question]
question   :: [Question]        -- ^ The question for the name server
  , DNSMessage -> Answers
answer     :: Answers           -- ^ RRs answering the question
  , DNSMessage -> Answers
authority  :: AuthorityRecords  -- ^ RRs pointing toward an authority
  , DNSMessage -> Answers
additional :: AdditionalRecords -- ^ RRs holding additional information
  } deriving (DNSMessage -> DNSMessage -> Bool
(DNSMessage -> DNSMessage -> Bool)
-> (DNSMessage -> DNSMessage -> Bool) -> Eq DNSMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DNSMessage -> DNSMessage -> Bool
$c/= :: DNSMessage -> DNSMessage -> Bool
== :: DNSMessage -> DNSMessage -> Bool
$c== :: DNSMessage -> DNSMessage -> Bool
Eq, Int -> DNSMessage -> ShowS
[DNSMessage] -> ShowS
DNSMessage -> String
(Int -> DNSMessage -> ShowS)
-> (DNSMessage -> String)
-> ([DNSMessage] -> ShowS)
-> Show DNSMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DNSMessage] -> ShowS
$cshowList :: [DNSMessage] -> ShowS
show :: DNSMessage -> String
$cshow :: DNSMessage -> String
showsPrec :: Int -> DNSMessage -> ShowS
$cshowsPrec :: Int -> DNSMessage -> ShowS
Show)

-- | An identifier assigned by the program that
--   generates any kind of query.
type Identifier = Word16

-- | Raw data format for the header of DNS Query and Response.
data DNSHeader = DNSHeader {
    DNSHeader -> Word16
identifier :: !Identifier -- ^ Query or reply identifier.
  , DNSHeader -> DNSFlags
flags      :: !DNSFlags   -- ^ Flags, OPCODE, and RCODE
  } deriving (DNSHeader -> DNSHeader -> Bool
(DNSHeader -> DNSHeader -> Bool)
-> (DNSHeader -> DNSHeader -> Bool) -> Eq DNSHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DNSHeader -> DNSHeader -> Bool
$c/= :: DNSHeader -> DNSHeader -> Bool
== :: DNSHeader -> DNSHeader -> Bool
$c== :: DNSHeader -> DNSHeader -> Bool
Eq, Int -> DNSHeader -> ShowS
[DNSHeader] -> ShowS
DNSHeader -> String
(Int -> DNSHeader -> ShowS)
-> (DNSHeader -> String)
-> ([DNSHeader] -> ShowS)
-> Show DNSHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DNSHeader] -> ShowS
$cshowList :: [DNSHeader] -> ShowS
show :: DNSHeader -> String
$cshow :: DNSHeader -> String
showsPrec :: Int -> DNSHeader -> ShowS
$cshowsPrec :: Int -> DNSHeader -> ShowS
Show)

-- | Raw data format for the flags of DNS Query and Response.
data DNSFlags = DNSFlags {
    DNSFlags -> QorR
qOrR         :: !QorR  -- ^ Query or response.
  , DNSFlags -> OPCODE
opcode       :: !OPCODE -- ^ Kind of query.
  , DNSFlags -> Bool
authAnswer   :: !Bool  -- ^ AA (Authoritative Answer) bit - this bit is valid in responses,
                           -- and specifies that the responding name server is an
                           -- authority for the domain name in question section.
  , DNSFlags -> Bool
trunCation   :: !Bool  -- ^ TC (Truncated Response) bit - specifies that this message was truncated
                           -- due to length greater than that permitted on the
                           -- transmission channel.
  , DNSFlags -> Bool
recDesired   :: !Bool  -- ^ RD (Recursion Desired) bit - this bit may be set in a query and
                           -- is copied into the response.  If RD is set, it directs
                           -- the name server to pursue the query recursively.
                           -- Recursive query support is optional.
  , DNSFlags -> Bool
recAvailable :: !Bool  -- ^ RA (Recursion Available) bit - this be is set or cleared in a
                           -- response, and denotes whether recursive query support is
                           -- available in the name server.

  , DNSFlags -> RCODE
rcode        :: !RCODE -- ^ The full 12-bit extended RCODE when EDNS is in use.
                           -- Should always be zero in well-formed requests.
                           -- When decoding replies, the high eight bits from
                           -- any EDNS response are combined with the 4-bit
                           -- RCODE from the DNS header.  When encoding
                           -- replies, if no EDNS OPT record is provided, RCODE
                           -- values > 15 are mapped to 'FormatErr'.
  , DNSFlags -> Bool
authenData   :: !Bool  -- ^ AD (Authenticated Data) bit - (RFC4035, Section 3.2.3).
  , DNSFlags -> Bool
chkDisable   :: !Bool  -- ^ CD (Checking Disabled) bit - (RFC4035, Section 3.2.2).
  } deriving (DNSFlags -> DNSFlags -> Bool
(DNSFlags -> DNSFlags -> Bool)
-> (DNSFlags -> DNSFlags -> Bool) -> Eq DNSFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DNSFlags -> DNSFlags -> Bool
$c/= :: DNSFlags -> DNSFlags -> Bool
== :: DNSFlags -> DNSFlags -> Bool
$c== :: DNSFlags -> DNSFlags -> Bool
Eq, Int -> DNSFlags -> ShowS
[DNSFlags] -> ShowS
DNSFlags -> String
(Int -> DNSFlags -> ShowS)
-> (DNSFlags -> String) -> ([DNSFlags] -> ShowS) -> Show DNSFlags
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DNSFlags] -> ShowS
$cshowList :: [DNSFlags] -> ShowS
show :: DNSFlags -> String
$cshow :: DNSFlags -> String
showsPrec :: Int -> DNSFlags -> ShowS
$cshowsPrec :: Int -> DNSFlags -> ShowS
Show)


-- | Default 'DNSFlags' record suitable for making recursive queries.  By default
-- the RD bit is set, and the AD and CD bits are cleared.
--
defaultDNSFlags :: DNSFlags
defaultDNSFlags :: DNSFlags
defaultDNSFlags = $WDNSFlags :: QorR
-> OPCODE
-> Bool
-> Bool
-> Bool
-> Bool
-> RCODE
-> Bool
-> Bool
-> DNSFlags
DNSFlags
         { qOrR :: QorR
qOrR         = QorR
QR_Query
         , opcode :: OPCODE
opcode       = OPCODE
OP_STD
         , authAnswer :: Bool
authAnswer   = Bool
False
         , trunCation :: Bool
trunCation   = Bool
False
         , recDesired :: Bool
recDesired   = Bool
True
         , recAvailable :: Bool
recAvailable = Bool
False
         , authenData :: Bool
authenData   = Bool
False
         , chkDisable :: Bool
chkDisable   = Bool
False
         , rcode :: RCODE
rcode        = RCODE
NoErr
         }

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

-- | Boolean flag operations. These form a 'Monoid'.  When combined via
-- `mappend`, as with function composition, the left-most value has
-- the last say.
--
-- >>> mempty :: FlagOp
-- FlagKeep
-- >>> FlagSet <> mempty
-- FlagSet
-- >>> FlagClear <> FlagSet <> mempty
-- FlagClear
-- >>> FlagReset <> FlagClear <> FlagSet <> mempty
-- FlagReset
data FlagOp = FlagSet   -- ^ Set the flag to 1
            | FlagClear -- ^ Clear the flag to 0
            | FlagReset -- ^ Reset the flag to its default value
            | FlagKeep  -- ^ Leave the flag unchanged
            deriving (FlagOp -> FlagOp -> Bool
(FlagOp -> FlagOp -> Bool)
-> (FlagOp -> FlagOp -> Bool) -> Eq FlagOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FlagOp -> FlagOp -> Bool
$c/= :: FlagOp -> FlagOp -> Bool
== :: FlagOp -> FlagOp -> Bool
$c== :: FlagOp -> FlagOp -> Bool
Eq, Int -> FlagOp -> ShowS
[FlagOp] -> ShowS
FlagOp -> String
(Int -> FlagOp -> ShowS)
-> (FlagOp -> String) -> ([FlagOp] -> ShowS) -> Show FlagOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FlagOp] -> ShowS
$cshowList :: [FlagOp] -> ShowS
show :: FlagOp -> String
$cshow :: FlagOp -> String
showsPrec :: Int -> FlagOp -> ShowS
$cshowsPrec :: Int -> FlagOp -> ShowS
Show)

-- $
-- Test associativity of the semigroup operation:
--
-- >>> let ops = [FlagSet, FlagClear, FlagReset, FlagKeep]
-- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops]
-- True
--
instance Sem.Semigroup FlagOp where
    FlagKeep <> :: FlagOp -> FlagOp -> FlagOp
<> op :: FlagOp
op = FlagOp
op
    op :: FlagOp
op       <> _  = FlagOp
op

instance Monoid FlagOp where
    mempty :: FlagOp
mempty = FlagOp
FlagKeep
#if !(MIN_VERSION_base(4,11,0))
    -- this is redundant starting with base-4.11 / GHC 8.4
    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally
    mappend = (Sem.<>)
#endif

-- | We don't show options left at their default value.
--
_skipDefault :: String
_skipDefault :: String
_skipDefault = ""

-- | Show non-default flag values
--
_showFlag :: String -> FlagOp -> String
_showFlag :: String -> FlagOp -> String
_showFlag nm :: String
nm FlagSet   = String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":1"
_showFlag nm :: String
nm FlagClear = String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":0"
_showFlag _  FlagReset = String
_skipDefault
_showFlag _  FlagKeep  = String
_skipDefault

-- | Combine a list of options for display, skipping default values
--
_showOpts :: [String] -> String
_showOpts :: [String] -> String
_showOpts os :: [String]
os = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
_skipDefault) [String]
os

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

-- | Control over query-related DNS header flags. As with function composition,
-- the left-most value has the last say.
--
data HeaderControls = HeaderControls
    { HeaderControls -> FlagOp
rdBit :: !FlagOp
    , HeaderControls -> FlagOp
adBit :: !FlagOp
    , HeaderControls -> FlagOp
cdBit :: !FlagOp
    }
    deriving (HeaderControls -> HeaderControls -> Bool
(HeaderControls -> HeaderControls -> Bool)
-> (HeaderControls -> HeaderControls -> Bool) -> Eq HeaderControls
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderControls -> HeaderControls -> Bool
$c/= :: HeaderControls -> HeaderControls -> Bool
== :: HeaderControls -> HeaderControls -> Bool
$c== :: HeaderControls -> HeaderControls -> Bool
Eq)

instance Sem.Semigroup HeaderControls where
    (HeaderControls rd1 :: FlagOp
rd1 ad1 :: FlagOp
ad1 cd1 :: FlagOp
cd1) <> :: HeaderControls -> HeaderControls -> HeaderControls
<> (HeaderControls rd2 :: FlagOp
rd2 ad2 :: FlagOp
ad2 cd2 :: FlagOp
cd2) =
        FlagOp -> FlagOp -> FlagOp -> HeaderControls
HeaderControls (FlagOp
rd1 FlagOp -> FlagOp -> FlagOp
forall a. Semigroup a => a -> a -> a
<> FlagOp
rd2) (FlagOp
ad1 FlagOp -> FlagOp -> FlagOp
forall a. Semigroup a => a -> a -> a
<> FlagOp
ad2) (FlagOp
cd1 FlagOp -> FlagOp -> FlagOp
forall a. Semigroup a => a -> a -> a
<> FlagOp
cd2)

instance Monoid HeaderControls where
    mempty :: HeaderControls
mempty = FlagOp -> FlagOp -> FlagOp -> HeaderControls
HeaderControls FlagOp
FlagKeep FlagOp
FlagKeep FlagOp
FlagKeep
#if !(MIN_VERSION_base(4,11,0))
    -- this is redundant starting with base-4.11 / GHC 8.4
    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally
    mappend = (Sem.<>)
#endif

instance Show HeaderControls where
    show :: HeaderControls -> String
show (HeaderControls rd :: FlagOp
rd ad :: FlagOp
ad cd :: FlagOp
cd) =
        [String] -> String
_showOpts
             [ String -> FlagOp -> String
_showFlag "rd" FlagOp
rd
             , String -> FlagOp -> String
_showFlag "ad" FlagOp
ad
             , String -> FlagOp -> String
_showFlag "cd" FlagOp
cd ]

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

-- | The default EDNS Option list is empty.  We define two operations, one to
-- prepend a list of options, and another to set a specific list of options.
--
data ODataOp = ODataAdd [OData] -- ^ Add the specified options to the list.
             | ODataSet [OData] -- ^ Set the option list as specified.
             deriving (ODataOp -> ODataOp -> Bool
(ODataOp -> ODataOp -> Bool)
-> (ODataOp -> ODataOp -> Bool) -> Eq ODataOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ODataOp -> ODataOp -> Bool
$c/= :: ODataOp -> ODataOp -> Bool
== :: ODataOp -> ODataOp -> Bool
$c== :: ODataOp -> ODataOp -> Bool
Eq)

-- | Since any given option code can appear at most once in the list, we
-- de-duplicate by the OPTION CODE when combining lists.
--
_odataDedup :: ODataOp -> [OData]
_odataDedup :: ODataOp -> [OData]
_odataDedup op :: ODataOp
op =
    (OData -> OData -> Bool) -> [OData] -> [OData]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (OptCode -> OptCode -> Bool
forall a. Eq a => a -> a -> Bool
(==) (OptCode -> OptCode -> Bool)
-> (OData -> OptCode) -> OData -> OData -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` OData -> OptCode
_odataToOptCode) ([OData] -> [OData]) -> [OData] -> [OData]
forall a b. (a -> b) -> a -> b
$
        case ODataOp
op of
            ODataAdd os :: [OData]
os -> [OData]
os
            ODataSet os :: [OData]
os -> [OData]
os

-- $
-- Test associativity of the OData semigroup operation:
--
-- >>> let ip1 = IPv4 $ read "127.0.0.0"
-- >>> let ip2 = IPv4 $ read "192.0.2.0"
-- >>> let cs1 = OD_ClientSubnet 8 0 ip1
-- >>> let cs2 = OD_ClientSubnet 24 0 ip2
-- >>> let cs3 = OD_ECSgeneric 0 24 0 "foo"
-- >>> let dau1 = OD_DAU [3,5,7,8]
-- >>> let dau2 = OD_DAU [13,14]
-- >>> let dhu1 = OD_DHU [1,2]
-- >>> let dhu2 = OD_DHU [3,4]
-- >>> let nsid = OD_NSID ""
-- >>> let ops1 = [ODataAdd [dau1, dau2, cs1], ODataAdd [dau2, cs2, dhu1]]
-- >>> let ops2 = [ODataSet [], ODataSet [dhu2, cs3], ODataSet [nsid]]
-- >>> let ops = ops1 ++ ops2
-- >>> foldl (&&) True [(a<>b)<>c == a<>(b<>c) | a <- ops, b <- ops, c <- ops]
-- True

instance Sem.Semigroup ODataOp where
    ODataAdd as :: [OData]
as <> :: ODataOp -> ODataOp -> ODataOp
<> ODataAdd bs :: [OData]
bs = [OData] -> ODataOp
ODataAdd ([OData] -> ODataOp) -> [OData] -> ODataOp
forall a b. (a -> b) -> a -> b
$ [OData]
as [OData] -> [OData] -> [OData]
forall a. [a] -> [a] -> [a]
++ [OData]
bs
    ODataAdd as :: [OData]
as <> ODataSet bs :: [OData]
bs = [OData] -> ODataOp
ODataSet ([OData] -> ODataOp) -> [OData] -> ODataOp
forall a b. (a -> b) -> a -> b
$ [OData]
as [OData] -> [OData] -> [OData]
forall a. [a] -> [a] -> [a]
++ [OData]
bs
    ODataSet as :: [OData]
as <> _ = [OData] -> ODataOp
ODataSet [OData]
as

instance Monoid ODataOp where
    mempty :: ODataOp
mempty = [OData] -> ODataOp
ODataAdd []
#if !(MIN_VERSION_base(4,11,0))
    -- this is redundant starting with base-4.11 / GHC 8.4
    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally
    mappend = (Sem.<>)
#endif

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

-- | EDNS query controls.  When EDNS is disabled via @ednsEnabled FlagClear@,
-- all the other EDNS-related overrides have no effect.
--
-- >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet
-- NoEDNS
data EdnsControls = EdnsControls
    { EdnsControls -> FlagOp
extEn :: !FlagOp         -- ^ Enabled
    , EdnsControls -> Maybe Word8
extVn :: !(Maybe Word8)  -- ^ Version
    , EdnsControls -> Maybe Word16
extSz :: !(Maybe Word16) -- ^ UDP Size
    , EdnsControls -> FlagOp
extDO :: !FlagOp         -- ^ DNSSEC OK (DO) bit
    , EdnsControls -> ODataOp
extOd :: !ODataOp        -- ^ EDNS option list tweaks
    }
    deriving (EdnsControls -> EdnsControls -> Bool
(EdnsControls -> EdnsControls -> Bool)
-> (EdnsControls -> EdnsControls -> Bool) -> Eq EdnsControls
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdnsControls -> EdnsControls -> Bool
$c/= :: EdnsControls -> EdnsControls -> Bool
== :: EdnsControls -> EdnsControls -> Bool
$c== :: EdnsControls -> EdnsControls -> Bool
Eq)

-- | Apply all the query flag overrides to 'defaultDNSFlags', returning the

instance Sem.Semigroup EdnsControls where
    (EdnsControls en1 :: FlagOp
en1 vn1 :: Maybe Word8
vn1 sz1 :: Maybe Word16
sz1 do1 :: FlagOp
do1 od1 :: ODataOp
od1) <> :: EdnsControls -> EdnsControls -> EdnsControls
<> (EdnsControls en2 :: FlagOp
en2 vn2 :: Maybe Word8
vn2 sz2 :: Maybe Word16
sz2 do2 :: FlagOp
do2 od2 :: ODataOp
od2) =
        FlagOp
-> Maybe Word8 -> Maybe Word16 -> FlagOp -> ODataOp -> EdnsControls
EdnsControls (FlagOp
en1 FlagOp -> FlagOp -> FlagOp
forall a. Semigroup a => a -> a -> a
<> FlagOp
en2) (Maybe Word8
vn1 Maybe Word8 -> Maybe Word8 -> Maybe Word8
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Word8
vn2) (Maybe Word16
sz1 Maybe Word16 -> Maybe Word16 -> Maybe Word16
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Word16
sz2)
                    (FlagOp
do1 FlagOp -> FlagOp -> FlagOp
forall a. Semigroup a => a -> a -> a
<> FlagOp
do2) (ODataOp
od1 ODataOp -> ODataOp -> ODataOp
forall a. Semigroup a => a -> a -> a
<> ODataOp
od2)

instance Monoid EdnsControls where
    mempty :: EdnsControls
mempty = FlagOp
-> Maybe Word8 -> Maybe Word16 -> FlagOp -> ODataOp -> EdnsControls
EdnsControls FlagOp
FlagKeep Maybe Word8
forall a. Maybe a
Nothing Maybe Word16
forall a. Maybe a
Nothing FlagOp
FlagKeep ODataOp
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
    -- this is redundant starting with base-4.11 / GHC 8.4
    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally
    mappend = (Sem.<>)
#endif

instance Show EdnsControls where
    show :: EdnsControls -> String
show (EdnsControls en :: FlagOp
en vn :: Maybe Word8
vn sz :: Maybe Word16
sz d0 :: FlagOp
d0 od :: ODataOp
od) =
        [String] -> String
_showOpts
            [ String -> FlagOp -> String
_showFlag "edns.enabled" FlagOp
en
            , String -> Maybe Word8 -> String
forall a. Show a => String -> Maybe a -> String
_showWord "edns.version" Maybe Word8
vn
            , String -> Maybe Word16 -> String
forall a. Show a => String -> Maybe a -> String
_showWord "edns.udpsize" Maybe Word16
sz
            , String -> FlagOp -> String
_showFlag "edns.dobit"   FlagOp
d0
            , String -> [String] -> String
_showOdOp "edns.options" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (OData -> String) -> [OData] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OptCode -> String
forall a. Show a => a -> String
show(OptCode -> String) -> (OData -> OptCode) -> OData -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OData -> OptCode
_odataToOptCode)
                                       ([OData] -> [String]) -> [OData] -> [String]
forall a b. (a -> b) -> a -> b
$ ODataOp -> [OData]
_odataDedup ODataOp
od ]
      where
        _showWord :: Show a => String -> Maybe a -> String
        _showWord :: String -> Maybe a -> String
_showWord nm :: String
nm w :: Maybe a
w = String -> (a -> String) -> Maybe a -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
_skipDefault (\s :: a
s -> String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
s) Maybe a
w

        _showOdOp :: String -> [String] -> String
        _showOdOp :: String -> [String] -> String
_showOdOp nm :: String
nm os :: [String]
os = case [String]
os of
            [] -> ""
            _  -> String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "," [String]
os String -> ShowS
forall a. [a] -> [a] -> [a]
++ "]"

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

-- | Query controls form a 'Monoid', as with function composition, the
-- left-most value has the last say.  The 'Monoid' is generated by two sets of
-- combinators, one that controls query-related DNS header flags, and another
-- that controls EDNS features.
--
-- The header flag controls are: 'rdFlag', 'adFlag' and 'cdFlag'.
--
-- The EDNS feature controls are: 'doFlag', 'ednsEnabled', 'ednsSetVersion',
-- 'ednsSetUdpSize' and 'ednsSetOptions'.  When EDNS is disabled, all the other
-- EDNS-related controls have no effect.
--
-- __Example:__ Disable DNSSEC checking on the server, and request signatures and
-- NSEC records, perhaps for your own independent validation.  The UDP buffer
-- size is set large, for use with a local loopback nameserver on the same host.
--
-- >>> :{
-- mconcat [ adFlag FlagClear
--         , cdFlag FlagSet
--         , doFlag FlagSet
--         , ednsSetUdpSize (Just 8192) -- IPv4 loopback server?
--         ]
-- :}
-- ad:0,cd:1,edns.udpsize:8192,edns.dobit:1
--
-- __Example:__ Use EDNS version 1 (yet to be specified), request nameserver
-- ids from the server, and indicate a client subnet of "192.0.2.1/24".
--
-- >>> :set -XOverloadedStrings
-- >>> let emptyNSID = ""
-- >>> let mask = 24
-- >>> let ipaddr = read "192.0.2.1"
-- >>> :{
-- mconcat [ ednsSetVersion (Just 1)
--         , ednsSetOptions (ODataAdd [OD_NSID emptyNSID])
--         , ednsSetOptions (ODataAdd [OD_ClientSubnet mask 0 ipaddr])
--         ]
-- :}
-- edns.version:1,edns.options:[NSID,ClientSubnet]

data QueryControls = QueryControls
    { QueryControls -> HeaderControls
qctlHeader :: !HeaderControls
    , QueryControls -> EdnsControls
qctlEdns   :: !EdnsControls
    }
    deriving (QueryControls -> QueryControls -> Bool
(QueryControls -> QueryControls -> Bool)
-> (QueryControls -> QueryControls -> Bool) -> Eq QueryControls
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QueryControls -> QueryControls -> Bool
$c/= :: QueryControls -> QueryControls -> Bool
== :: QueryControls -> QueryControls -> Bool
$c== :: QueryControls -> QueryControls -> Bool
Eq)

instance Sem.Semigroup QueryControls where
    (QueryControls fl1 :: HeaderControls
fl1 ex1 :: EdnsControls
ex1) <> :: QueryControls -> QueryControls -> QueryControls
<> (QueryControls fl2 :: HeaderControls
fl2 ex2 :: EdnsControls
ex2) =
        HeaderControls -> EdnsControls -> QueryControls
QueryControls (HeaderControls
fl1 HeaderControls -> HeaderControls -> HeaderControls
forall a. Semigroup a => a -> a -> a
<> HeaderControls
fl2) (EdnsControls
ex1 EdnsControls -> EdnsControls -> EdnsControls
forall a. Semigroup a => a -> a -> a
<> EdnsControls
ex2)

instance Monoid QueryControls where
    mempty :: QueryControls
mempty = HeaderControls -> EdnsControls -> QueryControls
QueryControls HeaderControls
forall a. Monoid a => a
mempty EdnsControls
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
    -- this is redundant starting with base-4.11 / GHC 8.4
    -- if you want to avoid CPP, you can define `mappend = (<>)` unconditionally
    mappend = (Sem.<>)
#endif

instance Show QueryControls where
    show :: QueryControls -> String
show (QueryControls fl :: HeaderControls
fl ex :: EdnsControls
ex) = [String] -> String
_showOpts [ HeaderControls -> String
forall a. Show a => a -> String
show HeaderControls
fl, EdnsControls -> String
forall a. Show a => a -> String
show EdnsControls
ex ]

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

-- | Generator of 'QueryControls' that adjusts the RD bit.
--
-- >>> rdFlag FlagClear
-- rd:0
rdFlag :: FlagOp -> QueryControls
rdFlag :: FlagOp -> QueryControls
rdFlag rd :: FlagOp
rd = QueryControls
forall a. Monoid a => a
mempty { qctlHeader :: HeaderControls
qctlHeader = HeaderControls
forall a. Monoid a => a
mempty { rdBit :: FlagOp
rdBit = FlagOp
rd } }

-- | Generator of 'QueryControls' that adjusts the AD bit.
--
-- >>> adFlag FlagSet
-- ad:1
adFlag :: FlagOp -> QueryControls
adFlag :: FlagOp -> QueryControls
adFlag ad :: FlagOp
ad = QueryControls
forall a. Monoid a => a
mempty { qctlHeader :: HeaderControls
qctlHeader = HeaderControls
forall a. Monoid a => a
mempty { adBit :: FlagOp
adBit = FlagOp
ad } }

-- | Generator of 'QueryControls' that adjusts the CD bit.
--
-- >>> cdFlag FlagSet
-- cd:1
cdFlag :: FlagOp -> QueryControls
cdFlag :: FlagOp -> QueryControls
cdFlag cd :: FlagOp
cd = QueryControls
forall a. Monoid a => a
mempty { qctlHeader :: HeaderControls
qctlHeader = HeaderControls
forall a. Monoid a => a
mempty { cdBit :: FlagOp
cdBit = FlagOp
cd } }

-- | Generator of 'QueryControls' that enables or disables EDNS support.
--   When EDNS is disabled, the rest of the 'EDNS' controls are ignored.
--
-- >>> ednsHeader $ makeEmptyQuery $ ednsEnabled FlagClear <> doFlag FlagSet
-- NoEDNS
ednsEnabled :: FlagOp -> QueryControls
ednsEnabled :: FlagOp -> QueryControls
ednsEnabled en :: FlagOp
en = QueryControls
forall a. Monoid a => a
mempty { qctlEdns :: EdnsControls
qctlEdns = EdnsControls
forall a. Monoid a => a
mempty { extEn :: FlagOp
extEn = FlagOp
en } }

-- | Generator of 'QueryControls' that adjusts the 'EDNS' version.
-- A value of 'Nothing' makes no changes, while 'Just' @v@ sets
-- the EDNS version to @v@.
--
-- >>> ednsSetVersion (Just 1)
-- edns.version:1
ednsSetVersion :: Maybe Word8 -> QueryControls
ednsSetVersion :: Maybe Word8 -> QueryControls
ednsSetVersion vn :: Maybe Word8
vn = QueryControls
forall a. Monoid a => a
mempty { qctlEdns :: EdnsControls
qctlEdns = EdnsControls
forall a. Monoid a => a
mempty { extVn :: Maybe Word8
extVn = Maybe Word8
vn } }

-- | Generator of 'QueryControls' that adjusts the 'EDNS' UDP buffer size.
-- A value of 'Nothing' makes no changes, while 'Just' @n@ sets the EDNS UDP
-- buffer size to @n@.
--
-- >>> ednsSetUdpSize (Just 2048)
-- edns.udpsize:2048
ednsSetUdpSize :: Maybe Word16 -> QueryControls
ednsSetUdpSize :: Maybe Word16 -> QueryControls
ednsSetUdpSize sz :: Maybe Word16
sz = QueryControls
forall a. Monoid a => a
mempty { qctlEdns :: EdnsControls
qctlEdns = EdnsControls
forall a. Monoid a => a
mempty { extSz :: Maybe Word16
extSz = Maybe Word16
sz } }

-- | Generator of 'QueryControls' that adjusts the 'EDNS' DnssecOk (DO) bit.
--
-- >>> doFlag FlagSet
-- edns.dobit:1
doFlag :: FlagOp -> QueryControls
doFlag :: FlagOp -> QueryControls
doFlag d0 :: FlagOp
d0 = QueryControls
forall a. Monoid a => a
mempty { qctlEdns :: EdnsControls
qctlEdns = EdnsControls
forall a. Monoid a => a
mempty { extDO :: FlagOp
extDO = FlagOp
d0 } }

-- | Generator of 'QueryControls' that adjusts the list of 'EDNS' options.
--
-- >>> :set -XOverloadedStrings
-- >>> ednsSetOptions (ODataAdd [OD_NSID ""])
-- edns.options:[NSID]
ednsSetOptions :: ODataOp -> QueryControls
ednsSetOptions :: ODataOp -> QueryControls
ednsSetOptions od :: ODataOp
od = QueryControls
forall a. Monoid a => a
mempty { qctlEdns :: EdnsControls
qctlEdns = EdnsControls
forall a. Monoid a => a
mempty { extOd :: ODataOp
extOd = ODataOp
od } }

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

-- | Query or response.
data QorR = QR_Query    -- ^ Query.
          | QR_Response -- ^ Response.
          deriving (QorR -> QorR -> Bool
(QorR -> QorR -> Bool) -> (QorR -> QorR -> Bool) -> Eq QorR
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QorR -> QorR -> Bool
$c/= :: QorR -> QorR -> Bool
== :: QorR -> QorR -> Bool
$c== :: QorR -> QorR -> Bool
Eq, Int -> QorR -> ShowS
[QorR] -> ShowS
QorR -> String
(Int -> QorR -> ShowS)
-> (QorR -> String) -> ([QorR] -> ShowS) -> Show QorR
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QorR] -> ShowS
$cshowList :: [QorR] -> ShowS
show :: QorR -> String
$cshow :: QorR -> String
showsPrec :: Int -> QorR -> ShowS
$cshowsPrec :: Int -> QorR -> ShowS
Show, Int -> QorR
QorR -> Int
QorR -> [QorR]
QorR -> QorR
QorR -> QorR -> [QorR]
QorR -> QorR -> QorR -> [QorR]
(QorR -> QorR)
-> (QorR -> QorR)
-> (Int -> QorR)
-> (QorR -> Int)
-> (QorR -> [QorR])
-> (QorR -> QorR -> [QorR])
-> (QorR -> QorR -> [QorR])
-> (QorR -> QorR -> QorR -> [QorR])
-> Enum QorR
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: QorR -> QorR -> QorR -> [QorR]
$cenumFromThenTo :: QorR -> QorR -> QorR -> [QorR]
enumFromTo :: QorR -> QorR -> [QorR]
$cenumFromTo :: QorR -> QorR -> [QorR]
enumFromThen :: QorR -> QorR -> [QorR]
$cenumFromThen :: QorR -> QorR -> [QorR]
enumFrom :: QorR -> [QorR]
$cenumFrom :: QorR -> [QorR]
fromEnum :: QorR -> Int
$cfromEnum :: QorR -> Int
toEnum :: Int -> QorR
$ctoEnum :: Int -> QorR
pred :: QorR -> QorR
$cpred :: QorR -> QorR
succ :: QorR -> QorR
$csucc :: QorR -> QorR
Enum, QorR
QorR -> QorR -> Bounded QorR
forall a. a -> a -> Bounded a
maxBound :: QorR
$cmaxBound :: QorR
minBound :: QorR
$cminBound :: QorR
Bounded)

-- | Kind of query.
data OPCODE
  = OP_STD -- ^ A standard query.
  | OP_INV -- ^ An inverse query (inverse queries are deprecated).
  | OP_SSR -- ^ A server status request.
  | OP_NOTIFY -- ^ A zone change notification (RFC1996)
  | OP_UPDATE -- ^ An update request (RFC2136)
  deriving (OPCODE -> OPCODE -> Bool
(OPCODE -> OPCODE -> Bool)
-> (OPCODE -> OPCODE -> Bool) -> Eq OPCODE
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OPCODE -> OPCODE -> Bool
$c/= :: OPCODE -> OPCODE -> Bool
== :: OPCODE -> OPCODE -> Bool
$c== :: OPCODE -> OPCODE -> Bool
Eq, Int -> OPCODE -> ShowS
[OPCODE] -> ShowS
OPCODE -> String
(Int -> OPCODE -> ShowS)
-> (OPCODE -> String) -> ([OPCODE] -> ShowS) -> Show OPCODE
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OPCODE] -> ShowS
$cshowList :: [OPCODE] -> ShowS
show :: OPCODE -> String
$cshow :: OPCODE -> String
showsPrec :: Int -> OPCODE -> ShowS
$cshowsPrec :: Int -> OPCODE -> ShowS
Show, Int -> OPCODE
OPCODE -> Int
OPCODE -> [OPCODE]
OPCODE -> OPCODE
OPCODE -> OPCODE -> [OPCODE]
OPCODE -> OPCODE -> OPCODE -> [OPCODE]
(OPCODE -> OPCODE)
-> (OPCODE -> OPCODE)
-> (Int -> OPCODE)
-> (OPCODE -> Int)
-> (OPCODE -> [OPCODE])
-> (OPCODE -> OPCODE -> [OPCODE])
-> (OPCODE -> OPCODE -> [OPCODE])
-> (OPCODE -> OPCODE -> OPCODE -> [OPCODE])
-> Enum OPCODE
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: OPCODE -> OPCODE -> OPCODE -> [OPCODE]
$cenumFromThenTo :: OPCODE -> OPCODE -> OPCODE -> [OPCODE]
enumFromTo :: OPCODE -> OPCODE -> [OPCODE]
$cenumFromTo :: OPCODE -> OPCODE -> [OPCODE]
enumFromThen :: OPCODE -> OPCODE -> [OPCODE]
$cenumFromThen :: OPCODE -> OPCODE -> [OPCODE]
enumFrom :: OPCODE -> [OPCODE]
$cenumFrom :: OPCODE -> [OPCODE]
fromEnum :: OPCODE -> Int
$cfromEnum :: OPCODE -> Int
toEnum :: Int -> OPCODE
$ctoEnum :: Int -> OPCODE
pred :: OPCODE -> OPCODE
$cpred :: OPCODE -> OPCODE
succ :: OPCODE -> OPCODE
$csucc :: OPCODE -> OPCODE
Enum, OPCODE
OPCODE -> OPCODE -> Bounded OPCODE
forall a. a -> a -> Bounded a
maxBound :: OPCODE
$cmaxBound :: OPCODE
minBound :: OPCODE
$cminBound :: OPCODE
Bounded)

-- | Convert a 16-bit DNS OPCODE number to its internal representation
--
toOPCODE :: Word16 -> Maybe OPCODE
toOPCODE :: Word16 -> Maybe OPCODE
toOPCODE i :: Word16
i = case Word16
i of
  0 -> OPCODE -> Maybe OPCODE
forall a. a -> Maybe a
Just OPCODE
OP_STD
  1 -> OPCODE -> Maybe OPCODE
forall a. a -> Maybe a
Just OPCODE
OP_INV
  2 -> OPCODE -> Maybe OPCODE
forall a. a -> Maybe a
Just OPCODE
OP_SSR
  -- OPCODE 3 is unassigned
  4 -> OPCODE -> Maybe OPCODE
forall a. a -> Maybe a
Just OPCODE
OP_NOTIFY
  5 -> OPCODE -> Maybe OPCODE
forall a. a -> Maybe a
Just OPCODE
OP_UPDATE
  _ -> Maybe OPCODE
forall a. Maybe a
Nothing

-- | Convert the internal representation of a DNS OPCODE to its 16-bit numeric
-- value.
--
fromOPCODE :: OPCODE -> Word16
fromOPCODE :: OPCODE -> Word16
fromOPCODE OP_STD    = 0
fromOPCODE OP_INV    = 1
fromOPCODE OP_SSR    = 2
fromOPCODE OP_NOTIFY = 4
fromOPCODE OP_UPDATE = 5

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

#if __GLASGOW_HASKELL__ >= 800
-- | EDNS extended 12-bit response code.  Non-EDNS messages use only the low 4
-- bits.  With EDNS this stores the combined error code from the DNS header and
-- and the EDNS psuedo-header. See 'EDNSheader' for more detail.
newtype RCODE = RCODE {
    -- | Convert an 'RCODE' to its numeric value.
    RCODE -> Word16
fromRCODE :: Word16
  } deriving (RCODE -> RCODE -> Bool
(RCODE -> RCODE -> Bool) -> (RCODE -> RCODE -> Bool) -> Eq RCODE
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RCODE -> RCODE -> Bool
$c/= :: RCODE -> RCODE -> Bool
== :: RCODE -> RCODE -> Bool
$c== :: RCODE -> RCODE -> Bool
Eq)

-- | Provide an Enum instance for backwards compatibility
instance Enum RCODE where
    fromEnum :: RCODE -> Int
fromEnum = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> (RCODE -> Word16) -> RCODE -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RCODE -> Word16
fromRCODE
    toEnum :: Int -> RCODE
toEnum = Word16 -> RCODE
RCODE (Word16 -> RCODE) -> (Int -> Word16) -> Int -> RCODE
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | No error condition.
pattern NoErr     :: RCODE
pattern $bNoErr :: RCODE
$mNoErr :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
NoErr      = RCODE  0
-- | Format error - The name server was
--   unable to interpret the query.
pattern FormatErr :: RCODE
pattern $bFormatErr :: RCODE
$mFormatErr :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
FormatErr  = RCODE  1
-- | Server failure - The name server was
--   unable to process this query due to a
--   problem with the name server.
pattern ServFail  :: RCODE
pattern $bServFail :: RCODE
$mServFail :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
ServFail   = RCODE  2
-- | Name Error - Meaningful only for
--   responses from an authoritative name
--   server, this code signifies that the
--   domain name referenced in the query does
--   not exist.
pattern NameErr   :: RCODE
pattern $bNameErr :: RCODE
$mNameErr :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
NameErr    = RCODE  3
-- | Not Implemented - The name server does
--   not support the requested kind of query.
pattern NotImpl   :: RCODE
pattern $bNotImpl :: RCODE
$mNotImpl :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
NotImpl    = RCODE  4
-- | Refused - The name server refuses to
--   perform the specified operation for
--   policy reasons.  For example, a name
--   server may not wish to provide the
--   information to the particular requester,
--   or a name server may not wish to perform
--   a particular operation (e.g., zone
--   transfer) for particular data.
pattern Refused   :: RCODE
pattern $bRefused :: RCODE
$mRefused :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
Refused    = RCODE  5
-- | YXDomain - Dynamic update response, a pre-requisite domain that should not
-- exist, does exist.
pattern YXDomain :: RCODE
pattern $bYXDomain :: RCODE
$mYXDomain :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
YXDomain  = RCODE 6
-- | YXRRSet - Dynamic update response, a pre-requisite RRSet that should not
-- exist, does exist.
pattern YXRRSet  :: RCODE
pattern $bYXRRSet :: RCODE
$mYXRRSet :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
YXRRSet   = RCODE 7
-- | NXRRSet - Dynamic update response, a pre-requisite RRSet that should
-- exist, does not exist.
pattern NXRRSet  :: RCODE
pattern $bNXRRSet :: RCODE
$mNXRRSet :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
NXRRSet   = RCODE 8
-- | NotAuth - Dynamic update response, the server is not authoritative for the
-- zone named in the Zone Section.
pattern NotAuth  :: RCODE
pattern $bNotAuth :: RCODE
$mNotAuth :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
NotAuth   = RCODE 9
-- | NotZone - Dynamic update response, a name used in the Prerequisite or
-- Update Section is not within the zone denoted by the Zone Section.
pattern NotZone  :: RCODE
pattern $bNotZone :: RCODE
$mNotZone :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
NotZone   = RCODE 10
-- | Bad OPT Version (BADVERS, RFC 6891).
pattern BadVers   :: RCODE
pattern $bBadVers :: RCODE
$mBadVers :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
BadVers    = RCODE 16
-- | Key not recognized [RFC2845]
pattern BadKey    :: RCODE
pattern $bBadKey :: RCODE
$mBadKey :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
BadKey     = RCODE 17
-- | Signature out of time window [RFC2845]
pattern BadTime   :: RCODE
pattern $bBadTime :: RCODE
$mBadTime :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
BadTime    = RCODE 18
-- | Bad TKEY Mode [RFC2930]
pattern BadMode   :: RCODE
pattern $bBadMode :: RCODE
$mBadMode :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
BadMode    = RCODE 19
-- | Duplicate key name [RFC2930]
pattern BadName   :: RCODE
pattern $bBadName :: RCODE
$mBadName :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
BadName    = RCODE 20
-- | Algorithm not supported [RFC2930]
pattern BadAlg    :: RCODE
pattern $bBadAlg :: RCODE
$mBadAlg :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
BadAlg     = RCODE 21
-- | Bad Truncation [RFC4635]
pattern BadTrunc  :: RCODE
pattern $bBadTrunc :: RCODE
$mBadTrunc :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
BadTrunc   = RCODE 22
-- | Bad/missing Server Cookie [RFC7873]
pattern BadCookie :: RCODE
pattern $bBadCookie :: RCODE
$mBadCookie :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
BadCookie  = RCODE 23
-- | Malformed (peer) EDNS message, no RCODE available.  This is not an RCODE
-- that can be sent by a peer.  It lies outside the 12-bit range expressible
-- via EDNS.  The low 12-bits are chosen to coincide with 'FormatErr'.  When
-- an EDNS message is malformed, and we're unable to extract the extended RCODE,
-- the header 'rcode' is set to 'BadRCODE'.
pattern BadRCODE  :: RCODE
pattern $bBadRCODE :: RCODE
$mBadRCODE :: forall r. RCODE -> (Void# -> r) -> (Void# -> r) -> r
BadRCODE   = RCODE 0x1001

-- | Use https://tools.ietf.org/html/rfc2929#section-2.3 names for DNS RCODEs
instance Show RCODE where
    show :: RCODE -> String
show NoErr     = "NoError"
    show FormatErr = "FormErr"
    show ServFail  = "ServFail"
    show NameErr   = "NXDomain"
    show NotImpl   = "NotImp"
    show Refused   = "Refused"
    show YXDomain  = "YXDomain"
    show YXRRSet   = "YXRRSet"
    show NotAuth   = "NotAuth"
    show NotZone   = "NotZone"
    show BadVers   = "BadVers"
    show BadKey    = "BadKey"
    show BadTime   = "BadTime"
    show BadMode   = "BadMode"
    show BadName   = "BadName"
    show BadAlg    = "BadAlg"
    show BadTrunc  = "BadTrunc"
    show BadCookie = "BadCookie"
    show x :: RCODE
x         = "RCODE " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word16 -> String
forall a. Show a => a -> String
show (Word16 -> String) -> Word16 -> String
forall a b. (a -> b) -> a -> b
$ RCODE -> Word16
fromRCODE RCODE
x)

-- | Convert a numeric value to a corresponding 'RCODE'.  The behaviour is
-- undefined for values outside the range @[0 .. 0xFFF]@ since the EDNS
-- extended RCODE is a 12-bit value.  Values in the range @[0xF01 .. 0xFFF]@
-- are reserved for private use.
toRCODE :: Word16 -> RCODE
toRCODE :: Word16 -> RCODE
toRCODE = Word16 -> RCODE
RCODE
#else
-- | EDNS extended 12-bit response code.  Non-EDNS messages use only the low 4
-- bits.  With EDNS this stores the combined error code from the DNS header and
-- and the EDNS psuedo-header. See 'EDNSheader' for more detail.
data RCODE
  = NoErr     -- ^ No error condition.
  | FormatErr -- ^ Format error - The name server was
              --   unable to interpret the query.
  | ServFail  -- ^ Server failure - The name server was
              --   unable to process this query due to a
              --   problem with the name server.
  | NameErr   -- ^ Name Error - Meaningful only for
              --   responses from an authoritative name
              --   server, this code signifies that the
              --   domain name referenced in the query does
              --   not exist.
  | NotImpl   -- ^ Not Implemented - The name server does
              --   not support the requested kind of query.
  | Refused   -- ^ Refused - The name server refuses to
              --   perform the specified operation for
              --   policy reasons.  For example, a name
              --   server may not wish to provide the
              --   information to the particular requester,
              --   or a name server may not wish to perform
              --   a particular operation (e.g., zone
              --   transfer) for particular data.
  | YXDomain  -- ^ Dynamic update response, a pre-requisite
              --   domain that should not exist, does exist.
  | YXRRSet   -- ^ Dynamic update response, a pre-requisite
              --   RRSet that should not exist, does exist.
  | NXRRSet   -- ^ Dynamic update response, a pre-requisite
              --   RRSet that should exist, does not exist.
  | NotAuth   -- ^ Dynamic update response, the server is not
              --   authoritative for the zone named in the Zone Section.
  | NotZone   -- ^ Dynamic update response, a name used in the
              --   Prerequisite or Update Section is not within the zone
              --   denoted by the Zone Section.
  | BadVers   -- ^ Bad OPT Version (RFC 6891)
  | BadKey    -- ^ Key not recognized [RFC2845]
  | BadTime   -- ^ Signature out of time window [RFC2845]
  | BadMode   -- ^ Bad TKEY Mode [RFC2930]
  | BadName   -- ^ Duplicate key name [RFC2930]
  | BadAlg    -- ^ Algorithm not supported [RFC2930]
  | BadTrunc  -- ^ Bad Truncation [RFC4635]
  | BadCookie -- ^ Bad/missing Server Cookie [RFC7873]
  | BadRCODE  -- ^ Malformed (peer) EDNS message, no RCODE available.  This is
              -- not an RCODE that can be sent by a peer.  It lies outside the
              -- 12-bit range expressible via EDNS.  The low bits are chosen to
              -- coincide with 'FormatErr'.  When an EDNS message is malformed,
              -- and we're unable to extract the extended RCODE, the header
              -- 'rcode' is set to 'BadRCODE'.
  | UnknownRCODE Word16
  deriving (Eq, Ord, Show)

-- | Convert an 'RCODE' to its numeric value.
fromRCODE :: RCODE -> Word16
fromRCODE NoErr     =  0
fromRCODE FormatErr =  1
fromRCODE ServFail  =  2
fromRCODE NameErr   =  3
fromRCODE NotImpl   =  4
fromRCODE Refused   =  5
fromRCODE YXDomain  =  6
fromRCODE YXRRSet   =  7
fromRCODE NXRRSet   =  8
fromRCODE NotAuth   =  9
fromRCODE NotZone   = 10
fromRCODE BadVers   = 16
fromRCODE BadKey    = 17
fromRCODE BadTime   = 18
fromRCODE BadMode   = 19
fromRCODE BadName   = 20
fromRCODE BadAlg    = 21
fromRCODE BadTrunc  = 22
fromRCODE BadCookie = 23
fromRCODE BadRCODE  = 0x1001
fromRCODE (UnknownRCODE x) = x

-- | Convert a numeric value to a corresponding 'RCODE'.  The behaviour
-- is undefined for values outside the range @[0 .. 0xFFF]@ since the
-- EDNS extended RCODE is a 12-bit value.  Values in the range
-- @[0xF01 .. 0xFFF]@ are reserved for private use.
--
toRCODE :: Word16 -> RCODE
toRCODE  0 = NoErr
toRCODE  1 = FormatErr
toRCODE  2 = ServFail
toRCODE  3 = NameErr
toRCODE  4 = NotImpl
toRCODE  5 = Refused
toRCODE  6 = YXDomain
toRCODE  7 = YXRRSet
toRCODE  8 = NXRRSet
toRCODE  9 = NotAuth
toRCODE 10 = NotZone
toRCODE 16 = BadVers
toRCODE 17 = BadKey
toRCODE 18 = BadTime
toRCODE 19 = BadMode
toRCODE 20 = BadName
toRCODE 21 = BadAlg
toRCODE 22 = BadTrunc
toRCODE 23 = BadCookie
toRCODE 0x1001 = BadRCODE
toRCODE  x = UnknownRCODE x
#endif

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

-- XXX: The Question really should also include the CLASS
--
-- | Raw data format for DNS questions.
data Question = Question {
    Question -> Domain
qname  :: Domain -- ^ A domain name
  , Question -> TYPE
qtype  :: TYPE   -- ^ The type of the query
  } deriving (Question -> Question -> Bool
(Question -> Question -> Bool)
-> (Question -> Question -> Bool) -> Eq Question
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Question -> Question -> Bool
$c/= :: Question -> Question -> Bool
== :: Question -> Question -> Bool
$c== :: Question -> Question -> Bool
Eq, Int -> Question -> ShowS
[Question] -> ShowS
Question -> String
(Int -> Question -> ShowS)
-> (Question -> String) -> ([Question] -> ShowS) -> Show Question
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Question] -> ShowS
$cshowList :: [Question] -> ShowS
show :: Question -> String
$cshow :: Question -> String
showsPrec :: Int -> Question -> ShowS
$cshowsPrec :: Int -> Question -> ShowS
Show)

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

-- | Resource record class.
type CLASS = Word16

-- | Resource record class for the Internet.
classIN :: CLASS
classIN :: Word16
classIN = 1

-- | Time to live in second.
type TTL = Word32

-- | Raw data format for resource records.
data ResourceRecord = ResourceRecord {
    ResourceRecord -> Domain
rrname  :: !Domain -- ^ Name
  , ResourceRecord -> TYPE
rrtype  :: !TYPE   -- ^ Resource record type
  , ResourceRecord -> Word16
rrclass :: !CLASS  -- ^ Resource record class
  , ResourceRecord -> TTL
rrttl   :: !TTL    -- ^ Time to live
  , ResourceRecord -> RData
rdata   :: !RData  -- ^ Resource data
  } deriving (ResourceRecord -> ResourceRecord -> Bool
(ResourceRecord -> ResourceRecord -> Bool)
-> (ResourceRecord -> ResourceRecord -> Bool) -> Eq ResourceRecord
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResourceRecord -> ResourceRecord -> Bool
$c/= :: ResourceRecord -> ResourceRecord -> Bool
== :: ResourceRecord -> ResourceRecord -> Bool
$c== :: ResourceRecord -> ResourceRecord -> Bool
Eq,Int -> ResourceRecord -> ShowS
Answers -> ShowS
ResourceRecord -> String
(Int -> ResourceRecord -> ShowS)
-> (ResourceRecord -> String)
-> (Answers -> ShowS)
-> Show ResourceRecord
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: Answers -> ShowS
$cshowList :: Answers -> ShowS
show :: ResourceRecord -> String
$cshow :: ResourceRecord -> String
showsPrec :: Int -> ResourceRecord -> ShowS
$cshowsPrec :: Int -> ResourceRecord -> ShowS
Show)

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

-- | Given a 32-bit circle-arithmetic DNS time, and the current absolute epoch
-- time, return the epoch time corresponding to the DNS timestamp.
--
dnsTime :: Word32 -- ^ DNS circle-arithmetic timestamp
        -> Int64  -- ^ current epoch time
        -> Int64  -- ^ absolute DNS timestamp
dnsTime :: TTL -> Int64 -> Int64
dnsTime tdns :: TTL
tdns tnow :: Int64
tnow =
    let delta :: TTL
delta = TTL
tdns TTL -> TTL -> TTL
forall a. Num a => a -> a -> a
- Int64 -> TTL
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
tnow
     in if TTL
delta TTL -> TTL -> Bool
forall a. Ord a => a -> a -> Bool
> 0x7FFFFFFF -- tdns is in the past?
           then Int64
tnow Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- (0x100000000 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- TTL -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral TTL
delta)
           else Int64
tnow Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ TTL -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral TTL
delta

-- | RRSIG representation.
--
-- As noted in
-- <https://tools.ietf.org/html/rfc4034#section-3.1.5 Section 3.1.5 of RFC 4034>
-- the RRsig inception and expiration times use serial number arithmetic.  As a
-- result these timestamps /are not/ pure values, their meaning is
-- time-dependent!  They depend on the present time and are both at most
-- approximately +\/-68 years from the present.  This ambiguity is not a
-- problem because cached RRSIG records should only persist a few days,
-- signature lifetimes should be *much* shorter than 68 years, and key rotation
-- should result any misconstrued 136-year-old signatures fail to validate.
-- This also means that the interpretation of a time that is exactly half-way
-- around the clock at @now +\/-0x80000000@ is not important, the signature
-- should never be valid.
--
-- The upshot for us is that we need to convert these *impure* relative values
-- to pure absolute values at the moment they are received from from the network
-- (or read from files, ... in some impure I/O context), and convert them back to
-- 32-bit values when encoding.  Therefore, the constructor takes absolute
-- 64-bit representations of the inception and expiration times.
--
-- The 'dnsTime' function performs the requisite conversion.
--
data RD_RRSIG = RDREP_RRSIG
    { RD_RRSIG -> TYPE
rrsigType       :: !TYPE       -- ^ RRtype of RRset signed
    , RD_RRSIG -> Word8
rrsigKeyAlg     :: !Word8      -- ^ DNSKEY algorithm
    , RD_RRSIG -> Word8
rrsigNumLabels  :: !Word8      -- ^ Number of labels signed
    , RD_RRSIG -> TTL
rrsigTTL        :: !Word32     -- ^ Maximum origin TTL
    , RD_RRSIG -> Int64
rrsigExpiration :: !Int64      -- ^ Time last valid
    , RD_RRSIG -> Int64
rrsigInception  :: !Int64      -- ^ Time first valid
    , RD_RRSIG -> Word16
rrsigKeyTag     :: !Word16     -- ^ Signing key tag
    , RD_RRSIG -> Domain
rrsigZone       :: !Domain     -- ^ Signing domain
    , RD_RRSIG -> Domain
rrsigValue      :: !ByteString -- ^ Opaque signature
    }
    deriving (RD_RRSIG -> RD_RRSIG -> Bool
(RD_RRSIG -> RD_RRSIG -> Bool)
-> (RD_RRSIG -> RD_RRSIG -> Bool) -> Eq RD_RRSIG
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RD_RRSIG -> RD_RRSIG -> Bool
$c/= :: RD_RRSIG -> RD_RRSIG -> Bool
== :: RD_RRSIG -> RD_RRSIG -> Bool
$c== :: RD_RRSIG -> RD_RRSIG -> Bool
Eq, Eq RD_RRSIG
Eq RD_RRSIG =>
(RD_RRSIG -> RD_RRSIG -> Ordering)
-> (RD_RRSIG -> RD_RRSIG -> Bool)
-> (RD_RRSIG -> RD_RRSIG -> Bool)
-> (RD_RRSIG -> RD_RRSIG -> Bool)
-> (RD_RRSIG -> RD_RRSIG -> Bool)
-> (RD_RRSIG -> RD_RRSIG -> RD_RRSIG)
-> (RD_RRSIG -> RD_RRSIG -> RD_RRSIG)
-> Ord RD_RRSIG
RD_RRSIG -> RD_RRSIG -> Bool
RD_RRSIG -> RD_RRSIG -> Ordering
RD_RRSIG -> RD_RRSIG -> RD_RRSIG
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RD_RRSIG -> RD_RRSIG -> RD_RRSIG
$cmin :: RD_RRSIG -> RD_RRSIG -> RD_RRSIG
max :: RD_RRSIG -> RD_RRSIG -> RD_RRSIG
$cmax :: RD_RRSIG -> RD_RRSIG -> RD_RRSIG
>= :: RD_RRSIG -> RD_RRSIG -> Bool
$c>= :: RD_RRSIG -> RD_RRSIG -> Bool
> :: RD_RRSIG -> RD_RRSIG -> Bool
$c> :: RD_RRSIG -> RD_RRSIG -> Bool
<= :: RD_RRSIG -> RD_RRSIG -> Bool
$c<= :: RD_RRSIG -> RD_RRSIG -> Bool
< :: RD_RRSIG -> RD_RRSIG -> Bool
$c< :: RD_RRSIG -> RD_RRSIG -> Bool
compare :: RD_RRSIG -> RD_RRSIG -> Ordering
$ccompare :: RD_RRSIG -> RD_RRSIG -> Ordering
$cp1Ord :: Eq RD_RRSIG
Ord)

instance Show RD_RRSIG where
    show :: RD_RRSIG -> String
show RDREP_RRSIG{..} = [String] -> String
unwords
        [ TYPE -> String
forall a. Show a => a -> String
show TYPE
rrsigType
        , Word8 -> String
forall a. Show a => a -> String
show Word8
rrsigKeyAlg
        , Word8 -> String
forall a. Show a => a -> String
show Word8
rrsigNumLabels
        , TTL -> String
forall a. Show a => a -> String
show TTL
rrsigTTL
        , Int64 -> String
showTime Int64
rrsigExpiration
        , Int64 -> String
showTime Int64
rrsigInception
        , Word16 -> String
forall a. Show a => a -> String
show Word16
rrsigKeyTag
        , Domain -> String
BS.unpack Domain
rrsigZone
        , Domain -> String
_b64encode Domain
rrsigValue
        ]
      where
        showTime :: Int64 -> String
        showTime :: Int64 -> String
showTime t :: Int64
t = [TimeFormatElem] -> Elapsed -> String
forall format t.
(TimeFormat format, Timeable t) =>
format -> t -> String
H.timePrint [TimeFormatElem]
fmt (Elapsed -> String) -> Elapsed -> String
forall a b. (a -> b) -> a -> b
$ Seconds -> Elapsed
H.Elapsed (Seconds -> Elapsed) -> Seconds -> Elapsed
forall a b. (a -> b) -> a -> b
$ Int64 -> Seconds
H.Seconds Int64
t
          where
            fmt :: [TimeFormatElem]
fmt = [ TimeFormatElem
H.Format_Year4, TimeFormatElem
H.Format_Month2, TimeFormatElem
H.Format_Day2
                  , TimeFormatElem
H.Format_Hour,  TimeFormatElem
H.Format_Minute, TimeFormatElem
H.Format_Second ]

-- | Raw data format for each type.
data RData = RD_A IPv4           -- ^ IPv4 address
           | RD_NS Domain        -- ^ An authoritative name serve
           | RD_CNAME Domain     -- ^ The canonical name for an alias
           | RD_SOA Domain Mailbox Word32 Word32 Word32 Word32 Word32
                                 -- ^ Marks the start of a zone of authority
           | RD_NULL ByteString  -- ^ NULL RR (EXPERIMENTAL, RFC1035).
           | RD_PTR Domain       -- ^ A domain name pointer
           | RD_MX Word16 Domain -- ^ Mail exchange
           | RD_TXT ByteString   -- ^ Text strings
           | RD_AAAA IPv6        -- ^ IPv6 Address
           | RD_SRV Word16 Word16 Word16 Domain
                                 -- ^ Server Selection (RFC2782)
           | RD_DNAME Domain     -- ^ DNAME (RFC6672)
           | RD_OPT [OData]      -- ^ OPT (RFC6891)
           | RD_DS Word16 Word8 Word8 ByteString -- ^ Delegation Signer (RFC4034)
           | RD_RRSIG RD_RRSIG   -- ^ DNSSEC signature
           | RD_NSEC Domain [TYPE] -- ^ DNSSEC denial of existence NSEC record
           | RD_DNSKEY Word16 Word8 Word8 ByteString
                                 -- ^ DNSKEY (RFC4034)
           | RD_NSEC3 Word8 Word8 Word16 ByteString ByteString [TYPE]
                                 -- ^ DNSSEC hashed denial of existence (RFC5155)
           | RD_NSEC3PARAM Word8 Word8 Word16 ByteString
                                 -- ^ NSEC3 zone parameters (RFC5155)
           | RD_TLSA Word8 Word8 Word8 ByteString
                                 -- ^ TLSA (RFC6698)
           | RD_CDS Word16 Word8 Word8 ByteString
                                 -- ^ Child DS (RFC7344)
           | RD_CDNSKEY Word16 Word8 Word8 ByteString
                                 -- ^ Child DNSKEY (RFC7344)
           --RD_CSYNC
           | UnknownRData ByteString   -- ^ Unknown resource data
    deriving (RData -> RData -> Bool
(RData -> RData -> Bool) -> (RData -> RData -> Bool) -> Eq RData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RData -> RData -> Bool
$c/= :: RData -> RData -> Bool
== :: RData -> RData -> Bool
$c== :: RData -> RData -> Bool
Eq, Eq RData
Eq RData =>
(RData -> RData -> Ordering)
-> (RData -> RData -> Bool)
-> (RData -> RData -> Bool)
-> (RData -> RData -> Bool)
-> (RData -> RData -> Bool)
-> (RData -> RData -> RData)
-> (RData -> RData -> RData)
-> Ord RData
RData -> RData -> Bool
RData -> RData -> Ordering
RData -> RData -> RData
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RData -> RData -> RData
$cmin :: RData -> RData -> RData
max :: RData -> RData -> RData
$cmax :: RData -> RData -> RData
>= :: RData -> RData -> Bool
$c>= :: RData -> RData -> Bool
> :: RData -> RData -> Bool
$c> :: RData -> RData -> Bool
<= :: RData -> RData -> Bool
$c<= :: RData -> RData -> Bool
< :: RData -> RData -> Bool
$c< :: RData -> RData -> Bool
compare :: RData -> RData -> Ordering
$ccompare :: RData -> RData -> Ordering
$cp1Ord :: Eq RData
Ord)

instance Show RData where
  show :: RData -> String
show rd :: RData
rd = case RData
rd of
      RD_A                  address :: IPv4
address -> IPv4 -> String
forall a. Show a => a -> String
show IPv4
address
      RD_NS                 nsdname :: Domain
nsdname -> Domain -> String
showDomain Domain
nsdname
      RD_CNAME                cname :: Domain
cname -> Domain -> String
showDomain Domain
cname
      RD_SOA          a :: Domain
a b :: Domain
b c :: TTL
c d :: TTL
d e :: TTL
e f :: TTL
f g :: TTL
g -> Domain -> Domain -> TTL -> TTL -> TTL -> TTL -> TTL -> String
forall a a a a a.
(Show a, Show a, Show a, Show a, Show a) =>
Domain -> Domain -> a -> a -> a -> a -> a -> String
showSOA Domain
a Domain
b TTL
c TTL
d TTL
e TTL
f TTL
g
      RD_NULL                 bytes :: Domain
bytes -> Domain -> String
showOpaque Domain
bytes
      RD_PTR               ptrdname :: Domain
ptrdname -> Domain -> String
showDomain Domain
ptrdname
      RD_MX               pref :: Word16
pref exch :: Domain
exch -> Word16 -> Domain -> String
forall a. Show a => a -> Domain -> String
showMX Word16
pref Domain
exch
      RD_TXT             textstring :: Domain
textstring -> Domain -> String
showTXT Domain
textstring
      RD_AAAA               address :: IPv6
address -> IPv6 -> String
forall a. Show a => a -> String
show IPv6
address
      RD_SRV        pri :: Word16
pri wei :: Word16
wei prt :: Word16
prt tgt :: Domain
tgt -> Word16 -> Word16 -> Word16 -> Domain -> String
forall a a a.
(Show a, Show a, Show a) =>
a -> a -> a -> Domain -> String
showSRV Word16
pri Word16
wei Word16
prt Domain
tgt
      RD_DNAME               target :: Domain
target -> Domain -> String
showDomain Domain
target
      RD_OPT                options :: [OData]
options -> [OData] -> String
forall a. Show a => a -> String
show [OData]
options
      RD_DS          tag :: Word16
tag alg :: Word8
alg dalg :: Word8
dalg d :: Domain
d -> Word16 -> Word8 -> Word8 -> Domain -> String
forall a a a.
(Show a, Show a, Show a) =>
a -> a -> a -> Domain -> String
showDS Word16
tag Word8
alg Word8
dalg Domain
d
      RD_RRSIG                rrsig :: RD_RRSIG
rrsig -> RD_RRSIG -> String
forall a. Show a => a -> String
show RD_RRSIG
rrsig
      RD_NSEC            next :: Domain
next types :: [TYPE]
types -> Domain -> [TYPE] -> String
forall a. Show a => Domain -> [a] -> String
showNSEC Domain
next [TYPE]
types
      RD_DNSKEY             f :: Word16
f p :: Word8
p a :: Word8
a k :: Domain
k -> Word16 -> Word8 -> Word8 -> Domain -> String
forall a a a.
(Show a, Show a, Show a) =>
a -> a -> a -> Domain -> String
showDNSKEY Word16
f Word8
p Word8
a Domain
k
      RD_NSEC3      a :: Word8
a f :: Word8
f i :: Word16
i s :: Domain
s h :: Domain
h types :: [TYPE]
types -> Word8 -> Word8 -> Word16 -> Domain -> Domain -> [TYPE] -> String
forall a a a a.
(Show a, Show a, Show a, Show a) =>
a -> a -> a -> Domain -> Domain -> [a] -> String
showNSEC3 Word8
a Word8
f Word16
i Domain
s Domain
h [TYPE]
types
      RD_NSEC3PARAM         a :: Word8
a f :: Word8
f i :: Word16
i s :: Domain
s -> Word8 -> Word8 -> Word16 -> Domain -> String
forall a a a.
(Show a, Show a, Show a) =>
a -> a -> a -> Domain -> String
showNSEC3PARAM Word8
a Word8
f Word16
i Domain
s
      RD_TLSA               u :: Word8
u s :: Word8
s m :: Word8
m d :: Domain
d -> Word8 -> Word8 -> Word8 -> Domain -> String
forall a a a.
(Show a, Show a, Show a) =>
a -> a -> a -> Domain -> String
showTLSA Word8
u Word8
s Word8
m Domain
d
      RD_CDS         tag :: Word16
tag alg :: Word8
alg dalg :: Word8
dalg d :: Domain
d -> Word16 -> Word8 -> Word8 -> Domain -> String
forall a a a.
(Show a, Show a, Show a) =>
a -> a -> a -> Domain -> String
showDS Word16
tag Word8
alg Word8
dalg Domain
d
      RD_CDNSKEY            f :: Word16
f p :: Word8
p a :: Word8
a k :: Domain
k -> Word16 -> Word8 -> Word8 -> Domain -> String
forall a a a.
(Show a, Show a, Show a) =>
a -> a -> a -> Domain -> String
showDNSKEY Word16
f Word8
p Word8
a Domain
k
      UnknownRData            bytes :: Domain
bytes -> Domain -> String
showOpaque Domain
bytes
    where
      showSalt :: Domain -> String
showSalt ""    = "-"
      showSalt salt :: Domain
salt  = Domain -> String
_b16encode Domain
salt
      showDomain :: Domain -> String
showDomain = Domain -> String
BS.unpack
      showSOA :: Domain -> Domain -> a -> a -> a -> a -> a -> String
showSOA mname :: Domain
mname mrname :: Domain
mrname serial :: a
serial refresh :: a
refresh retry :: a
retry expire :: a
expire minttl :: a
minttl =
          Domain -> String
showDomain Domain
mname String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
showDomain Domain
mrname String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++
          a -> String
forall a. Show a => a -> String
show a
serial String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
refresh String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++
          a -> String
forall a. Show a => a -> String
show a
retry String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
expire String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
minttl
      showMX :: a -> Domain -> String
showMX preference :: a
preference exchange :: Domain
exchange =
          a -> String
forall a. Show a => a -> String
show a
preference String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
showDomain Domain
exchange
      showTXT :: Domain -> String
showTXT bs :: Domain
bs = '"' Char -> ShowS
forall a. a -> [a] -> [a]
: (Word8 -> ShowS) -> String -> Domain -> String
forall a. (Word8 -> a -> a) -> a -> Domain -> a
B.foldr Word8 -> ShowS
dnsesc ['"'] Domain
bs
        where
          c2w :: Char -> Word8
c2w = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum
          w2c :: Word8 -> Char
w2c = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
          doubleQuote :: Word8
doubleQuote = Char -> Word8
c2w Char
'"'
          backSlash :: Word8
backSlash   = Char -> Word8
c2w Char
'\\'
          dnsesc :: Word8 -> ShowS
dnsesc c :: Word8
c s :: String
s
              | Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
doubleQuote   = '\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> Char
w2c Word8
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
s
              | Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
backSlash     = '\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> Char
w2c Word8
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
s
              | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= 32 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 127 =        Word8 -> Char
w2c Word8
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
s
              | Bool
otherwise          = '\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> ShowS
forall a. Integral a => a -> ShowS
ddd Word8
c   String
s
          ddd :: a -> ShowS
ddd c :: a
c s :: String
s =
              let (q100 :: Int
q100, r100 :: Int
r100) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
c) 100
                  (q10 :: Int
q10, r10 :: Int
r10) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod Int
r100 10
               in Int -> Char
intToDigit Int
q100 Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> Char
intToDigit Int
q10 Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> Char
intToDigit Int
r10 Char -> ShowS
forall a. a -> [a] -> [a]
: String
s
      showSRV :: a -> a -> a -> Domain -> String
showSRV priority :: a
priority weight :: a
weight port :: a
port target :: Domain
target =
          a -> String
forall a. Show a => a -> String
show a
priority String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
weight String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++
          a -> String
forall a. Show a => a -> String
show a
port String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
BS.unpack Domain
target
      showDS :: a -> a -> a -> Domain -> String
showDS keytag :: a
keytag alg :: a
alg digestType :: a
digestType digest :: Domain
digest =
          a -> String
forall a. Show a => a -> String
show a
keytag String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
alg String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++
          a -> String
forall a. Show a => a -> String
show a
digestType String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
_b16encode Domain
digest
      showNSEC :: Domain -> [a] -> String
showNSEC next :: Domain
next types :: [a]
types =
          [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Domain -> String
showDomain Domain
next String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show [a]
types
      showDNSKEY :: a -> a -> a -> Domain -> String
showDNSKEY flags :: a
flags protocol :: a
protocol alg :: a
alg key :: Domain
key =
          a -> String
forall a. Show a => a -> String
show a
flags String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
protocol String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++
          a -> String
forall a. Show a => a -> String
show a
alg String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
_b64encode Domain
key
      -- | <https://tools.ietf.org/html/rfc5155#section-3.2>
      showNSEC3 :: a -> a -> a -> Domain -> Domain -> [a] -> String
showNSEC3 hashalg :: a
hashalg flags :: a
flags iterations :: a
iterations salt :: Domain
salt nexthash :: Domain
nexthash types :: [a]
types =
          [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
hashalg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: a -> String
forall a. Show a => a -> String
show a
flags String -> [String] -> [String]
forall a. a -> [a] -> [a]
: a -> String
forall a. Show a => a -> String
show a
iterations String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                    Domain -> String
showSalt Domain
salt String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Domain -> String
_b32encode Domain
nexthash String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show [a]
types
      showNSEC3PARAM :: a -> a -> a -> Domain -> String
showNSEC3PARAM hashAlg :: a
hashAlg flags :: a
flags iterations :: a
iterations salt :: Domain
salt =
          a -> String
forall a. Show a => a -> String
show a
hashAlg String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
flags String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++
          a -> String
forall a. Show a => a -> String
show a
iterations String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
showSalt Domain
salt
      showTLSA :: a -> a -> a -> Domain -> String
showTLSA usage :: a
usage selector :: a
selector mtype :: a
mtype digest :: Domain
digest =
          a -> String
forall a. Show a => a -> String
show a
usage String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
selector String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++
          a -> String
forall a. Show a => a -> String
show a
mtype String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
_b16encode Domain
digest
      -- | Opaque RData: <https://tools.ietf.org/html/rfc3597#section-5>
      showOpaque :: Domain -> String
showOpaque bs :: Domain
bs = [String] -> String
unwords ["\\#", Int -> String
forall a. Show a => a -> String
show (Domain -> Int
BS.length Domain
bs), Domain -> String
_b16encode Domain
bs]

_b16encode, _b32encode, _b64encode :: ByteString -> String
_b16encode :: Domain -> String
_b16encode = Domain -> String
BS.unpack(Domain -> String) -> (Domain -> Domain) -> Domain -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> Domain
B16.encode
_b32encode :: Domain -> String
_b32encode = Domain -> String
BS.unpack(Domain -> String) -> (Domain -> Domain) -> Domain -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> Domain
B32.encode
_b64encode :: Domain -> String
_b64encode = Domain -> String
BS.unpack(Domain -> String) -> (Domain -> Domain) -> Domain -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> Domain
B64.encode

-- | Type alias for resource records in the answer section.
type Answers = [ResourceRecord]

-- | Type alias for resource records in the answer section.
type AuthorityRecords = [ResourceRecord]

-- | Type for resource records in the additional section.
type AdditionalRecords = [ResourceRecord]

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

-- | A 'DNSMessage' template for queries with default settings for
-- the message 'DNSHeader' and 'EDNSheader'.  This is the initial
-- query message state, before customization via 'QueryControls'.
--
defaultQuery :: DNSMessage
defaultQuery :: DNSMessage
defaultQuery = $WDNSMessage :: DNSHeader
-> EDNSheader
-> [Question]
-> Answers
-> Answers
-> Answers
-> DNSMessage
DNSMessage {
    header :: DNSHeader
header = $WDNSHeader :: Word16 -> DNSFlags -> DNSHeader
DNSHeader {
       identifier :: Word16
identifier = 0
     , flags :: DNSFlags
flags = DNSFlags
defaultDNSFlags
     }
  , ednsHeader :: EDNSheader
ednsHeader = EDNS -> EDNSheader
EDNSheader EDNS
defaultEDNS
  , question :: [Question]
question   = []
  , answer :: Answers
answer     = []
  , authority :: Answers
authority  = []
  , additional :: Answers
additional = []
  }

-- | Default response.  When responding to EDNS queries, the response must
-- either be an EDNS response, or else FormatErr must be returned.  The default
-- response message has EDNS disabled ('ednsHeader' set to 'NoEDNS'), it should
-- be updated as appropriate.
--
-- Do not explicitly add OPT RRs to the additional section, instead let the
-- encoder compute and add the OPT record based on the EDNS pseudo-header.
--
-- The 'RCODE' in the 'DNSHeader' should be set to the appropriate 12-bit
-- extended value, which will be split between the primary header and EDNS OPT
-- record during message encoding (low 4 bits in DNS header, high 8 bits in
-- EDNS OPT record).  See 'EDNSheader' for more details.
--
defaultResponse :: DNSMessage
defaultResponse :: DNSMessage
defaultResponse = $WDNSMessage :: DNSHeader
-> EDNSheader
-> [Question]
-> Answers
-> Answers
-> Answers
-> DNSMessage
DNSMessage {
    header :: DNSHeader
header = $WDNSHeader :: Word16 -> DNSFlags -> DNSHeader
DNSHeader {
       identifier :: Word16
identifier = 0
     , flags :: DNSFlags
flags = DNSFlags
defaultDNSFlags {
              qOrR :: QorR
qOrR = QorR
QR_Response
            , authAnswer :: Bool
authAnswer = Bool
True
            , recAvailable :: Bool
recAvailable = Bool
True
            , authenData :: Bool
authenData = Bool
False
       }
     }
  , ednsHeader :: EDNSheader
ednsHeader = EDNSheader
NoEDNS
  , question :: [Question]
question   = []
  , answer :: Answers
answer     = []
  , authority :: Answers
authority  = []
  , additional :: Answers
additional = []
  }

-- | A query template with 'QueryControls' overrides applied,
-- with just the 'Question' and query 'Identifier' remaining
-- to be filled in.
--
makeEmptyQuery :: QueryControls -- ^ Flag and EDNS overrides
               -> DNSMessage
makeEmptyQuery :: QueryControls -> DNSMessage
makeEmptyQuery ctls :: QueryControls
ctls = DNSMessage
defaultQuery {
      header :: DNSHeader
header = DNSHeader
header'
    , ednsHeader :: EDNSheader
ednsHeader = EdnsControls -> EDNSheader
queryEdns EdnsControls
ehctls
    }
  where
    hctls :: HeaderControls
hctls = QueryControls -> HeaderControls
qctlHeader QueryControls
ctls
    ehctls :: EdnsControls
ehctls = QueryControls -> EdnsControls
qctlEdns QueryControls
ctls
    header' :: DNSHeader
header' = (DNSMessage -> DNSHeader
header DNSMessage
defaultQuery) { flags :: DNSFlags
flags = HeaderControls -> DNSFlags
queryDNSFlags HeaderControls
hctls }

    -- | Apply the given 'FlagOp' to a default boolean value to produce the final
    -- setting.
    --
    applyFlag :: FlagOp -> Bool -> Bool
    applyFlag :: FlagOp -> Bool -> Bool
applyFlag FlagSet   _ = Bool
True
    applyFlag FlagClear _ = Bool
False
    applyFlag _         v :: Bool
v = Bool
v

    -- | Construct a list of 0 or 1 EDNS OPT RRs based on EdnsControls setting.
    --
    queryEdns :: EdnsControls -> EDNSheader
    queryEdns :: EdnsControls -> EDNSheader
queryEdns (EdnsControls en :: FlagOp
en vn :: Maybe Word8
vn sz :: Maybe Word16
sz d0 :: FlagOp
d0 od :: ODataOp
od) =
        let d :: EDNS
d  = EDNS
defaultEDNS
         in if FlagOp
en FlagOp -> FlagOp -> Bool
forall a. Eq a => a -> a -> Bool
== FlagOp
FlagClear
            then EDNSheader
NoEDNS
            else EDNS -> EDNSheader
EDNSheader (EDNS -> EDNSheader) -> EDNS -> EDNSheader
forall a b. (a -> b) -> a -> b
$ EDNS
d { ednsVersion :: Word8
ednsVersion = Word8 -> Maybe Word8 -> Word8
forall a. a -> Maybe a -> a
fromMaybe (EDNS -> Word8
ednsVersion EDNS
d) Maybe Word8
vn
                                , ednsUdpSize :: Word16
ednsUdpSize = Word16 -> Maybe Word16 -> Word16
forall a. a -> Maybe a -> a
fromMaybe (EDNS -> Word16
ednsUdpSize EDNS
d) Maybe Word16
sz
                                , ednsDnssecOk :: Bool
ednsDnssecOk = FlagOp -> Bool -> Bool
applyFlag FlagOp
d0 (EDNS -> Bool
ednsDnssecOk EDNS
d)
                                , ednsOptions :: [OData]
ednsOptions  = ODataOp -> [OData]
_odataDedup ODataOp
od
                                }

    -- | Apply all the query flag overrides to 'defaultDNSFlags', returning the
    -- resulting 'DNSFlags' suitable for making queries with the requested flag
    -- settings.  This is only needed if you're creating your own 'DNSMessage',
    -- the 'Network.DNS.LookupRaw.lookupRawCtl' function takes a 'QueryControls'
    -- argument and handles this conversion internally.
    --
    -- Default overrides can be specified in the resolver configuration by setting
    -- the 'Network.DNS.resolvQueryControls' field of the
    -- 'Network.DNS.Resolver.ResolvConf' argument to
    -- 'Network.DNS.Resolver.makeResolvSeed'.  These then apply to lookups via
    -- resolvers based on the resulting configuration, with the exception of
    -- 'Network.DNS.LookupRaw.lookupRawCtl' which takes an additional
    -- 'QueryControls' argument to augment the default overrides.
    --
    queryDNSFlags :: HeaderControls -> DNSFlags
    queryDNSFlags :: HeaderControls -> DNSFlags
queryDNSFlags (HeaderControls rd :: FlagOp
rd ad :: FlagOp
ad cd :: FlagOp
cd) = DNSFlags
d {
          recDesired :: Bool
recDesired = FlagOp -> Bool -> Bool
applyFlag FlagOp
rd (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DNSFlags -> Bool
recDesired DNSFlags
d
        , authenData :: Bool
authenData = FlagOp -> Bool -> Bool
applyFlag FlagOp
ad (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DNSFlags -> Bool
authenData DNSFlags
d
        , chkDisable :: Bool
chkDisable = FlagOp -> Bool -> Bool
applyFlag FlagOp
cd (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DNSFlags -> Bool
chkDisable DNSFlags
d
        }
      where
        d :: DNSFlags
d = DNSFlags
defaultDNSFlags

-- | Construct a complete query 'DNSMessage', by combining the 'defaultQuery'
-- template with the specified 'Identifier', and 'Question'.  The
-- 'QueryControls' can be 'mempty' to leave all header and EDNS settings at
-- their default values, or some combination of overrides.  A default set of
-- overrides can be enabled via the 'Network.DNS.Resolver.resolvQueryControls'
-- field of 'Network.DNS.Resolver.ResolvConf'.  Per-query overrides are
-- possible by using 'Network.DNS.LookupRaw.loookupRawCtl'.
--
makeQuery :: Identifier        -- ^ Crypto random request id
          -> Question          -- ^ Question name and type
          -> QueryControls     -- ^ Custom RD\/AD\/CD flags and EDNS settings
          -> DNSMessage
makeQuery :: Word16 -> Question -> QueryControls -> DNSMessage
makeQuery idt :: Word16
idt q :: Question
q ctls :: QueryControls
ctls = DNSMessage
empqry {
      header :: DNSHeader
header = (DNSMessage -> DNSHeader
header DNSMessage
empqry) { identifier :: Word16
identifier = Word16
idt }
    , question :: [Question]
question = [Question
q]
    }
  where
    empqry :: DNSMessage
empqry = QueryControls -> DNSMessage
makeEmptyQuery QueryControls
ctls

-- | Construct a query response 'DNSMessage'.
makeResponse :: Identifier
             -> Question
             -> Answers
             -> DNSMessage
makeResponse :: Word16 -> Question -> Answers -> DNSMessage
makeResponse idt :: Word16
idt q :: Question
q as :: Answers
as = DNSMessage
defaultResponse {
      header :: DNSHeader
header = DNSHeader
header' { identifier :: Word16
identifier = Word16
idt }
    , question :: [Question]
question = [Question
q]
    , answer :: Answers
answer   = Answers
as
    }
  where
    header' :: DNSHeader
header' = DNSMessage -> DNSHeader
header DNSMessage
defaultResponse

----------------------------------------------------------------
-- EDNS (RFC 6891, EDNS(0))
----------------------------------------------------------------

-- | EDNS information defined in RFC 6891.
data EDNS = EDNS {
    -- | EDNS version, presently only version 0 is defined.
    EDNS -> Word8
ednsVersion :: !Word8
    -- | Supported UDP payload size.
  , EDNS -> Word16
ednsUdpSize  :: !Word16
    -- | Request DNSSEC replies (with RRSIG and NSEC records as as appropriate)
    -- from the server.  Generally, not needed (except for diagnostic purposes)
    -- unless the signatures will be validated.  Just setting the 'AD' bit in
    -- the query and checking it in the response is sufficient (but often
    -- subject to man-in-the-middle forgery) if all that's wanted is whether
    -- the server validated the response.
  , EDNS -> Bool
ednsDnssecOk :: !Bool
    -- | EDNS options (e.g. 'OD_NSID', 'OD_ClientSubnet', ...)
  , EDNS -> [OData]
ednsOptions  :: ![OData]
  } deriving (EDNS -> EDNS -> Bool
(EDNS -> EDNS -> Bool) -> (EDNS -> EDNS -> Bool) -> Eq EDNS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EDNS -> EDNS -> Bool
$c/= :: EDNS -> EDNS -> Bool
== :: EDNS -> EDNS -> Bool
$c== :: EDNS -> EDNS -> Bool
Eq, Int -> EDNS -> ShowS
[EDNS] -> ShowS
EDNS -> String
(Int -> EDNS -> ShowS)
-> (EDNS -> String) -> ([EDNS] -> ShowS) -> Show EDNS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EDNS] -> ShowS
$cshowList :: [EDNS] -> ShowS
show :: EDNS -> String
$cshow :: EDNS -> String
showsPrec :: Int -> EDNS -> ShowS
$cshowsPrec :: Int -> EDNS -> ShowS
Show)

-- | The default EDNS pseudo-header for queries.  The UDP buffer size is set to
--   1216 bytes, which should result in replies that fit into the 1280 byte
--   IPv6 minimum MTU.  Since IPv6 only supports fragmentation at the source,
--   and even then not all gateways forward IPv6 pre-fragmented IPv6 packets,
--   it is best to keep DNS packet sizes below this limit when using IPv6
--   nameservers.  A larger value may be practical when using IPv4 exclusively.
--
-- @
-- defaultEDNS = EDNS
--     { ednsVersion = 0      -- The default EDNS version is 0
--     , ednsUdpSize = 1232   -- IPv6-safe UDP MTU (RIPE recommendation)
--     , ednsDnssecOk = False -- We don't do DNSSEC validation
--     , ednsOptions = []     -- No EDNS options by default
--     }
-- @
--
defaultEDNS :: EDNS
defaultEDNS :: EDNS
defaultEDNS = $WEDNS :: Word8 -> Word16 -> Bool -> [OData] -> EDNS
EDNS
    { ednsVersion :: Word8
ednsVersion = 0      -- The default EDNS version is 0
    , ednsUdpSize :: Word16
ednsUdpSize = 1232   -- IPv6-safe UDP MTU
    , ednsDnssecOk :: Bool
ednsDnssecOk = Bool
False -- We don't do DNSSEC validation
    , ednsOptions :: [OData]
ednsOptions = []     -- No EDNS options by default
    }

-- | Maximum UDP size that can be advertised.  If the 'ednsUdpSize' of 'EDNS'
--   is larger, then this value is sent instead.  This value is likely to work
--   only for local nameservers on the loopback network.  Servers may enforce
--   a smaller limit.
--
-- >>> maxUdpSize
-- 16384
maxUdpSize :: Word16
maxUdpSize :: Word16
maxUdpSize = 16384

-- | Minimum UDP size to advertise. If 'ednsUdpSize' of 'EDNS' is smaller,
--   then this value is sent instead.
--
-- >>> minUdpSize
-- 512
minUdpSize :: Word16
minUdpSize :: Word16
minUdpSize = 512

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

#if __GLASGOW_HASKELL__ >= 800
-- | EDNS Option Code (RFC 6891).
newtype OptCode = OptCode {
    -- | From option code to number.
    OptCode -> Word16
fromOptCode :: Word16
  } deriving (OptCode -> OptCode -> Bool
(OptCode -> OptCode -> Bool)
-> (OptCode -> OptCode -> Bool) -> Eq OptCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OptCode -> OptCode -> Bool
$c/= :: OptCode -> OptCode -> Bool
== :: OptCode -> OptCode -> Bool
$c== :: OptCode -> OptCode -> Bool
Eq,Eq OptCode
Eq OptCode =>
(OptCode -> OptCode -> Ordering)
-> (OptCode -> OptCode -> Bool)
-> (OptCode -> OptCode -> Bool)
-> (OptCode -> OptCode -> Bool)
-> (OptCode -> OptCode -> Bool)
-> (OptCode -> OptCode -> OptCode)
-> (OptCode -> OptCode -> OptCode)
-> Ord OptCode
OptCode -> OptCode -> Bool
OptCode -> OptCode -> Ordering
OptCode -> OptCode -> OptCode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OptCode -> OptCode -> OptCode
$cmin :: OptCode -> OptCode -> OptCode
max :: OptCode -> OptCode -> OptCode
$cmax :: OptCode -> OptCode -> OptCode
>= :: OptCode -> OptCode -> Bool
$c>= :: OptCode -> OptCode -> Bool
> :: OptCode -> OptCode -> Bool
$c> :: OptCode -> OptCode -> Bool
<= :: OptCode -> OptCode -> Bool
$c<= :: OptCode -> OptCode -> Bool
< :: OptCode -> OptCode -> Bool
$c< :: OptCode -> OptCode -> Bool
compare :: OptCode -> OptCode -> Ordering
$ccompare :: OptCode -> OptCode -> Ordering
$cp1Ord :: Eq OptCode
Ord)

-- | NSID (RFC5001, section 2.3)
pattern NSID :: OptCode
pattern $bNSID :: OptCode
$mNSID :: forall r. OptCode -> (Void# -> r) -> (Void# -> r) -> r
NSID = OptCode 3

-- | DNSSEC algorithm support (RFC6974, section 3)
pattern DAU :: OptCode
pattern $bDAU :: OptCode
$mDAU :: forall r. OptCode -> (Void# -> r) -> (Void# -> r) -> r
DAU = OptCode 5
pattern DHU :: OptCode
pattern $bDHU :: OptCode
$mDHU :: forall r. OptCode -> (Void# -> r) -> (Void# -> r) -> r
DHU = OptCode 6
pattern N3U :: OptCode
pattern $bN3U :: OptCode
$mN3U :: forall r. OptCode -> (Void# -> r) -> (Void# -> r) -> r
N3U = OptCode 7

-- | Client subnet (RFC7871)
pattern ClientSubnet :: OptCode
pattern $bClientSubnet :: OptCode
$mClientSubnet :: forall r. OptCode -> (Void# -> r) -> (Void# -> r) -> r
ClientSubnet = OptCode 8

instance Show OptCode where
    show :: OptCode -> String
show NSID         = "NSID"
    show DAU          = "DAU"
    show DHU          = "DHU"
    show N3U          = "N3U"
    show ClientSubnet = "ClientSubnet"
    show x :: OptCode
x            = "OptCode" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word16 -> String
forall a. Show a => a -> String
show (Word16 -> String) -> Word16 -> String
forall a b. (a -> b) -> a -> b
$ OptCode -> Word16
fromOptCode OptCode
x)

-- | From number to option code.
toOptCode :: Word16 -> OptCode
toOptCode :: Word16 -> OptCode
toOptCode = Word16 -> OptCode
OptCode
#else
-- | Option Code (RFC 6891).
data OptCode = NSID                  -- ^ Name Server Identifier (RFC5001)
             | DAU                   -- ^ DNSSEC Algorithm understood (RFC6975)
             | DHU                   -- ^ DNSSEC Hash Understood (RFC6975)
             | N3U                   -- ^ NSEC3 Hash Understood (RFC6975)
             | ClientSubnet          -- ^ Client subnet (RFC7871)
             | UnknownOptCode Word16 -- ^ Unknown option code
    deriving (Eq, Ord, Show)

-- | From option code to number.
fromOptCode :: OptCode -> Word16
fromOptCode NSID         = 3
fromOptCode DAU          = 5
fromOptCode DHU          = 6
fromOptCode N3U          = 7
fromOptCode ClientSubnet = 8
fromOptCode (UnknownOptCode x) = x

-- | From number to option code.
toOptCode :: Word16 -> OptCode
toOptCode 3 = NSID
toOptCode 5 = DAU
toOptCode 6 = DHU
toOptCode 7 = N3U
toOptCode 8 = ClientSubnet
toOptCode x = UnknownOptCode x
#endif

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

-- | RData formats for a few EDNS options, and an opaque catchall
data OData =
      -- | Name Server Identifier (RFC5001).  Bidirectional, empty from client.
      -- (opaque octet-string).  May contain binary data, which MUST be empty
      -- in queries.
      OD_NSID ByteString
      -- | DNSSEC Algorithm Understood (RFC6975).  Client to server.
      -- (array of 8-bit numbers). Lists supported DNSKEY algorithms.
    | OD_DAU [Word8]
      -- | DS Hash Understood (RFC6975).  Client to server.
      -- (array of 8-bit numbers). Lists supported DS hash algorithms.
    | OD_DHU [Word8]
      -- | NSEC3 Hash Understood (RFC6975).  Client to server.
      -- (array of 8-bit numbers). Lists supported NSEC3 hash algorithms.
    | OD_N3U [Word8]
      -- | Client subnet (RFC7871).  Bidirectional.
      -- (source bits, scope bits, address).
      -- The address is masked and truncated when encoding queries.  The
      -- address is zero-padded when decoding.  Invalid input encodings
      -- result in an 'OD_ECSgeneric' value instead.
      --
    | OD_ClientSubnet Word8 Word8 IP
      -- | Unsupported or malformed IP client subnet option.  Bidirectional.
      -- (address family, source bits, scope bits, opaque address).
    | OD_ECSgeneric Word16 Word8 Word8 ByteString
      -- | Generic EDNS option.
      -- (numeric 'OptCode', opaque content)
    | UnknownOData Word16 ByteString
    deriving (OData -> OData -> Bool
(OData -> OData -> Bool) -> (OData -> OData -> Bool) -> Eq OData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OData -> OData -> Bool
$c/= :: OData -> OData -> Bool
== :: OData -> OData -> Bool
$c== :: OData -> OData -> Bool
Eq,Eq OData
Eq OData =>
(OData -> OData -> Ordering)
-> (OData -> OData -> Bool)
-> (OData -> OData -> Bool)
-> (OData -> OData -> Bool)
-> (OData -> OData -> Bool)
-> (OData -> OData -> OData)
-> (OData -> OData -> OData)
-> Ord OData
OData -> OData -> Bool
OData -> OData -> Ordering
OData -> OData -> OData
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OData -> OData -> OData
$cmin :: OData -> OData -> OData
max :: OData -> OData -> OData
$cmax :: OData -> OData -> OData
>= :: OData -> OData -> Bool
$c>= :: OData -> OData -> Bool
> :: OData -> OData -> Bool
$c> :: OData -> OData -> Bool
<= :: OData -> OData -> Bool
$c<= :: OData -> OData -> Bool
< :: OData -> OData -> Bool
$c< :: OData -> OData -> Bool
compare :: OData -> OData -> Ordering
$ccompare :: OData -> OData -> Ordering
$cp1Ord :: Eq OData
Ord)


-- | Recover the (often implicit) 'OptCode' from a value of the 'OData' sum
-- type.
_odataToOptCode :: OData -> OptCode
_odataToOptCode :: OData -> OptCode
_odataToOptCode OD_NSID {}            = OptCode
NSID
_odataToOptCode OD_DAU {}             = OptCode
DAU
_odataToOptCode OD_DHU {}             = OptCode
DHU
_odataToOptCode OD_N3U {}             = OptCode
N3U
_odataToOptCode OD_ClientSubnet {}    = OptCode
ClientSubnet
_odataToOptCode OD_ECSgeneric {}      = OptCode
ClientSubnet
_odataToOptCode (UnknownOData code :: Word16
code _) = Word16 -> OptCode
toOptCode Word16
code

instance Show OData where
    show :: OData -> String
show (OD_NSID nsid :: Domain
nsid) = Domain -> String
_showNSID Domain
nsid
    show (OD_DAU as :: [Word8]
as)    = String -> [Word8] -> String
_showAlgList "DAU" [Word8]
as
    show (OD_DHU hs :: [Word8]
hs)    = String -> [Word8] -> String
_showAlgList "DHU" [Word8]
hs
    show (OD_N3U hs :: [Word8]
hs)    = String -> [Word8] -> String
_showAlgList "N3U" [Word8]
hs
    show (OD_ClientSubnet b1 :: Word8
b1 b2 :: Word8
b2 ip :: IP
ip@(IPv4 _)) = Word16 -> Word8 -> Word8 -> ShowS
_showECS 1 Word8
b1 Word8
b2 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ IP -> String
forall a. Show a => a -> String
show IP
ip
    show (OD_ClientSubnet b1 :: Word8
b1 b2 :: Word8
b2 ip :: IP
ip@(IPv6 _)) = Word16 -> Word8 -> Word8 -> ShowS
_showECS 2 Word8
b1 Word8
b2 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ IP -> String
forall a. Show a => a -> String
show IP
ip
    show (OD_ECSgeneric fam :: Word16
fam b1 :: Word8
b1 b2 :: Word8
b2 a :: Domain
a) = Word16 -> Word8 -> Word8 -> ShowS
_showECS Word16
fam Word8
b1 Word8
b2 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Domain -> String
_b16encode Domain
a
    show (UnknownOData code :: Word16
code bs :: Domain
bs) =
        "UnknownOData " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
code String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
_b16encode Domain
bs

_showAlgList :: String -> [Word8] -> String
_showAlgList :: String -> [Word8] -> String
_showAlgList nm :: String
nm ws :: [Word8]
ws = String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "," ((Word8 -> String) -> [Word8] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> String
forall a. Show a => a -> String
show [Word8]
ws)

_showNSID :: ByteString -> String
_showNSID :: Domain -> String
_showNSID nsid :: Domain
nsid = "NSID" String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
_b16encode Domain
nsid String -> ShowS
forall a. [a] -> [a] -> [a]
++ ";" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Domain -> String
printable Domain
nsid
  where
    printable :: Domain -> String
printable = Domain -> String
BS.unpack(Domain -> String) -> (Domain -> Domain) -> Domain -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> Domain -> Domain
BS.map (\c :: Char
c -> if Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< ' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
> '~' then '?' else Char
c)

_showECS :: Word16 -> Word8 -> Word8 -> String -> String
_showECS :: Word16 -> Word8 -> Word8 -> ShowS
_showECS family :: Word16
family srcBits :: Word8
srcBits scpBits :: Word8
scpBits address :: String
address =
    Word16 -> String
forall a. Show a => a -> String
show Word16
family String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
srcBits
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
scpBits String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
address