{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}

-- | Data types for DNS Query and Response.
--   For more information, see <http://www.ietf.org/rfc/rfc1035>.

module Network.DNS.Types (
  -- * Resource Records
    ResourceRecord (..)
  -- ** Types
  , Domain
  , CLASS
  , classIN
  , TTL
  -- ** Resource Record Types
  , TYPE (
    A
  , NS
  , CNAME
  , SOA
  , NULL
  , PTR
  , MX
  , TXT
  , AAAA
  , SRV
  , DNAME
  , OPT
  , DS
  , RRSIG
  , NSEC
  , DNSKEY
  , NSEC3
  , NSEC3PARAM
  , TLSA
  , CDS
  , CDNSKEY
  , CSYNC
  , ANY
  )
  , fromTYPE
  , toTYPE
  -- ** Resource Data
  , RData (..)
  -- * DNS Message
  , DNSMessage (..)
  , defaultQuery
  , defaultResponse
  , DNSFormat
  -- ** DNS Header
  , DNSHeader (..)
  , Identifier
  , QorR (..)
  , DNSFlags (..)
  , OPCODE (..)
  , RCODE (
    NoErr
  , FormatErr
  , ServFail
  , NameErr
  , NotImpl
  , Refused
  , YXDomain
  , YXRRSet
  , NXRRSet
  , NotAuth
  , NotZone
  , BadOpt
  )
  , fromRCODE
  , toRCODE
  , fromRCODEforHeader
  , toRCODEforHeader
  -- ** DNS Body
  , Question (..)
  -- * DNS Error
  , DNSError (..)
  -- * EDNS0
  , EDNS0
  , defaultEDNS0
  -- ** Accessors
  , udpSize
  , extRCODE
  , dnssecOk
  , options
  -- ** Converters
  , fromEDNS0
  , toEDNS0
  -- * EDNS0 option data
  , OData (..)
  , OptCode (
    ClientSubnet
  )
  , fromOptCode
  , toOptCode
  -- * Other types
  , Mailbox
  ) where

import Control.Exception (Exception, IOException)
import Data.Bits ((.&.), (.|.), shiftR, shiftL, testBit, setBit)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as B64 (encode)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Builder as L
import qualified Data.ByteString.Lazy as L
import Data.IP (IP, IPv4, IPv6)
import Data.Typeable (Typeable)
import Data.Word (Word8, Word16, Word32)

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

-- | Type for domain.
type Domain = ByteString

-- | Type for a mailbox encoded on the wire as a DNS name, but the first label
-- is conceptually the user name, and sometimes has internal '.' characters
-- that are not label separators.
type Mailbox = ByteString

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

#if __GLASGOW_HASKELL__ >= 800
-- | Types for resource records.
newtype TYPE = TYPE {
    -- | From type to number.
    fromTYPE :: Word16
  } deriving (Eq, Ord)

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

-- | IPv4 address
pattern A :: TYPE
pattern A          = TYPE   1
-- | An authoritative name serve
pattern NS :: TYPE
pattern NS         = TYPE   2
-- | The canonical name for an alias
pattern CNAME :: TYPE
pattern CNAME      = TYPE   5
-- | Marks the start of a zone of authority
pattern SOA :: TYPE
pattern SOA        = TYPE   6
-- | A null RR (EXPERIMENTAL)
pattern NULL :: TYPE
pattern NULL       = TYPE  10
-- | A domain name pointer
pattern PTR :: TYPE
pattern PTR        = TYPE  12
-- | Mail exchange
pattern MX :: TYPE
pattern MX         = TYPE  15
-- | Text strings
pattern TXT :: TYPE
pattern TXT        = TYPE  16
-- | IPv6 Address
pattern AAAA :: TYPE
pattern AAAA       = TYPE  28
-- | Server Selection (RFC2782)
pattern SRV :: TYPE
pattern SRV        = TYPE  33
-- | DNAME (RFC6672)
pattern DNAME :: TYPE
pattern DNAME      = TYPE  39 -- RFC 6672
-- | OPT (RFC6891)
pattern OPT :: TYPE
pattern OPT        = TYPE  41 -- RFC 6891
-- | Delegation Signer (RFC4034)
pattern DS :: TYPE
pattern DS         = TYPE  43 -- RFC 4034
-- | RRSIG (RFC4034)
pattern RRSIG :: TYPE
pattern RRSIG      = TYPE  46 -- RFC 4034
-- | NSEC (RFC4034)
pattern NSEC :: TYPE
pattern NSEC       = TYPE  47 -- RFC 4034
-- | DNSKEY (RFC4034)
pattern DNSKEY :: TYPE
pattern DNSKEY     = TYPE  48 -- RFC 4034
-- | NSEC3 (RFC5155)
pattern NSEC3 :: TYPE
pattern NSEC3      = TYPE  50 -- RFC 5155
-- | NSEC3PARAM (RFC5155)
pattern NSEC3PARAM :: TYPE
pattern NSEC3PARAM = TYPE  51 -- RFC 5155
-- | TLSA (RFC6698)
pattern TLSA :: TYPE
pattern TLSA       = TYPE  52 -- RFC 6698
-- | Child DS (RFC7344)
pattern CDS :: TYPE
pattern CDS        = TYPE  59 -- RFC 7344
-- | DNSKEY(s) the Child wants reflected in DS (RFC7344)
pattern CDNSKEY :: TYPE
pattern CDNSKEY    = TYPE  60 -- RFC 7344
-- | Child-To-Parent Synchronization (RFC7477)
pattern CSYNC :: TYPE
pattern CSYNC      = TYPE  62 -- RFC 7477
-- | A request for all records the server/cache has available
pattern ANY :: TYPE
pattern ANY        = TYPE 255

instance Show TYPE where
    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 ANY        = "ANY"
    show x          = "TYPE " ++ (show $ fromTYPE x)

-- | From number to type.
toTYPE :: Word16 -> TYPE
toTYPE = 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)
          | ANY        -- ^ A request for all records the server/cache
                       --   has available
          | UnknownTYPE Word16  -- ^ Unknown type
          deriving (Eq, Ord, Show, 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 ANY        = 255
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 255 = ANY
toTYPE x   = UnknownTYPE x
#endif

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

-- | 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 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 detected a malformed OPT RR.
  | BadOptRecord
    -- | Configuration is wrong.
  | BadConfiguration
    -- | Network failure.
  | NetworkFailure IOException
    -- | Error is unknown
  | UnknownDNSError
  deriving (Eq, Show, Typeable)

instance Exception DNSError

-- | Raw data format for DNS Query and Response.
data DNSMessage = DNSMessage {
    header     :: DNSHeader        -- ^ Header
  , question   :: [Question]       -- ^ The question for the name server
  , answer     :: [ResourceRecord] -- ^ RRs answering the question
  , authority  :: [ResourceRecord] -- ^ RRs pointing toward an authority
  , additional :: [ResourceRecord] -- ^ RRs holding additional information
  } deriving (Eq, Show)

{-# DEPRECATED DNSFormat "Use DNSMessage instead" #-}
-- | For backward compatibility.
type DNSFormat = DNSMessage

-- | 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 {
    identifier :: Identifier -- ^ An identifier.
  , flags      :: DNSFlags   -- ^ The second 16bit word.
  } deriving (Eq, Show)

-- | Raw data format for the flags of DNS Query and Response.
data DNSFlags = DNSFlags {
    qOrR         :: QorR   -- ^ Query or response.
  , opcode       :: OPCODE -- ^ Kind of query.
  , authAnswer   :: Bool   -- ^ Authoritative Answer - this bit is valid in responses,
                           -- and specifies that the responding name server is an
                           -- authority for the domain name in question section.
  , trunCation   :: Bool   -- ^ TrunCation - specifies that this message was truncated
                           -- due to length greater than that permitted on the
                           -- transmission channel.
  , recDesired   :: Bool   -- ^ Recursion Desired - 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.
  , recAvailable :: Bool   -- ^ Recursion Available - this be is set or cleared in a
                           -- response, and denotes whether recursive query support is
                           -- available in the name server.

  , rcode        :: RCODE  -- ^ Response code.
  , authenData   :: Bool   -- ^ Authentic Data (RFC4035).
  } deriving (Eq, Show)

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

-- | Query or response.
data QorR = QR_Query    -- ^ Query.
          | QR_Response -- ^ Response.
          deriving (Eq, Show, Enum, Bounded)

-- | Kind of query.
data OPCODE
  = OP_STD -- ^ A standard query.
  | OP_INV -- ^ An inverse query.
  | OP_SSR -- ^ A server status request.
  deriving (Eq, Show, Enum, Bounded)

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

#if __GLASGOW_HASKELL__ >= 800
-- | Response code including EDNS0's 12bit ones.
newtype RCODE = RCODE {
    -- | From rcode to number.
    fromRCODE :: Word16
  } deriving (Eq)

-- | Provide an Enum instance for backwards compatibility
instance Enum RCODE where
    fromEnum = fromIntegral . fromRCODE
    toEnum = RCODE . fromIntegral

-- | No error condition.
pattern NoErr     :: RCODE
pattern NoErr      = RCODE  0
-- | Format error - The name server was
--   unable to interpret the query.
pattern FormatErr :: RCODE
pattern 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 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 NameErr    = RCODE  3
-- | Not Implemented - The name server does
--   not support the requested kind of query.
pattern NotImpl   :: RCODE
pattern 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 Refused    = RCODE  5
-- | YXDomain - Dynamic update response, a pre-requisite domain that should not
-- exist, does exist.
pattern YXDomain :: RCODE
pattern YXDomain  = RCODE 6
-- | YXRRSet - Dynamic update response, a pre-requisite RRSet that should not
-- exist, does exist.
pattern YXRRSet  :: RCODE
pattern YXRRSet   = RCODE 7
-- | NXRRSet - Dynamic update response, a pre-requisite RRSet that should
-- exist, does not exist.
pattern NXRRSet  :: RCODE
pattern NXRRSet   = RCODE 8
-- | NotAuth - Dynamic update response, the server is not authoritative for the
-- zone named in the Zone Section.
pattern NotAuth  :: RCODE
pattern 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 NotZone   = RCODE 10
-- | Bad OPT Version (RFC 6891) or TSIG Signature Failure (RFC2845).
pattern BadOpt    :: RCODE
pattern BadOpt     = RCODE 16

-- | Use https://tools.ietf.org/html/rfc2929#section-2.3 names for DNS RCODEs
instance Show RCODE where
    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 BadOpt    = "BADVERS"
    show x         = "RCODE " ++ (show $ fromRCODE x)

-- | From number to rcode.
toRCODE :: Word16 -> RCODE
toRCODE = RCODE

-- | From rcode to number for header (4bits only).
fromRCODEforHeader :: RCODE -> Word16
fromRCODEforHeader (RCODE w) = w .&. 0x0f

-- | From number in header to rcode (4bits only).
toRCODEforHeader :: Word16 -> RCODE
toRCODEforHeader w = RCODE (w .&. 0x0f)
#else
-- | Response code.
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.
  | BadOpt    -- ^ Bad OPT Version (RFC 6891) or TSIG Signature
              --   Failure (RFC2845).
  | UnknownRCODE Word16
  deriving (Eq, Ord, Show)

-- | From rcode to number.
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 BadOpt    = 16
fromRCODE (UnknownRCODE x) = x

-- | From number to rcode.
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 = BadOpt
toRCODE  x = UnknownRCODE x

-- | From rcode to number for header (4bits only).
fromRCODEforHeader :: RCODE -> Word16
fromRCODEforHeader rc = fromRCODE rc .&. 0x0f

-- | From number in header to rcode (4bits only).
toRCODEforHeader :: Word16 -> RCODE
toRCODEforHeader w = toRCODE (w .&. 0x0f)
#endif

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

-- | Raw data format for DNS questions.
data Question = Question {
    qname  :: Domain -- ^ A domain name
  , qtype  :: TYPE   -- ^ The type of the query
  } deriving (Eq, Show)

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

-- | Resource record class.
type CLASS = Word16

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

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

-- | Raw data format for resource records.
data ResourceRecord = ResourceRecord {
    rrname  :: Domain -- ^ Name
  , rrtype  :: TYPE   -- ^ Resource record type
  , rrclass :: CLASS  -- ^ Resource record class
  , rrttl   :: TTL    -- ^ Time to live
  , rdata   :: RData  -- ^ Resource data
  } deriving (Eq,Show)

-- | 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             -- ^ A null RR (EXPERIMENTAL).
                                 -- Anything can be in a NULL record,
                                 -- for now we just drop this data.
           | 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_NSEC
           | RD_DNSKEY Word16 Word8 Word8 ByteString
                                 -- ^ DNSKEY (RFC4034)
           --RD_NSEC3
           --RD_NSEC3PARAM
           | RD_TLSA Word8 Word8 Word8 ByteString
                                 -- ^ TLSA (RFC6698)
           --RD_CDS
           --RD_CDNSKEY
           --RD_CSYNC
           | UnknownRData ByteString   -- ^ Unknown resource data
    deriving (Eq, Ord)

instance Show RData where
  show (RD_NS dom) = BS.unpack dom
  show (RD_MX prf dom) = show prf ++ " " ++ BS.unpack dom
  show (RD_CNAME dom) = BS.unpack dom
  show (RD_DNAME dom) = BS.unpack dom
  show (RD_A a) = show a
  show (RD_AAAA aaaa) = show aaaa
  show (RD_TXT txt) = BS.unpack txt
  show (RD_SOA mn mr serial refresh retry expire mi) = BS.unpack mn ++ " " ++ BS.unpack mr ++ " " ++
                                                       show serial ++ " " ++ show refresh ++ " " ++
                                                       show retry ++ " " ++ show expire ++ " " ++ show mi
  show (RD_PTR dom) = BS.unpack dom
  show (RD_SRV pri wei prt dom) = show pri ++ " " ++ show wei ++ " " ++ show prt ++ BS.unpack dom
  show (RD_OPT od) = show od
  show (UnknownRData is) = show is
  show (RD_TLSA use sel mtype dgst) = show use ++ " " ++ show sel ++ " " ++ show mtype ++ " " ++ hexencode dgst
  show (RD_DS t a dt dv) = show t ++ " " ++ show a ++ " " ++ show dt ++ " " ++ hexencode dv
  show RD_NULL = "NULL"
  show (RD_DNSKEY f p a k) = show f ++ " " ++ show p ++ " " ++ show a ++ " " ++ b64encode k

hexencode :: ByteString -> String
hexencode = BS.unpack . L.toStrict . L.toLazyByteString . L.byteStringHex

b64encode :: ByteString -> String
b64encode = BS.unpack . B64.encode

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

-- | Default query.
defaultQuery :: DNSMessage
defaultQuery = DNSMessage {
    header = DNSHeader {
       identifier = 0
     , flags = DNSFlags {
           qOrR         = QR_Query
         , opcode       = OP_STD
         , authAnswer   = False
         , trunCation   = False
         , recDesired   = True
         , recAvailable = False
         , rcode        = NoErr
         , authenData   = False
         }
     }
  , question   = []
  , answer     = []
  , authority  = []
  , additional = []
  }

-- | Default response.
defaultResponse :: DNSMessage
defaultResponse =
  let hd = header defaultQuery
      flg = flags hd
  in  defaultQuery {
        header = hd {
          flags = flg {
              qOrR = QR_Response
            , authAnswer = True
            , recAvailable = True
            , authenData = False
            }
        }
      }

----------------------------------------------------------------
-- EDNS0 (RFC 6891)
----------------------------------------------------------------

-- | EDNS0 infromation defined in RFC 6891.
data EDNS0 = EDNS0 {
    -- | UDP payload size.
    udpSize  :: Word16
    -- | Extended RCODE.
  , extRCODE :: RCODE
    -- | Is DNSSEC OK?
  , dnssecOk :: Bool
    -- | EDNS0 option data.
  , options  :: [OData]
  } deriving (Eq, Show)

#if __GLASGOW_HASKELL__ >= 800
-- | Default information for EDNS0.
--
-- >>> defaultEDNS0
-- EDNS0 {udpSize = 4096, extRCODE = NoError, dnssecOk = False, options = []}
#else
-- | Default information for EDNS0.
--
-- >>> defaultEDNS0
-- EDNS0 {udpSize = 4096, extRCODE = NoErr, dnssecOk = False, options = []}
#endif
defaultEDNS0 :: EDNS0
defaultEDNS0 = EDNS0 4096 NoErr False []

-- | Generating a resource record for the additional section based on EDNS0.
-- 'DNSFlags' is not generated.
-- Just set the same 'RCODE' to 'DNSFlags'.
fromEDNS0 :: EDNS0 -> ResourceRecord
fromEDNS0 edns = ResourceRecord name' type' class' ttl' rdata'
  where
    name'  = "."
    type'  = OPT
    class' = udpSize edns
    ttl0'   = fromIntegral (fromRCODE (extRCODE edns) .&. 0x0ff0) `shiftL` 20
    ttl'
      | dnssecOk edns = ttl0' `setBit` 15
      | otherwise     = ttl0'
    rdata' = RD_OPT $ options edns

-- | Generating EDNS0 information from the OPT RR.
toEDNS0 :: DNSFlags -> ResourceRecord -> Maybe EDNS0
toEDNS0 flgs (ResourceRecord "." OPT udpsiz ttl' (RD_OPT opts)) =
    Just $ EDNS0 udpsiz (toRCODE erc) secok opts
  where
    lp = fromRCODEforHeader $ rcode flgs
    up = shiftR (ttl' .&. 0xff000000) 20
    erc = fromIntegral up .|. lp
    secok = ttl' `testBit` 15
toEDNS0 _ _ = Nothing

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

#if __GLASGOW_HASKELL__ >= 800
-- | EDNS0 Option Code (RFC 6891).
newtype OptCode = OptCode {
    -- | From option code to number.
    fromOptCode :: Word16
  } deriving (Eq,Ord)

-- | Client subnet (RFC7871)
pattern ClientSubnet :: OptCode
pattern ClientSubnet = OptCode 8

instance Show OptCode where
    show ClientSubnet = "ClientSubnet"
    show x            = "OptCode " ++ (show $ fromOptCode x)

-- | From number to option code.
toOptCode :: Word16 -> OptCode
toOptCode = OptCode
#else
-- | Option Code (RFC 6891).
data OptCode = ClientSubnet          -- ^ Client subnet (RFC7871)
             | UnknownOptCode Word16 -- ^ Unknown option code
    deriving (Eq, Ord, Show)

-- | From option code to number.
fromOptCode :: OptCode -> Word16
fromOptCode ClientSubnet = 8
fromOptCode (UnknownOptCode x) = x

-- | From number to option code.
toOptCode :: Word16 -> OptCode
toOptCode 8 = ClientSubnet
toOptCode x = UnknownOptCode x
#endif

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

-- | Optional resource data.
data OData = OD_ClientSubnet Word8 Word8 IP   -- ^ Client subnet (RFC7871)
           | UnknownOData OptCode ByteString  -- ^ Unknown optional type
    deriving (Eq,Show,Ord)