{-# LANGUAGE BangPatterns, LambdaCase, OverloadedStrings #-}

module Network.DNS.Decode.Parsers (
    getResponse
  , getDNSFlags
  , getHeader
  , getResourceRecord
  , getResourceRecords
  , getDomain
  , getMailbox
  ) where

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BS
import qualified Data.CaseInsensitive as CI
import qualified Data.IP
import Data.IP (IP(..), toIPv4, toIPv6b, makeAddrRange)

import Network.DNS.Imports
import Network.DNS.StateBinary
import Network.DNS.Types.Internal

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

getResponse :: SGet DNSMessage
getResponse :: SGet DNSMessage
getResponse = do
    hm <- SGet DNSHeader
getHeader
    qdCount <- getInt16
    anCount <- getInt16
    nsCount <- getInt16
    arCount <- getInt16
    queries <- getQueries qdCount
    answers <- getResourceRecords anCount
    authrrs <- getResourceRecords nsCount
    addnrrs <- getResourceRecords arCount
    let (opts, rest) = partition ((==) OPT. rrtype) addnrrs
        flgs         = DNSHeader -> DNSFlags
flags DNSHeader
hm
        rc           = RCODE -> Word16
fromRCODE (RCODE -> Word16) -> RCODE -> Word16
forall a b. (a -> b) -> a -> b
$ DNSFlags -> RCODE
rcode DNSFlags
flgs
        (eh, erc)    = getEDNS rc opts
        hd           = DNSHeader
hm { flags = flgs { rcode = erc } }
    pure $ DNSMessage hd eh queries answers authrrs $ ifEDNS eh rest addnrrs

  where

    -- | Get EDNS pseudo-header and the high eight bits of the extended RCODE.
    --
    getEDNS :: Word16 -> AdditionalRecords -> (EDNSheader, RCODE)
    getEDNS :: Word16 -> [ResourceRecord] -> (EDNSheader, RCODE)
getEDNS Word16
rc [ResourceRecord]
rrs = case [ResourceRecord]
rrs of
        [ResourceRecord
rr] | Just (EDNS
edns, Word16
erc) <- ResourceRecord -> Maybe (EDNS, Word16)
optEDNS ResourceRecord
rr
               -> (EDNS -> EDNSheader
EDNSheader EDNS
edns, Word16 -> RCODE
toRCODE Word16
erc)
        []     -> (EDNSheader
NoEDNS, Word16 -> RCODE
toRCODE Word16
rc)
        [ResourceRecord]
_      -> (EDNSheader
InvalidEDNS, RCODE
BadRCODE)

      where

        -- | Extract EDNS information from an OPT RR.
        --
        optEDNS :: ResourceRecord -> Maybe (EDNS, Word16)
        optEDNS :: ResourceRecord -> Maybe (EDNS, Word16)
optEDNS (ResourceRecord ByteString
"." TYPE
OPT Word16
udpsiz TTL
ttl' (RD_OPT [OData]
opts)) =
            let hrc :: TTL
hrc      = Word16 -> TTL
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
rc TTL -> TTL -> TTL
forall a. Bits a => a -> a -> a
.&. TTL
0x0f
                erc :: TTL
erc      = TTL -> Int -> TTL
forall a. Bits a => a -> Int -> a
shiftR (TTL
ttl' TTL -> TTL -> TTL
forall a. Bits a => a -> a -> a
.&. TTL
0xff000000) Int
20 TTL -> TTL -> TTL
forall a. Bits a => a -> a -> a
.|. TTL
hrc
                secok :: Bool
secok    = TTL
ttl' TTL -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
15
                vers :: Word8
vers     = TTL -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TTL -> Word8) -> TTL -> Word8
forall a b. (a -> b) -> a -> b
$ TTL -> Int -> TTL
forall a. Bits a => a -> Int -> a
shiftR (TTL
ttl' TTL -> TTL -> TTL
forall a. Bits a => a -> a -> a
.&. TTL
0x00ff0000) Int
16
             in (EDNS, Word16) -> Maybe (EDNS, Word16)
forall a. a -> Maybe a
Just (Word8 -> Word16 -> Bool -> [OData] -> EDNS
EDNS Word8
vers Word16
udpsiz Bool
secok [OData]
opts, TTL -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral TTL
erc)
        optEDNS ResourceRecord
_ = Maybe (EDNS, Word16)
forall a. Maybe a
Nothing

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

getDNSFlags :: SGet DNSFlags
getDNSFlags :: SGet DNSFlags
getDNSFlags = do
    flgs <- SGet Word16
get16
    oc <- getOpcode flgs
    return $ DNSFlags (getQorR flgs)
                      oc
                      (getAuthAnswer flgs)
                      (getTrunCation flgs)
                      (getRecDesired flgs)
                      (getRecAvailable flgs)
                      (getRcode flgs)
                      (getAuthenData flgs)
                      (getChkDisable flgs)
  where
    getQorR :: a -> QorR
getQorR a
w = if a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
15 then QorR
QR_Response else QorR
QR_Query
    getOpcode :: Word16 -> StateT PState (Parser ByteString) OPCODE
getOpcode Word16
w =
        case Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR Word16
w Int
11 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x0f of
            Word16
n | Just OPCODE
opc <- Word16 -> Maybe OPCODE
toOPCODE Word16
n
              -> OPCODE -> StateT PState (Parser ByteString) OPCODE
forall a. a -> StateT PState (Parser ByteString) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OPCODE
opc
              | Bool
otherwise
              -> String -> StateT PState (Parser ByteString) OPCODE
forall a. String -> SGet a
failSGet (String -> StateT PState (Parser ByteString) OPCODE)
-> String -> StateT PState (Parser ByteString) OPCODE
forall a b. (a -> b) -> a -> b
$ String
"Unsupported header opcode: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
n
    getAuthAnswer :: a -> Bool
getAuthAnswer a
w = a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
10
    getTrunCation :: a -> Bool
getTrunCation a
w = a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
9
    getRecDesired :: a -> Bool
getRecDesired a
w = a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
8
    getRecAvailable :: a -> Bool
getRecAvailable a
w = a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
7
    getRcode :: Word16 -> RCODE
getRcode Word16
w = Word16 -> RCODE
toRCODE (Word16 -> RCODE) -> Word16 -> RCODE
forall a b. (a -> b) -> a -> b
$ Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x0f
    getAuthenData :: a -> Bool
getAuthenData a
w = a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
5
    getChkDisable :: a -> Bool
getChkDisable a
w = a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
4

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

getHeader :: SGet DNSHeader
getHeader :: SGet DNSHeader
getHeader =
    Word16 -> DNSFlags -> DNSHeader
DNSHeader (Word16 -> DNSFlags -> DNSHeader)
-> SGet Word16
-> StateT PState (Parser ByteString) (DNSFlags -> DNSHeader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word16
decodeIdentifier StateT PState (Parser ByteString) (DNSFlags -> DNSHeader)
-> SGet DNSFlags -> SGet DNSHeader
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SGet DNSFlags
getDNSFlags
  where
    decodeIdentifier :: SGet Word16
decodeIdentifier = SGet Word16
get16

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

getQueries :: Int -> SGet [Question]
getQueries :: Int -> SGet [Question]
getQueries Int
n = Int
-> StateT PState (Parser ByteString) Question -> SGet [Question]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n StateT PState (Parser ByteString) Question
getQuery

getTYPE :: SGet TYPE
getTYPE :: SGet TYPE
getTYPE = Word16 -> TYPE
toTYPE (Word16 -> TYPE) -> SGet Word16 -> SGet TYPE
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word16
get16

-- XXX: Include the class when implemented, or otherwise perhaps check the
-- implicit assumption that the class is classIN.
--
getQuery :: SGet Question
getQuery :: StateT PState (Parser ByteString) Question
getQuery = ByteString -> TYPE -> Question
Question (ByteString -> TYPE -> Question)
-> StateT PState (Parser ByteString) ByteString
-> StateT PState (Parser ByteString) (TYPE -> Question)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PState (Parser ByteString) ByteString
getDomain
                    StateT PState (Parser ByteString) (TYPE -> Question)
-> SGet TYPE -> StateT PState (Parser ByteString) Question
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SGet TYPE
getTYPE
                    StateT PState (Parser ByteString) Question
-> SGet Word16 -> StateT PState (Parser ByteString) Question
forall a b.
StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
-> StateT PState (Parser ByteString) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  SGet Word16
ignoreClass
  where
    ignoreClass :: SGet Word16
ignoreClass = SGet Word16
get16

getResourceRecords :: Int -> SGet [ResourceRecord]
getResourceRecords :: Int -> SGet [ResourceRecord]
getResourceRecords Int
n = Int
-> StateT PState (Parser ByteString) ResourceRecord
-> SGet [ResourceRecord]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n StateT PState (Parser ByteString) ResourceRecord
getResourceRecord

getResourceRecord :: SGet ResourceRecord
getResourceRecord :: StateT PState (Parser ByteString) ResourceRecord
getResourceRecord = do
    dom <- StateT PState (Parser ByteString) ByteString
getDomain
    typ <- getTYPE
    cls <- get16
    ttl <- get32
    len <- getInt16
    dat <- fitSGet len $ getRData typ len
    return $ ResourceRecord dom typ cls ttl dat

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

-- | Helper to find position of RData end, that is, the offset of the first
-- byte /after/ the current RData.
--
rdataEnd :: Int      -- ^ number of bytes left from current position
         -> SGet Int -- ^ end position
rdataEnd :: Int -> SGet Int
rdataEnd !Int
len = Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
len (Int -> Int) -> SGet Int -> SGet Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Int
getPosition

getRData :: TYPE -> Int -> SGet RData
getRData :: TYPE -> Int -> SGet RData
getRData TYPE
NS Int
_    = ByteString -> RData
RD_NS    (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PState (Parser ByteString) ByteString
getDomain
getRData TYPE
MX Int
_    = Word16 -> ByteString -> RData
RD_MX    (Word16 -> ByteString -> RData)
-> SGet Word16
-> StateT PState (Parser ByteString) (ByteString -> RData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word16
get16 StateT PState (Parser ByteString) (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) ByteString
getDomain
getRData TYPE
CNAME Int
_ = ByteString -> RData
RD_CNAME (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PState (Parser ByteString) ByteString
getDomain
getRData TYPE
DNAME Int
_ = ByteString -> RData
RD_DNAME (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PState (Parser ByteString) ByteString
getDomain
getRData TYPE
TXT Int
len = ByteString -> RData
RD_TXT   (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) ByteString
getTXT Int
len
getRData TYPE
A Int
_     = IPv4 -> RData
RD_A (IPv4 -> RData) -> ([Int] -> IPv4) -> [Int] -> RData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IPv4
toIPv4 ([Int] -> RData)
-> StateT PState (Parser ByteString) [Int] -> SGet RData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) [Int]
getNBytes Int
4
getRData TYPE
AAAA Int
_  = IPv6 -> RData
RD_AAAA (IPv6 -> RData) -> ([Int] -> IPv6) -> [Int] -> RData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IPv6
toIPv6b ([Int] -> RData)
-> StateT PState (Parser ByteString) [Int] -> SGet RData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) [Int]
getNBytes Int
16
getRData TYPE
SOA Int
_   = ByteString
-> ByteString -> TTL -> TTL -> TTL -> TTL -> TTL -> RData
RD_SOA  (ByteString
 -> ByteString -> TTL -> TTL -> TTL -> TTL -> TTL -> RData)
-> StateT PState (Parser ByteString) ByteString
-> StateT
     PState
     (Parser ByteString)
     (ByteString -> TTL -> TTL -> TTL -> TTL -> TTL -> RData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PState (Parser ByteString) ByteString
getDomain
                           StateT
  PState
  (Parser ByteString)
  (ByteString -> TTL -> TTL -> TTL -> TTL -> TTL -> RData)
-> StateT PState (Parser ByteString) ByteString
-> StateT
     PState
     (Parser ByteString)
     (TTL -> TTL -> TTL -> TTL -> TTL -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) ByteString
getMailbox
                           StateT
  PState
  (Parser ByteString)
  (TTL -> TTL -> TTL -> TTL -> TTL -> RData)
-> SGet TTL
-> StateT
     PState (Parser ByteString) (TTL -> TTL -> TTL -> TTL -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SGet TTL
decodeSerial
                           StateT
  PState (Parser ByteString) (TTL -> TTL -> TTL -> TTL -> RData)
-> SGet TTL
-> StateT PState (Parser ByteString) (TTL -> TTL -> TTL -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SGet TTL
decodeRefesh
                           StateT PState (Parser ByteString) (TTL -> TTL -> TTL -> RData)
-> SGet TTL
-> StateT PState (Parser ByteString) (TTL -> TTL -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SGet TTL
decodeRetry
                           StateT PState (Parser ByteString) (TTL -> TTL -> RData)
-> SGet TTL -> StateT PState (Parser ByteString) (TTL -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SGet TTL
decodeExpire
                           StateT PState (Parser ByteString) (TTL -> RData)
-> SGet TTL -> SGet RData
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SGet TTL
decodeMinimum
  where
    decodeSerial :: SGet TTL
decodeSerial  = SGet TTL
get32
    decodeRefesh :: SGet TTL
decodeRefesh  = SGet TTL
get32
    decodeRetry :: SGet TTL
decodeRetry   = SGet TTL
get32
    decodeExpire :: SGet TTL
decodeExpire  = SGet TTL
get32
    decodeMinimum :: SGet TTL
decodeMinimum = SGet TTL
get32
getRData TYPE
PTR Int
_ = ByteString -> RData
RD_PTR (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PState (Parser ByteString) ByteString
getDomain
getRData TYPE
SRV Int
_ = Word16 -> Word16 -> Word16 -> ByteString -> RData
RD_SRV (Word16 -> Word16 -> Word16 -> ByteString -> RData)
-> SGet Word16
-> StateT
     PState
     (Parser ByteString)
     (Word16 -> Word16 -> ByteString -> RData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word16
decodePriority
                        StateT
  PState
  (Parser ByteString)
  (Word16 -> Word16 -> ByteString -> RData)
-> SGet Word16
-> StateT
     PState (Parser ByteString) (Word16 -> ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SGet Word16
decodeWeight
                        StateT PState (Parser ByteString) (Word16 -> ByteString -> RData)
-> SGet Word16
-> StateT PState (Parser ByteString) (ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SGet Word16
decodePort
                        StateT PState (Parser ByteString) (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) ByteString
getDomain
  where
    decodePriority :: SGet Word16
decodePriority = SGet Word16
get16
    decodeWeight :: SGet Word16
decodeWeight   = SGet Word16
get16
    decodePort :: SGet Word16
decodePort     = SGet Word16
get16
--
getRData TYPE
RP Int
_   = ByteString -> ByteString -> RData
RD_RP (ByteString -> ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString
-> StateT PState (Parser ByteString) (ByteString -> RData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PState (Parser ByteString) ByteString
getMailbox
                        StateT PState (Parser ByteString) (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) ByteString
getDomain
--
getRData TYPE
OPT Int
len   = [OData] -> RData
RD_OPT ([OData] -> RData)
-> StateT PState (Parser ByteString) [OData] -> SGet RData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) [OData]
getOpts Int
len
--
getRData TYPE
TLSA Int
len = Word8 -> Word8 -> Word8 -> ByteString -> RData
RD_TLSA (Word8 -> Word8 -> Word8 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT
     PState (Parser ByteString) (Word8 -> Word8 -> ByteString -> RData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PState (Parser ByteString) Word8
decodeUsage
                            StateT
  PState (Parser ByteString) (Word8 -> Word8 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT PState (Parser ByteString) (Word8 -> ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) Word8
decodeSelector
                            StateT PState (Parser ByteString) (Word8 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT PState (Parser ByteString) (ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) Word8
decodeMType
                            StateT PState (Parser ByteString) (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) ByteString
decodeADF
  where
    decodeUsage :: StateT PState (Parser ByteString) Word8
decodeUsage    = StateT PState (Parser ByteString) Word8
get8
    decodeSelector :: StateT PState (Parser ByteString) Word8
decodeSelector = StateT PState (Parser ByteString) Word8
get8
    decodeMType :: StateT PState (Parser ByteString) Word8
decodeMType    = StateT PState (Parser ByteString) Word8
get8
    decodeADF :: StateT PState (Parser ByteString) ByteString
decodeADF      = Int -> StateT PState (Parser ByteString) ByteString
getNByteString (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3)
--
getRData TYPE
DS Int
len = Word16 -> Word8 -> Word8 -> ByteString -> RData
RD_DS (Word16 -> Word8 -> Word8 -> ByteString -> RData)
-> SGet Word16
-> StateT
     PState (Parser ByteString) (Word8 -> Word8 -> ByteString -> RData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word16
decodeTag
                        StateT
  PState (Parser ByteString) (Word8 -> Word8 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT PState (Parser ByteString) (Word8 -> ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) Word8
decodeAlg
                        StateT PState (Parser ByteString) (Word8 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT PState (Parser ByteString) (ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) Word8
decodeDtyp
                        StateT PState (Parser ByteString) (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) ByteString
decodeDval
  where
    decodeTag :: SGet Word16
decodeTag  = SGet Word16
get16
    decodeAlg :: StateT PState (Parser ByteString) Word8
decodeAlg  = StateT PState (Parser ByteString) Word8
get8
    decodeDtyp :: StateT PState (Parser ByteString) Word8
decodeDtyp = StateT PState (Parser ByteString) Word8
get8
    decodeDval :: StateT PState (Parser ByteString) ByteString
decodeDval = Int -> StateT PState (Parser ByteString) ByteString
getNByteString (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)
--
getRData TYPE
CDS Int
len = Word16 -> Word8 -> Word8 -> ByteString -> RData
RD_CDS (Word16 -> Word8 -> Word8 -> ByteString -> RData)
-> SGet Word16
-> StateT
     PState (Parser ByteString) (Word8 -> Word8 -> ByteString -> RData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word16
decodeTag
                          StateT
  PState (Parser ByteString) (Word8 -> Word8 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT PState (Parser ByteString) (Word8 -> ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) Word8
decodeAlg
                          StateT PState (Parser ByteString) (Word8 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT PState (Parser ByteString) (ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) Word8
decodeDtyp
                          StateT PState (Parser ByteString) (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) ByteString
decodeDval
  where
    decodeTag :: SGet Word16
decodeTag  = SGet Word16
get16
    decodeAlg :: StateT PState (Parser ByteString) Word8
decodeAlg  = StateT PState (Parser ByteString) Word8
get8
    decodeDtyp :: StateT PState (Parser ByteString) Word8
decodeDtyp = StateT PState (Parser ByteString) Word8
get8
    decodeDval :: StateT PState (Parser ByteString) ByteString
decodeDval = Int -> StateT PState (Parser ByteString) ByteString
getNByteString (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)
--
getRData TYPE
RRSIG Int
len = RD_RRSIG -> RData
RD_RRSIG (RD_RRSIG -> RData)
-> StateT PState (Parser ByteString) RD_RRSIG -> SGet RData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PState (Parser ByteString) RD_RRSIG
decodeRRSIG
  where
    decodeRRSIG :: StateT PState (Parser ByteString) RD_RRSIG
decodeRRSIG = do
        -- The signature follows a variable length zone name
        -- and occupies the rest of the RData.  Simplest to
        -- checkpoint the position at the start of the RData,
        -- and after reading the zone name, and subtract that
        -- from the RData length.
        --
        end <- Int -> SGet Int
rdataEnd Int
len
        typ <- getTYPE
        alg <- get8
        cnt <- get8
        ttl <- get32
        tex <- getDnsTime
        tin <- getDnsTime
        tag <- get16
        dom <- getDomain -- XXX: Enforce no compression?
        pos <- getPosition
        val <- getNByteString $ end - pos
        return $ RDREP_RRSIG typ alg cnt ttl tex tin tag dom val
    getDnsTime :: StateT PState (Parser ByteString) Int64
getDnsTime   = do
        tnow <- StateT PState (Parser ByteString) Int64
getAtTime
        tdns <- get32
        return $! dnsTime tdns tnow
--
getRData TYPE
NULL Int
len = ByteString -> RData
RD_NULL (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) ByteString
getNByteString Int
len
getRData TYPE
NSEC Int
len = do
    end <- Int -> SGet Int
rdataEnd Int
len
    dom <- getDomain
    pos <- getPosition
    RD_NSEC dom <$> getNsecTypes (end - pos)
--
getRData TYPE
DNSKEY Int
len = Word16 -> Word8 -> Word8 -> ByteString -> RData
RD_DNSKEY (Word16 -> Word8 -> Word8 -> ByteString -> RData)
-> SGet Word16
-> StateT
     PState (Parser ByteString) (Word8 -> Word8 -> ByteString -> RData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word16
decodeKeyFlags
                                StateT
  PState (Parser ByteString) (Word8 -> Word8 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT PState (Parser ByteString) (Word8 -> ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) Word8
decodeKeyProto
                                StateT PState (Parser ByteString) (Word8 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT PState (Parser ByteString) (ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) Word8
decodeKeyAlg
                                StateT PState (Parser ByteString) (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) ByteString
decodeKeyBytes
  where
    decodeKeyFlags :: SGet Word16
decodeKeyFlags  = SGet Word16
get16
    decodeKeyProto :: StateT PState (Parser ByteString) Word8
decodeKeyProto  = StateT PState (Parser ByteString) Word8
get8
    decodeKeyAlg :: StateT PState (Parser ByteString) Word8
decodeKeyAlg    = StateT PState (Parser ByteString) Word8
get8
    decodeKeyBytes :: StateT PState (Parser ByteString) ByteString
decodeKeyBytes  = Int -> StateT PState (Parser ByteString) ByteString
getNByteString (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)
--
getRData TYPE
CDNSKEY Int
len = Word16 -> Word8 -> Word8 -> ByteString -> RData
RD_CDNSKEY (Word16 -> Word8 -> Word8 -> ByteString -> RData)
-> SGet Word16
-> StateT
     PState (Parser ByteString) (Word8 -> Word8 -> ByteString -> RData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word16
decodeKeyFlags
                                  StateT
  PState (Parser ByteString) (Word8 -> Word8 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT PState (Parser ByteString) (Word8 -> ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) Word8
decodeKeyProto
                                  StateT PState (Parser ByteString) (Word8 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT PState (Parser ByteString) (ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) Word8
decodeKeyAlg
                                  StateT PState (Parser ByteString) (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) ByteString
decodeKeyBytes
  where
    decodeKeyFlags :: SGet Word16
decodeKeyFlags  = SGet Word16
get16
    decodeKeyProto :: StateT PState (Parser ByteString) Word8
decodeKeyProto  = StateT PState (Parser ByteString) Word8
get8
    decodeKeyAlg :: StateT PState (Parser ByteString) Word8
decodeKeyAlg    = StateT PState (Parser ByteString) Word8
get8
    decodeKeyBytes :: StateT PState (Parser ByteString) ByteString
decodeKeyBytes  = Int -> StateT PState (Parser ByteString) ByteString
getNByteString (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)
--
getRData TYPE
NSEC3 Int
len = do
    dend <- Int -> SGet Int
rdataEnd Int
len
    halg <- get8
    flgs <- get8
    iter <- get16
    salt <- getInt8 >>= getNByteString
    hash <- getInt8 >>= getNByteString
    tpos <- getPosition
    RD_NSEC3 halg flgs iter salt hash <$> getNsecTypes (dend - tpos)
--
getRData TYPE
NSEC3PARAM Int
_ = Word8 -> Word8 -> Word16 -> ByteString -> RData
RD_NSEC3PARAM (Word8 -> Word8 -> Word16 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT
     PState (Parser ByteString) (Word8 -> Word16 -> ByteString -> RData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT PState (Parser ByteString) Word8
decodeHashAlg
                                      StateT
  PState (Parser ByteString) (Word8 -> Word16 -> ByteString -> RData)
-> StateT PState (Parser ByteString) Word8
-> StateT
     PState (Parser ByteString) (Word16 -> ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) Word8
decodeFlags
                                      StateT PState (Parser ByteString) (Word16 -> ByteString -> RData)
-> SGet Word16
-> StateT PState (Parser ByteString) (ByteString -> RData)
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SGet Word16
decodeIterations
                                      StateT PState (Parser ByteString) (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall a b.
StateT PState (Parser ByteString) (a -> b)
-> StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT PState (Parser ByteString) ByteString
decodeSalt
  where
    decodeHashAlg :: StateT PState (Parser ByteString) Word8
decodeHashAlg    = StateT PState (Parser ByteString) Word8
get8
    decodeFlags :: StateT PState (Parser ByteString) Word8
decodeFlags      = StateT PState (Parser ByteString) Word8
get8
    decodeIterations :: SGet Word16
decodeIterations = SGet Word16
get16
    decodeSalt :: StateT PState (Parser ByteString) ByteString
decodeSalt       = SGet Int
getInt8 SGet Int
-> (Int -> StateT PState (Parser ByteString) ByteString)
-> StateT PState (Parser ByteString) ByteString
forall a b.
StateT PState (Parser ByteString) a
-> (a -> StateT PState (Parser ByteString) b)
-> StateT PState (Parser ByteString) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> StateT PState (Parser ByteString) ByteString
getNByteString
--
getRData TYPE
CAA Int
len = do
    dend <- Int -> SGet Int
rdataEnd Int
len
    flags <- get8
    tag <- getInt8 >>= getNByteString
    tpos <- getPosition
    RD_CAA flags (CI.mk tag) <$> getNByteString (dend - tpos)
--
getRData TYPE
_  Int
len = ByteString -> RData
UnknownRData (ByteString -> RData)
-> StateT PState (Parser ByteString) ByteString -> SGet RData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) ByteString
getNByteString Int
len

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

-- $
--
-- >>> import Network.DNS.StateBinary
-- >>> let Right ((t,_),l) = runSGetWithLeftovers (getTXT 8) "\3foo\3barbaz"
-- >>> (t, l) == ("foobar", "baz")
-- True

-- | Concatenate a sequence of length-prefixed strings of text
-- https://tools.ietf.org/html/rfc1035#section-3.3
--
getTXT :: Int -> SGet ByteString
getTXT :: Int -> StateT PState (Parser ByteString) ByteString
getTXT !Int
len = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> StateT PState (Parser ByteString) [ByteString]
-> StateT PState (Parser ByteString) ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Int
-> StateT PState (Parser ByteString) ByteString
-> StateT PState (Parser ByteString) [ByteString]
forall a. String -> Int -> SGet a -> SGet [a]
sGetMany String
"TXT RR string" Int
len StateT PState (Parser ByteString) ByteString
getstring
  where
    getstring :: StateT PState (Parser ByteString) ByteString
getstring = SGet Int
getInt8 SGet Int
-> (Int -> StateT PState (Parser ByteString) ByteString)
-> StateT PState (Parser ByteString) ByteString
forall a b.
StateT PState (Parser ByteString) a
-> (a -> StateT PState (Parser ByteString) b)
-> StateT PState (Parser ByteString) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> StateT PState (Parser ByteString) ByteString
getNByteString

-- <https://tools.ietf.org/html/rfc6891#section-6.1.2>
-- Parse a list of EDNS options
--
getOpts :: Int -> SGet [OData]
getOpts :: Int -> StateT PState (Parser ByteString) [OData]
getOpts !Int
len = String
-> Int -> SGet OData -> StateT PState (Parser ByteString) [OData]
forall a. String -> Int -> SGet a -> SGet [a]
sGetMany String
"EDNS option" Int
len SGet OData
getoption
  where
    getoption :: SGet OData
getoption = do
        code <- Word16 -> OptCode
toOptCode (Word16 -> OptCode)
-> SGet Word16 -> StateT PState (Parser ByteString) OptCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word16
get16
        olen <- getInt16
        getOData code olen

-- <https://tools.ietf.org/html/rfc4034#section-4.1>
-- Parse a list of NSEC type bitmaps
--
getNsecTypes :: Int -> SGet [TYPE]
getNsecTypes :: Int -> StateT PState (Parser ByteString) [TYPE]
getNsecTypes !Int
len = [[TYPE]] -> [TYPE]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TYPE]] -> [TYPE])
-> StateT PState (Parser ByteString) [[TYPE]]
-> StateT PState (Parser ByteString) [TYPE]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Int
-> StateT PState (Parser ByteString) [TYPE]
-> StateT PState (Parser ByteString) [[TYPE]]
forall a. String -> Int -> SGet a -> SGet [a]
sGetMany String
"NSEC type bitmap" Int
len StateT PState (Parser ByteString) [TYPE]
getbits
  where
    getbits :: StateT PState (Parser ByteString) [TYPE]
getbits = do
        window <- (Int -> Int -> Int) -> Int -> Int -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
8 (Int -> Int) -> SGet Int -> SGet Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Int
getInt8
        blocks <- getInt8
        when (blocks > 32) $
            failSGet $ "NSEC bitmap block too long: " ++ show blocks
        concatMap blkTypes. zip [window, window + 8..] <$> getNBytes blocks
      where
        blkTypes :: (Int, a) -> [TYPE]
blkTypes (Int
bitOffset, a
byte) =
            [ Word16 -> TYPE
toTYPE (Word16 -> TYPE) -> Word16 -> TYPE
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Int
bitOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i |
              Int
i <- [Int
0..Int
7], a
byte a -> a -> a
forall a. Bits a => a -> a -> a
.&. Int -> a
forall a. Bits a => Int -> a
bit (Int
7Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 ]

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

getOData :: OptCode -> Int -> SGet OData
getOData :: OptCode -> Int -> SGet OData
getOData OptCode
NSID Int
len = ByteString -> OData
OD_NSID (ByteString -> OData)
-> StateT PState (Parser ByteString) ByteString -> SGet OData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) ByteString
getNByteString Int
len
getOData OptCode
DAU  Int
len = [Word8] -> OData
OD_DAU  ([Word8] -> OData)
-> StateT PState (Parser ByteString) [Word8] -> SGet OData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) [Word8]
getNoctets Int
len
getOData OptCode
DHU  Int
len = [Word8] -> OData
OD_DHU  ([Word8] -> OData)
-> StateT PState (Parser ByteString) [Word8] -> SGet OData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) [Word8]
getNoctets Int
len
getOData OptCode
N3U  Int
len = [Word8] -> OData
OD_N3U  ([Word8] -> OData)
-> StateT PState (Parser ByteString) [Word8] -> SGet OData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) [Word8]
getNoctets Int
len
getOData OptCode
ClientSubnet Int
len = do
        family  <- SGet Word16
get16
        srcBits <- get8
        scpBits <- get8
        addrbs  <- getNByteString (len - 4) -- 4 = 2 + 1 + 1
        --
        -- https://tools.ietf.org/html/rfc7871#section-6
        --
        -- o  ADDRESS, variable number of octets, contains either an IPv4 or
        --    IPv6 address, depending on FAMILY, which MUST be truncated to the
        --    number of bits indicated by the SOURCE PREFIX-LENGTH field,
        --    padding with 0 bits to pad to the end of the last octet needed.
        --
        -- o  A server receiving an ECS option that uses either too few or too
        --    many ADDRESS octets, or that has non-zero ADDRESS bits set beyond
        --    SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet,
        --    as a signal to the software developer making the request to fix
        --    their implementation.
        --
        -- In order to avoid needless decoding errors, when the ECS encoding
        -- requirements are violated, we construct an OD_ECSgeneric OData,
        -- instread of an IP-specific OD_ClientSubnet OData, which will only
        -- be used for valid inputs.  When the family is neither IPv4(1) nor
        -- IPv6(2), or the address prefix is not correctly encoded (too long
        -- or too short), the OD_ECSgeneric data contains the verbatim input
        -- from the peer.
        --
        case BS.length addrbs == (fromIntegral srcBits + 7) `div` 8 of
            Bool
True | Just IP
ip <- Word16 -> ByteString -> Word8 -> Word8 -> Maybe IP
bstoip Word16
family ByteString
addrbs Word8
srcBits Word8
scpBits
                -> OData -> SGet OData
forall a. a -> StateT PState (Parser ByteString) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OData -> SGet OData) -> OData -> SGet OData
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> IP -> OData
OD_ClientSubnet Word8
srcBits Word8
scpBits IP
ip
            Bool
_   -> OData -> SGet OData
forall a. a -> StateT PState (Parser ByteString) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OData -> SGet OData) -> OData -> SGet OData
forall a b. (a -> b) -> a -> b
$ Word16 -> Word8 -> Word8 -> ByteString -> OData
OD_ECSgeneric Word16
family Word8
srcBits Word8
scpBits ByteString
addrbs
  where
    prefix :: a -> a -> a
prefix a
addr a
bits = AddrRange a -> a
forall a. AddrRange a -> a
Data.IP.addr (AddrRange a -> a) -> AddrRange a -> a
forall a b. (a -> b) -> a -> b
$ a -> Int -> AddrRange a
forall a. Addr a => a -> Int -> AddrRange a
makeAddrRange a
addr (Int -> AddrRange a) -> Int -> AddrRange a
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
bits
    zeropad :: ByteString -> [Int]
zeropad = ([Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int]
forall a. a -> [a]
repeat Int
0)([Int] -> [Int]) -> (ByteString -> [Int]) -> ByteString -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Int) -> [Word8] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral([Word8] -> [Int])
-> (ByteString -> [Word8]) -> ByteString -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack
    checkBits :: (t a -> t) -> (t -> a) -> p -> a -> t a -> Maybe a
checkBits t a -> t
fromBytes t -> a
toIP p
srcBits a
scpBits t a
bytes =
        let addr :: t
addr       = t a -> t
fromBytes t a
bytes
            maskedAddr :: t
maskedAddr = t -> p -> t
forall {a} {a}. (Addr a, Integral a) => a -> a -> a
prefix t
addr p
srcBits
            maxBits :: a
maxBits    = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
bytes
         in if t
addr t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
maskedAddr Bool -> Bool -> Bool
&& a
scpBits a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
maxBits
            then a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ t -> a
toIP t
addr
            else Maybe a
forall a. Maybe a
Nothing
    bstoip :: Word16 -> B.ByteString -> Word8 -> Word8 -> Maybe IP
    bstoip :: Word16 -> ByteString -> Word8 -> Word8 -> Maybe IP
bstoip Word16
family ByteString
bs Word8
srcBits Word8
scpBits = case Word16
family of
        Word16
1 -> ([Int] -> IPv4)
-> (IPv4 -> IP) -> Word8 -> Word8 -> [Int] -> Maybe IP
forall {t :: * -> *} {t} {p} {a} {a} {a}.
(Foldable t, Addr t, Integral p, Num a, Ord a) =>
(t a -> t) -> (t -> a) -> p -> a -> t a -> Maybe a
checkBits [Int] -> IPv4
toIPv4  IPv4 -> IP
IPv4 Word8
srcBits Word8
scpBits ([Int] -> Maybe IP) -> [Int] -> Maybe IP
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
4  ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Int]
zeropad ByteString
bs
        Word16
2 -> ([Int] -> IPv6)
-> (IPv6 -> IP) -> Word8 -> Word8 -> [Int] -> Maybe IP
forall {t :: * -> *} {t} {p} {a} {a} {a}.
(Foldable t, Addr t, Integral p, Num a, Ord a) =>
(t a -> t) -> (t -> a) -> p -> a -> t a -> Maybe a
checkBits [Int] -> IPv6
toIPv6b IPv6 -> IP
IPv6 Word8
srcBits Word8
scpBits ([Int] -> Maybe IP) -> [Int] -> Maybe IP
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
16 ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Int]
zeropad ByteString
bs
        Word16
_ -> Maybe IP
forall a. Maybe a
Nothing
getOData OptCode
opc Int
len = Word16 -> ByteString -> OData
UnknownOData (OptCode -> Word16
fromOptCode OptCode
opc) (ByteString -> OData)
-> StateT PState (Parser ByteString) ByteString -> SGet OData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) ByteString
getNByteString Int
len

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

-- | Pointers MUST point back into the packet per RFC1035 Section 4.1.4.  This
-- is further interpreted by the DNS community (from a discussion on the IETF
-- DNSOP mailing list) to mean that they don't point back into the same domain.
-- Therefore, when starting to parse a domain, the current offset is also a
-- strict upper bound on the targets of any pointers that arise while processing
-- the domain.  When following a pointer, the target again becomes a stict upper
-- bound for any subsequent pointers.  This results in a simple loop-prevention
-- algorithm, each sequence of valid pointer values is necessarily strictly
-- decreasing!  The third argument to 'getDomain'' is a strict pointer upper
-- bound, and is set here to the position at the start of parsing the domain
-- or mailbox.
--
-- Note: the separator passed to 'getDomain'' is required to be either \'.\' or
-- \'\@\', or else 'unparseLabel' needs to be modified to handle the new value.
--

getDomain :: SGet Domain
getDomain :: StateT PState (Parser ByteString) ByteString
getDomain = SGet Int
getPosition SGet Int
-> (Int -> StateT PState (Parser ByteString) ByteString)
-> StateT PState (Parser ByteString) ByteString
forall a b.
StateT PState (Parser ByteString) a
-> (a -> StateT PState (Parser ByteString) b)
-> StateT PState (Parser ByteString) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Int -> StateT PState (Parser ByteString) ByteString
getDomain' Word8
dot

getMailbox :: SGet Mailbox
getMailbox :: StateT PState (Parser ByteString) ByteString
getMailbox = SGet Int
getPosition SGet Int
-> (Int -> StateT PState (Parser ByteString) ByteString)
-> StateT PState (Parser ByteString) ByteString
forall a b.
StateT PState (Parser ByteString) a
-> (a -> StateT PState (Parser ByteString) b)
-> StateT PState (Parser ByteString) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Int -> StateT PState (Parser ByteString) ByteString
getDomain' Word8
atsign

dot, atsign :: Word8
dot :: Word8
dot    = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'.' -- 46
atsign :: Word8
atsign = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'@' -- 64

-- $
-- Pathological case: pointer embedded inside a label!  The pointer points
-- behind the start of the domain and is then absorbed into the initial label!
-- Though we don't IMHO have to support this, it is not manifestly illegal, and
-- does exercise the code in an interesting way.  Ugly as this is, it also
-- "works" the same in Perl's Net::DNS and reportedly in ISC's BIND.
--
-- >>> :{
-- let input = "\6\3foo\192\0\3bar\0"
--     parser = skipNBytes 1 >> getDomain' dot 1
--     Right (output, _) = runSGet parser input
--  in output == "foo.\\003foo\\192\\000.bar."
-- :}
-- True
--
-- The case below fails to point far enough back, and triggers the loop
-- prevention code-path.
--
-- >>> :{
-- let input = "\6\3foo\192\1\3bar\0"
--     parser = skipNBytes 1 >> getDomain' dot 1
--     Left (DecodeError err) = runSGet parser input
--  in err
-- :}
-- "invalid name compression pointer"

-- | Get a domain name, using sep1 as the separator between the 1st and 2nd
-- label.  Subsequent labels (and always the trailing label) are terminated
-- with a ".".
--
-- Note: the separator is required to be either \'.\' or \'\@\', or else
-- 'unparseLabel' needs to be modified to handle the new value.
--
-- Domain name compression pointers must always refer to a position that
-- precedes the start of the current domain name.  The starting offsets form a
-- strictly decreasing sequence, which prevents pointer loops.
--
getDomain' :: Word8 -> Int -> SGet ByteString
getDomain' :: Word8 -> Int -> StateT PState (Parser ByteString) ByteString
getDomain' Word8
sep1 Int
ptrLimit = do
    pos <- SGet Int
getPosition
    c <- getInt8
    let n = Int -> Int
forall {a}. (Bits a, Num a) => a -> a
getValue Int
c
    getdomain pos c n
  where
    -- Reprocess the same ByteString starting at the pointer
    -- target (offset).
    getPtr :: Int -> Int -> StateT PState (Parser ByteString) ByteString
getPtr Int
pos Int
offset = do
        msg <- StateT PState (Parser ByteString) ByteString
getInput
        let parser = Int -> StateT PState (Parser ByteString) ()
skipNBytes Int
offset StateT PState (Parser ByteString) ()
-> StateT PState (Parser ByteString) ByteString
-> StateT PState (Parser ByteString) ByteString
forall a b.
StateT PState (Parser ByteString) a
-> StateT PState (Parser ByteString) b
-> StateT PState (Parser ByteString) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Int -> StateT PState (Parser ByteString) ByteString
getDomain' Word8
sep1 Int
offset
        case runSGet parser msg of
            Left (DecodeError String
err) -> String -> StateT PState (Parser ByteString) ByteString
forall a. String -> SGet a
failSGet String
err
            Left DNSError
err               -> String -> StateT PState (Parser ByteString) ByteString
forall a. String -> SGet a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT PState (Parser ByteString) ByteString)
-> String -> StateT PState (Parser ByteString) ByteString
forall a b. (a -> b) -> a -> b
$ DNSError -> String
forall a. Show a => a -> String
show DNSError
err
            Right (ByteString, PState)
o                -> do
                -- Cache only the presentation form decoding of domain names,
                -- mailboxes (e.g. SOA rname) are less frequently reused, and
                -- have a different presentation form, so must not share the
                -- same cache.
                Bool
-> StateT PState (Parser ByteString) ()
-> StateT PState (Parser ByteString) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
sep1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
dot) (StateT PState (Parser ByteString) ()
 -> StateT PState (Parser ByteString) ())
-> StateT PState (Parser ByteString) ()
-> StateT PState (Parser ByteString) ()
forall a b. (a -> b) -> a -> b
$
                    Int -> ByteString -> StateT PState (Parser ByteString) ()
push Int
pos ((ByteString, PState) -> ByteString
forall a b. (a, b) -> a
fst (ByteString, PState)
o)
                ByteString -> StateT PState (Parser ByteString) ByteString
forall a. a -> StateT PState (Parser ByteString) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, PState) -> ByteString
forall a b. (a, b) -> a
fst (ByteString, PState)
o)

    getdomain :: Int -> a -> Int -> StateT PState (Parser ByteString) ByteString
getdomain Int
pos a
c Int
n
      | a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = ByteString -> StateT PState (Parser ByteString) ByteString
forall a. a -> StateT PState (Parser ByteString) a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"." -- Perhaps the root domain?
      | a -> Bool
forall {a}. Bits a => a -> Bool
isPointer a
c = do
          d <- SGet Int
getInt8
          let offset = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d
          when (offset >= ptrLimit) $
              failSGet "invalid name compression pointer"
          if sep1 /= dot
              then getPtr pos offset
              else pop offset >>= \case
                  Maybe ByteString
Nothing -> Int -> Int -> StateT PState (Parser ByteString) ByteString
getPtr Int
pos Int
offset
                  Just ByteString
o  -> ByteString -> StateT PState (Parser ByteString) ByteString
forall a. a -> StateT PState (Parser ByteString) a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
o
      -- As for now, extended labels have no use.
      -- This may change some time in the future.
      | a -> Bool
forall {a}. Bits a => a -> Bool
isExtLabel a
c = ByteString -> StateT PState (Parser ByteString) ByteString
forall a. a -> StateT PState (Parser ByteString) a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
      | Bool
otherwise = do
          hs <- Word8 -> ByteString -> ByteString
unparseLabel Word8
sep1 (ByteString -> ByteString)
-> StateT PState (Parser ByteString) ByteString
-> StateT PState (Parser ByteString) ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT PState (Parser ByteString) ByteString
getNByteString Int
n
          ds <- getDomain' dot ptrLimit
          let dom = case ByteString
ds of -- avoid trailing ".."
                  ByteString
"." -> ByteString
hs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"."
                  ByteString
_   -> ByteString
hs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
B.singleton Word8
sep1 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ds
          push pos dom
          return dom
    getValue :: a -> a
getValue a
c = a
c a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f
    isPointer :: a -> Bool
isPointer a
c = a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
c Int
7 Bool -> Bool -> Bool
&& a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
c Int
6
    isExtLabel :: a -> Bool
isExtLabel a
c = Bool -> Bool
not (a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
c Int
7) Bool -> Bool -> Bool
&& a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
c Int
6