{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Network.DNS.StateBinary (
PState(..)
, initialState
, SPut
, runSPut
, put8
, put16
, put32
, putInt8
, putInt16
, putInt32
, putByteString
, putReplicate
, SGet
, failSGet
, fitSGet
, runSGet
, runSGetAt
, runSGetWithLeftovers
, runSGetWithLeftoversAt
, get8
, get16
, get32
, getInt8
, getInt16
, getInt32
, getNByteString
, sGetMany
, getPosition
, getInput
, getAtTime
, wsPop
, wsPush
, wsPosition
, addPositionW
, push
, pop
, getNBytes
, getNoctets
, skipNBytes
, parseLabel
, unparseLabel
) where
import qualified Control.Exception as E
import Control.Monad.State.Strict (State, StateT)
import qualified Control.Monad.State.Strict as ST
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.Types as T
import qualified Data.ByteString as BS
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.Map (Map)
import qualified Data.Map as M
import Data.Semigroup as Sem
import Network.DNS.Imports
import Network.DNS.Types.Internal
type SPut = State WState Builder
data WState = WState {
WState -> Map ByteString Int
wsDomain :: Map Domain Int
, WState -> Int
wsPosition :: Int
}
initialWState :: WState
initialWState :: WState
initialWState = Map ByteString Int -> Int -> WState
WState Map ByteString Int
forall k a. Map k a
M.empty Int
0
instance Sem.Semigroup SPut where
SPut
p1 <> :: SPut -> SPut -> SPut
<> SPut
p2 = Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
(Sem.<>) (Builder -> Builder -> Builder)
-> SPut -> StateT WState Identity (Builder -> Builder)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SPut
p1 StateT WState Identity (Builder -> Builder) -> SPut -> SPut
forall a b.
StateT WState Identity (a -> b)
-> StateT WState Identity a -> StateT WState Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SPut
p2
instance Monoid SPut where
mempty :: SPut
mempty = Builder -> SPut
forall a. a -> StateT WState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Builder
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
mappend = (Sem.<>)
#endif
put8 :: Word8 -> SPut
put8 :: Word8 -> SPut
put8 = Int -> (Word8 -> Builder) -> Word8 -> SPut
forall a. Int -> (a -> Builder) -> a -> SPut
fixedSized Int
1 Word8 -> Builder
BB.word8
put16 :: Word16 -> SPut
put16 :: Word16 -> SPut
put16 = Int -> (Word16 -> Builder) -> Word16 -> SPut
forall a. Int -> (a -> Builder) -> a -> SPut
fixedSized Int
2 Word16 -> Builder
BB.word16BE
put32 :: Word32 -> SPut
put32 :: Word32 -> SPut
put32 = Int -> (Word32 -> Builder) -> Word32 -> SPut
forall a. Int -> (a -> Builder) -> a -> SPut
fixedSized Int
4 Word32 -> Builder
BB.word32BE
putInt8 :: Int -> SPut
putInt8 :: Int -> SPut
putInt8 = Int -> (Int -> Builder) -> Int -> SPut
forall a. Int -> (a -> Builder) -> a -> SPut
fixedSized Int
1 (Int8 -> Builder
BB.int8 (Int8 -> Builder) -> (Int -> Int8) -> Int -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
putInt16 :: Int -> SPut
putInt16 :: Int -> SPut
putInt16 = Int -> (Int -> Builder) -> Int -> SPut
forall a. Int -> (a -> Builder) -> a -> SPut
fixedSized Int
2 (Int16 -> Builder
BB.int16BE (Int16 -> Builder) -> (Int -> Int16) -> Int -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
putInt32 :: Int -> SPut
putInt32 :: Int -> SPut
putInt32 = Int -> (Int -> Builder) -> Int -> SPut
forall a. Int -> (a -> Builder) -> a -> SPut
fixedSized Int
4 (Int32 -> Builder
BB.int32BE (Int32 -> Builder) -> (Int -> Int32) -> Int -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
putByteString :: ByteString -> SPut
putByteString :: ByteString -> SPut
putByteString = (ByteString -> Int)
-> (ByteString -> Builder) -> ByteString -> SPut
forall a. (a -> Int) -> (a -> Builder) -> a -> SPut
writeSized ByteString -> Int
BS.length ByteString -> Builder
BB.byteString
putReplicate :: Int -> Word8 -> SPut
putReplicate :: Int -> Word8 -> SPut
putReplicate Int
n Word8
w =
Int -> (ByteString -> Builder) -> ByteString -> SPut
forall a. Int -> (a -> Builder) -> a -> SPut
fixedSized Int
n ByteString -> Builder
BB.lazyByteString (ByteString -> SPut) -> ByteString -> SPut
forall a b. (a -> b) -> a -> b
$ Int64 -> Word8 -> ByteString
LB.replicate (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) Word8
w
addPositionW :: Int -> State WState ()
addPositionW :: Int -> State WState ()
addPositionW Int
n = do
(WState m cur) <- StateT WState Identity WState
forall s (m :: * -> *). MonadState s m => m s
ST.get
ST.put $ WState m (cur+n)
fixedSized :: Int -> (a -> Builder) -> a -> SPut
fixedSized :: forall a. Int -> (a -> Builder) -> a -> SPut
fixedSized Int
n a -> Builder
f a
a = do Int -> State WState ()
addPositionW Int
n
Builder -> SPut
forall a. a -> StateT WState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Builder
f a
a)
writeSized :: (a -> Int) -> (a -> Builder) -> a -> SPut
writeSized :: forall a. (a -> Int) -> (a -> Builder) -> a -> SPut
writeSized a -> Int
n a -> Builder
f a
a = do Int -> State WState ()
addPositionW (a -> Int
n a
a)
Builder -> SPut
forall a. a -> StateT WState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Builder
f a
a)
wsPop :: Domain -> State WState (Maybe Int)
wsPop :: ByteString -> State WState (Maybe Int)
wsPop ByteString
dom = do
doms <- (WState -> Map ByteString Int)
-> StateT WState Identity (Map ByteString Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
ST.gets WState -> Map ByteString Int
wsDomain
return $ M.lookup dom doms
wsPush :: Domain -> Int -> State WState ()
wsPush :: ByteString -> Int -> State WState ()
wsPush ByteString
dom Int
pos = do
(WState m cur) <- StateT WState Identity WState
forall s (m :: * -> *). MonadState s m => m s
ST.get
ST.put $ WState (M.insert dom pos m) cur
type SGet = StateT PState (T.Parser ByteString)
data PState = PState {
PState -> IntMap ByteString
psDomain :: IntMap Domain
, PState -> Int
psPosition :: Int
, PState -> ByteString
psInput :: ByteString
, PState -> Int64
psAtTime :: Int64
}
getPosition :: SGet Int
getPosition :: SGet Int
getPosition = (PState -> Int) -> SGet Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
ST.gets PState -> Int
psPosition
getInput :: SGet ByteString
getInput :: SGet ByteString
getInput = (PState -> ByteString) -> SGet ByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
ST.gets PState -> ByteString
psInput
getAtTime :: SGet Int64
getAtTime :: SGet Int64
getAtTime = (PState -> Int64) -> SGet Int64
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
ST.gets PState -> Int64
psAtTime
addPosition :: Int -> SGet ()
addPosition :: Int -> SGet ()
addPosition Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> SGet ()
forall a. String -> SGet a
failSGet String
"internal error: negative position increment"
| Bool
otherwise = do
PState dom pos inp t <- StateT PState (Parser ByteString) PState
forall s (m :: * -> *). MonadState s m => m s
ST.get
let !pos' = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
when (pos' > BS.length inp) $
failSGet "malformed or truncated input"
ST.put $ PState dom pos' inp t
push :: Int -> Domain -> SGet ()
push :: Int -> ByteString -> SGet ()
push Int
n ByteString
d = do
PState dom pos inp t <- StateT PState (Parser ByteString) PState
forall s (m :: * -> *). MonadState s m => m s
ST.get
ST.put $ PState (IM.insert n d dom) pos inp t
pop :: Int -> SGet (Maybe Domain)
pop :: Int -> SGet (Maybe ByteString)
pop Int
n = (PState -> Maybe ByteString) -> SGet (Maybe ByteString)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
ST.gets (Int -> IntMap ByteString -> Maybe ByteString
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
n (IntMap ByteString -> Maybe ByteString)
-> (PState -> IntMap ByteString) -> PState -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PState -> IntMap ByteString
psDomain)
get8 :: SGet Word8
get8 :: SGet Word8
get8 = Parser ByteString Word8 -> SGet Word8
forall (m :: * -> *) a. Monad m => m a -> StateT PState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
ST.lift Parser ByteString Word8
A.anyWord8 SGet Word8 -> SGet () -> SGet Word8
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
<* Int -> SGet ()
addPosition Int
1
get16 :: SGet Word16
get16 :: SGet Word16
get16 = Parser ByteString Word16 -> SGet Word16
forall (m :: * -> *) a. Monad m => m a -> StateT PState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
ST.lift Parser ByteString Word16
getWord16be SGet Word16 -> SGet () -> SGet Word16
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
<* Int -> SGet ()
addPosition Int
2
where
word8' :: Parser ByteString Word16
word8' = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16)
-> Parser ByteString Word8 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
A.anyWord8
getWord16be :: Parser ByteString Word16
getWord16be = do
a <- Parser ByteString Word16
word8'
b <- word8'
return $ a * 0x100 + b
get32 :: SGet Word32
get32 :: SGet Word32
get32 = Parser ByteString Word32 -> SGet Word32
forall (m :: * -> *) a. Monad m => m a -> StateT PState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
ST.lift Parser ByteString Word32
getWord32be SGet Word32 -> SGet () -> SGet Word32
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
<* Int -> SGet ()
addPosition Int
4
where
word8' :: Parser ByteString Word32
word8' = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32)
-> Parser ByteString Word8 -> Parser ByteString Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
A.anyWord8
getWord32be :: Parser ByteString Word32
getWord32be = do
a <- Parser ByteString Word32
word8'
b <- word8'
c <- word8'
d <- word8'
return $ a * 0x1000000 + b * 0x10000 + c * 0x100 + d
getInt8 :: SGet Int
getInt8 :: SGet Int
getInt8 = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> SGet Word8 -> SGet Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word8
get8
getInt16 :: SGet Int
getInt16 :: SGet Int
getInt16 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> SGet Word16 -> SGet Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word16
get16
getInt32 :: SGet Int
getInt32 :: SGet Int
getInt32 = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> SGet Word32 -> SGet Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SGet Word32
get32
overrun :: SGet a
overrun :: forall a. SGet a
overrun = String -> SGet a
forall a. String -> SGet a
failSGet String
"malformed or truncated input"
getNBytes :: Int -> SGet [Int]
getNBytes :: Int -> SGet [Int]
getNBytes Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = SGet [Int]
forall a. SGet a
overrun
| Bool
otherwise = ByteString -> [Int]
toInts (ByteString -> [Int]) -> SGet ByteString -> SGet [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> SGet ByteString
getNByteString Int
n
where
toInts :: ByteString -> [Int]
toInts = (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]
BS.unpack
getNoctets :: Int -> SGet [Word8]
getNoctets :: Int -> SGet [Word8]
getNoctets Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = SGet [Word8]
forall a. SGet a
overrun
| Bool
otherwise = ByteString -> [Word8]
BS.unpack (ByteString -> [Word8]) -> SGet ByteString -> SGet [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> SGet ByteString
getNByteString Int
n
skipNBytes :: Int -> SGet ()
skipNBytes :: Int -> SGet ()
skipNBytes Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = SGet ()
forall a. SGet a
overrun
| Bool
otherwise = Parser ByteString ByteString -> SGet ByteString
forall (m :: * -> *) a. Monad m => m a -> StateT PState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
ST.lift (Int -> Parser ByteString ByteString
A.take Int
n) SGet ByteString -> SGet () -> SGet ()
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
>> Int -> SGet ()
addPosition Int
n
getNByteString :: Int -> SGet ByteString
getNByteString :: Int -> SGet ByteString
getNByteString Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = SGet ByteString
forall a. SGet a
overrun
| Bool
otherwise = Parser ByteString ByteString -> SGet ByteString
forall (m :: * -> *) a. Monad m => m a -> StateT PState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
ST.lift (Int -> Parser ByteString ByteString
A.take Int
n) SGet ByteString -> SGet () -> SGet ByteString
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
<* Int -> SGet ()
addPosition Int
n
fitSGet :: Int -> SGet a -> SGet a
fitSGet :: forall a. Int -> SGet a -> SGet a
fitSGet Int
len SGet a
parser | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = SGet a
forall a. SGet a
overrun
| Bool
otherwise = do
pos0 <- SGet Int
getPosition
ret <- parser
pos' <- getPosition
if pos' == pos0 + len
then return $! ret
else if pos' > pos0 + len
then failSGet "element size exceeds declared size"
else failSGet "element shorter than declared size"
sGetMany :: String
-> Int
-> SGet a
-> SGet [a]
sGetMany :: forall a. String -> Int -> SGet a -> SGet [a]
sGetMany String
elemname Int
len SGet a
parser | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = SGet [a]
forall a. SGet a
overrun
| Bool
otherwise = Int -> [a] -> SGet [a]
go Int
len []
where
go :: Int -> [a] -> SGet [a]
go Int
n [a]
xs
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> SGet [a]
forall a. String -> SGet a
failSGet (String -> SGet [a]) -> String -> SGet [a]
forall a b. (a -> b) -> a -> b
$ String
elemname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" longer than declared size"
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [a] -> SGet [a]
forall a. a -> StateT PState (Parser ByteString) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> SGet [a]) -> [a] -> SGet [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs
| Bool
otherwise = do
pos0 <- SGet Int
getPosition
x <- parser
pos1 <- getPosition
if pos1 <= pos0
then failSGet $ "internal error: in-place success for " ++ elemname
else go (n + pos0 - pos1) (x : xs)
dnsTimeMid :: Int64
dnsTimeMid :: Int64
dnsTimeMid = Int64
3426660848
initialState :: Int64 -> ByteString -> PState
initialState :: Int64 -> ByteString -> PState
initialState Int64
t ByteString
inp = IntMap ByteString -> Int -> ByteString -> Int64 -> PState
PState IntMap ByteString
forall a. IntMap a
IM.empty Int
0 ByteString
inp Int64
t
failSGet :: String -> SGet a
failSGet :: forall a. String -> SGet a
failSGet String
msg = Parser ByteString a -> StateT PState (Parser ByteString) a
forall (m :: * -> *) a. Monad m => m a -> StateT PState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
ST.lift (String -> Parser ByteString a
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"" Parser ByteString a -> String -> Parser ByteString a
forall i a. Parser i a -> String -> Parser i a
A.<?> String
msg)
runSGetAt :: Int64 -> SGet a -> ByteString -> Either DNSError (a, PState)
runSGetAt :: forall a.
Int64 -> SGet a -> ByteString -> Either DNSError (a, PState)
runSGetAt Int64
t SGet a
parser ByteString
inp =
Result (a, PState) -> Either DNSError (a, PState)
forall r. Result r -> Either DNSError r
toResult (Result (a, PState) -> Either DNSError (a, PState))
-> Result (a, PState) -> Either DNSError (a, PState)
forall a b. (a -> b) -> a -> b
$ Parser (a, PState) -> ByteString -> Result (a, PState)
forall a. Parser a -> ByteString -> Result a
A.parse (SGet a -> PState -> Parser (a, PState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
ST.runStateT SGet a
parser (PState -> Parser (a, PState)) -> PState -> Parser (a, PState)
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> PState
initialState Int64
t ByteString
inp) ByteString
inp
where
toResult :: A.Result r -> Either DNSError r
toResult :: forall r. Result r -> Either DNSError r
toResult (A.Done ByteString
_ r
r) = r -> Either DNSError r
forall a b. b -> Either a b
Right r
r
toResult (A.Fail ByteString
_ [String]
ctx String
msg) = DNSError -> Either DNSError r
forall a b. a -> Either a b
Left (DNSError -> Either DNSError r) -> DNSError -> Either DNSError r
forall a b. (a -> b) -> a -> b
$ String -> DNSError
DecodeError (String -> DNSError) -> String -> DNSError
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
ctx [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
msg]
toResult (A.Partial ByteString -> IResult ByteString r
_) = DNSError -> Either DNSError r
forall a b. a -> Either a b
Left (DNSError -> Either DNSError r) -> DNSError -> Either DNSError r
forall a b. (a -> b) -> a -> b
$ String -> DNSError
DecodeError String
"incomplete input"
runSGet :: SGet a -> ByteString -> Either DNSError (a, PState)
runSGet :: forall a. SGet a -> ByteString -> Either DNSError (a, PState)
runSGet = Int64 -> SGet a -> ByteString -> Either DNSError (a, PState)
forall a.
Int64 -> SGet a -> ByteString -> Either DNSError (a, PState)
runSGetAt Int64
dnsTimeMid
runSGetWithLeftoversAt :: Int64
-> SGet a
-> ByteString
-> Either DNSError ((a, PState), ByteString)
runSGetWithLeftoversAt :: forall a.
Int64
-> SGet a
-> ByteString
-> Either DNSError ((a, PState), ByteString)
runSGetWithLeftoversAt Int64
t SGet a
parser ByteString
inp =
Result (a, PState) -> Either DNSError ((a, PState), ByteString)
forall r. Result r -> Either DNSError (r, ByteString)
toResult (Result (a, PState) -> Either DNSError ((a, PState), ByteString))
-> Result (a, PState) -> Either DNSError ((a, PState), ByteString)
forall a b. (a -> b) -> a -> b
$ Parser (a, PState) -> ByteString -> Result (a, PState)
forall a. Parser a -> ByteString -> Result a
A.parse (SGet a -> PState -> Parser (a, PState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
ST.runStateT SGet a
parser (PState -> Parser (a, PState)) -> PState -> Parser (a, PState)
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> PState
initialState Int64
t ByteString
inp) ByteString
inp
where
toResult :: A.Result r -> Either DNSError (r, ByteString)
toResult :: forall r. Result r -> Either DNSError (r, ByteString)
toResult (A.Done ByteString
i r
r) = (r, ByteString) -> Either DNSError (r, ByteString)
forall a b. b -> Either a b
Right (r
r, ByteString
i)
toResult (A.Partial ByteString -> IResult ByteString r
f) = IResult ByteString r -> Either DNSError (r, ByteString)
forall r. Result r -> Either DNSError (r, ByteString)
toResult (IResult ByteString r -> Either DNSError (r, ByteString))
-> IResult ByteString r -> Either DNSError (r, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> IResult ByteString r
f ByteString
BS.empty
toResult (A.Fail ByteString
_ [String]
ctx String
e) = DNSError -> Either DNSError (r, ByteString)
forall a b. a -> Either a b
Left (DNSError -> Either DNSError (r, ByteString))
-> DNSError -> Either DNSError (r, ByteString)
forall a b. (a -> b) -> a -> b
$ String -> DNSError
DecodeError (String -> DNSError) -> String -> DNSError
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
ctx [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
e]
runSGetWithLeftovers :: SGet a -> ByteString -> Either DNSError ((a, PState), ByteString)
runSGetWithLeftovers :: forall a.
SGet a -> ByteString -> Either DNSError ((a, PState), ByteString)
runSGetWithLeftovers = Int64
-> SGet a
-> ByteString
-> Either DNSError ((a, PState), ByteString)
forall a.
Int64
-> SGet a
-> ByteString
-> Either DNSError ((a, PState), ByteString)
runSGetWithLeftoversAt Int64
dnsTimeMid
runSPut :: SPut -> ByteString
runSPut :: SPut -> ByteString
runSPut = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (SPut -> ByteString) -> SPut -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> (SPut -> Builder) -> SPut -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SPut -> WState -> Builder) -> WState -> SPut -> Builder
forall a b c. (a -> b -> c) -> b -> a -> c
flip SPut -> WState -> Builder
forall s a. State s a -> s -> a
ST.evalState WState
initialWState
parseLabel :: Word8 -> ByteString -> Either DNSError (ByteString, ByteString)
parseLabel :: Word8 -> ByteString -> Either DNSError (ByteString, ByteString)
parseLabel Word8
sep ByteString
dom =
if (Word8 -> Bool) -> ByteString -> Bool
BS.any (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
bslash) ByteString
dom
then IResult ByteString ByteString
-> Either DNSError (ByteString, ByteString)
toResult (IResult ByteString ByteString
-> Either DNSError (ByteString, ByteString))
-> IResult ByteString ByteString
-> Either DNSError (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Parser ByteString ByteString
-> ByteString -> IResult ByteString ByteString
forall a. Parser a -> ByteString -> Result a
A.parse (Word8 -> ByteString -> Parser ByteString ByteString
labelParser Word8
sep ByteString
forall a. Monoid a => a
mempty) ByteString
dom
else (ByteString, ByteString)
-> Either DNSError (ByteString, ByteString)
check ((ByteString, ByteString)
-> Either DNSError (ByteString, ByteString))
-> (ByteString, ByteString)
-> Either DNSError (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
safeTail (ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
sep) ByteString
dom
where
toResult :: IResult ByteString ByteString
-> Either DNSError (ByteString, ByteString)
toResult (A.Partial ByteString -> IResult ByteString ByteString
c) = IResult ByteString ByteString
-> Either DNSError (ByteString, ByteString)
toResult (ByteString -> IResult ByteString ByteString
c ByteString
forall a. Monoid a => a
mempty)
toResult (A.Done ByteString
tl ByteString
hd) = (ByteString, ByteString)
-> Either DNSError (ByteString, ByteString)
check (ByteString
hd, ByteString
tl)
toResult IResult ByteString ByteString
_ = Either DNSError (ByteString, ByteString)
forall {b}. Either DNSError b
bottom
safeTail :: ByteString -> ByteString
safeTail ByteString
bs | ByteString -> Bool
BS.null ByteString
bs = ByteString
forall a. Monoid a => a
mempty
| Bool
otherwise = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BS.tail ByteString
bs
check :: (ByteString, ByteString)
-> Either DNSError (ByteString, ByteString)
check r :: (ByteString, ByteString)
r@(ByteString
hd, ByteString
tl) | Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
hd) Bool -> Bool -> Bool
|| ByteString -> Bool
BS.null ByteString
tl = (ByteString, ByteString)
-> Either DNSError (ByteString, ByteString)
forall a b. b -> Either a b
Right (ByteString, ByteString)
r
| Bool
otherwise = Either DNSError (ByteString, ByteString)
forall {b}. Either DNSError b
bottom
bottom :: Either DNSError b
bottom = DNSError -> Either DNSError b
forall a b. a -> Either a b
Left (DNSError -> Either DNSError b) -> DNSError -> Either DNSError b
forall a b. (a -> b) -> a -> b
$ String -> DNSError
DecodeError (String -> DNSError) -> String -> DNSError
forall a b. (a -> b) -> a -> b
$ String
"invalid domain: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
S8.unpack ByteString
dom
labelParser :: Word8 -> ByteString -> A.Parser ByteString
labelParser :: Word8 -> ByteString -> Parser ByteString ByteString
labelParser Word8
sep ByteString
acc = do
acc' <- ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
mappend ByteString
acc (ByteString -> ByteString)
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option ByteString
forall a. Monoid a => a
mempty Parser ByteString ByteString
simple
labelEnd sep acc' <|> (escaped >>= labelParser sep . BS.snoc acc')
where
simple :: Parser ByteString ByteString
simple = (ByteString, ()) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ()) -> ByteString)
-> Parser ByteString (ByteString, ())
-> Parser ByteString ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser ByteString (ByteString, ())
forall a. Parser a -> Parser (ByteString, a)
A.match Parser ()
skipUnescaped
where
skipUnescaped :: Parser ()
skipUnescaped = Parser ByteString Word8 -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
A.skipMany1 (Parser ByteString Word8 -> Parser ())
-> Parser ByteString Word8 -> Parser ()
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> Parser ByteString Word8
A.satisfy Word8 -> Bool
notSepOrBslash
notSepOrBslash :: Word8 -> Bool
notSepOrBslash Word8
w = Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
sep Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
bslash
escaped :: Parser ByteString Word8
escaped = do
(Word8 -> Bool) -> Parser ()
A.skip (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
bslash)
(Word -> Parser ByteString Word8)
-> (Word8 -> Parser ByteString Word8)
-> Either Word Word8
-> Parser ByteString Word8
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Word -> Parser ByteString Word8
decodeDec Word8 -> Parser ByteString Word8
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Word Word8 -> Parser ByteString Word8)
-> Parser ByteString (Either Word Word8) -> Parser ByteString Word8
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser ByteString Word
-> Parser ByteString Word8 -> Parser ByteString (Either Word Word8)
forall (f :: * -> *) a b.
Alternative f =>
f a -> f b -> f (Either a b)
A.eitherP Parser ByteString Word
digit Parser ByteString Word8
A.anyWord8
where
digit :: Parser ByteString Word
digit = Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word)
-> Parser ByteString Word8 -> Parser ByteString Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Word8) -> (Word8 -> Bool) -> Parser ByteString Word8
forall a. (Word8 -> a) -> (a -> Bool) -> Parser a
A.satisfyWith (\Word8
n -> Word8
n Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
zero) (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<=Word8
9)
decodeDec :: Word -> Parser ByteString Word8
decodeDec Word
d =
Word -> Parser ByteString Word8
safeWord8 (Word -> Parser ByteString Word8)
-> Parser ByteString Word -> Parser ByteString Word8
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Word -> Word -> Word -> Word
trigraph Word
d (Word -> Word -> Word)
-> Parser ByteString Word -> Parser ByteString (Word -> Word)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word
digit Parser ByteString (Word -> Word)
-> Parser ByteString Word -> Parser ByteString Word
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Word
digit
where
trigraph :: Word -> Word -> Word -> Word
trigraph :: Word -> Word -> Word -> Word
trigraph Word
x Word
y Word
z = Word
100 Word -> Word -> Word
forall a. Num a => a -> a -> a
* Word
x Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
10 Word -> Word -> Word
forall a. Num a => a -> a -> a
* Word
y Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
z
safeWord8 :: Word -> A.Parser Word8
safeWord8 :: Word -> Parser ByteString Word8
safeWord8 Word
n | Word
n Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
255 = Parser ByteString Word8
forall a. Parser ByteString a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
| Bool
otherwise = Word8 -> Parser ByteString Word8
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> Parser ByteString Word8)
-> Word8 -> Parser ByteString Word8
forall a b. (a -> b) -> a -> b
$ Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n
labelEnd :: Word8 -> ByteString -> A.Parser ByteString
labelEnd :: Word8 -> ByteString -> Parser ByteString ByteString
labelEnd Word8
sep ByteString
acc =
(Word8 -> Bool) -> Parser ByteString Word8
A.satisfy (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
sep) Parser ByteString Word8
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> Parser ByteString ByteString
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
acc Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
Parser ()
forall t. Chunk t => Parser t ()
A.endOfInput Parser ()
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> Parser ByteString ByteString
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
acc
unparseLabel :: Word8 -> ByteString -> ByteString
unparseLabel :: Word8 -> ByteString -> ByteString
unparseLabel Word8
sep ByteString
label =
if (Word8 -> Bool) -> ByteString -> Bool
BS.all (Word8 -> Word8 -> Bool
isPlain Word8
sep) ByteString
label
then ByteString
label
else IResult ByteString ByteString -> ByteString
forall {i} {t}. Monoid i => IResult i t -> t
toResult (IResult ByteString ByteString -> ByteString)
-> IResult ByteString ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Parser ByteString ByteString
-> ByteString -> IResult ByteString ByteString
forall a. Parser a -> ByteString -> Result a
A.parse (Word8 -> ByteString -> Parser ByteString ByteString
labelUnparser Word8
sep ByteString
forall a. Monoid a => a
mempty) ByteString
label
where
toResult :: IResult i t -> t
toResult (A.Partial i -> IResult i t
c) = IResult i t -> t
toResult (i -> IResult i t
c i
forall a. Monoid a => a
mempty)
toResult (A.Done i
_ t
r) = t
r
toResult IResult i t
_ = DNSError -> t
forall a e. (HasCallStack, Exception e) => e -> a
E.throw DNSError
UnknownDNSError
labelUnparser :: Word8 -> ByteString -> A.Parser ByteString
labelUnparser :: Word8 -> ByteString -> Parser ByteString ByteString
labelUnparser Word8
sep ByteString
acc = do
acc' <- ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
mappend ByteString
acc (ByteString -> ByteString)
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option ByteString
forall a. Monoid a => a
mempty Parser ByteString ByteString
asis
A.endOfInput *> pure acc' <|> (esc >>= labelUnparser sep . mappend acc')
where
esc :: Parser ByteString ByteString
esc = do
w <- Parser ByteString Word8
A.anyWord8
if w <= 32 || w >= 127
then let (q100, r100) = w `divMod` 100
(q10, r10) = r100 `divMod` 10
in pure $ BS.pack [ bslash, zero + q100, zero + q10, zero + r10 ]
else pure $ BS.pack [ bslash, w ]
asis :: Parser ByteString ByteString
asis = ((ByteString, ()) -> ByteString)
-> Parser ByteString (ByteString, ())
-> Parser ByteString ByteString
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, ()) -> ByteString
forall a b. (a, b) -> a
fst (Parser ByteString (ByteString, ())
-> Parser ByteString ByteString)
-> Parser ByteString (ByteString, ())
-> Parser ByteString ByteString
forall a b. (a -> b) -> a -> b
$ Parser () -> Parser ByteString (ByteString, ())
forall a. Parser a -> Parser (ByteString, a)
A.match (Parser () -> Parser ByteString (ByteString, ()))
-> Parser () -> Parser ByteString (ByteString, ())
forall a b. (a -> b) -> a -> b
$ Parser ByteString Word8 -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
A.skipMany1 (Parser ByteString Word8 -> Parser ())
-> Parser ByteString Word8 -> Parser ()
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> Parser ByteString Word8
A.satisfy ((Word8 -> Bool) -> Parser ByteString Word8)
-> (Word8 -> Bool) -> Parser ByteString Word8
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Bool
isPlain Word8
sep
escSpecials :: ByteString
escSpecials :: ByteString
escSpecials = ByteString
"\"$();@\\"
isSpecial :: Word8 -> Word8 -> Bool
isSpecial :: Word8 -> Word8 -> Bool
isSpecial Word8
sep Word8
w = Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
sep Bool -> Bool -> Bool
|| Word8 -> ByteString -> Maybe Int
BS.elemIndex Word8
w ByteString
escSpecials Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Int
forall a. Maybe a
Nothing
isPlain :: Word8 -> Word8 -> Bool
isPlain :: Word8 -> Word8 -> Bool
isPlain Word8
sep Word8
w | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
127 = Bool
False
| Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
bslash = Bool
True
| Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
zero Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
semi = Bool
True
| Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
atsign Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
bslash = Bool
True
| Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
32 = Bool
False
| Word8 -> Word8 -> Bool
isSpecial Word8
sep Word8
w = Bool
False
| Bool
otherwise = Bool
True
zero, semi, atsign, bslash :: Word8
zero :: Word8
zero = 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
'0'
semi :: Word8
semi = 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
';'
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
'@'
bslash :: Word8
bslash = 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
'\\'