module Net.DNSBase.Internal.Flags
( DNSFlags
( QRflag
, AAflag
, TCflag
, RDflag
, RAflag
, Zflag
, ADflag
, CDflag
, DOflag
)
, basicFlags
, extendFlags
, extendedFlags
, extractOpcode
, extractRCODE
, hasAllFlags
, hasAnyFlags
, makeDNSFlags
, maskDNSFlags
, complementDNSFlags
, FlagOps
, setFlagBits
, clearFlagBits
, resetFlagBits
, emptyFlagOps
, applyFlagOps
, defaultQueryFlags
) where
import Net.DNSBase.Internal.RCODE
import Net.DNSBase.Internal.Present
import Net.DNSBase.Internal.Opcode
import Net.DNSBase.Internal.Util
newtype DNSFlags = DNSFlags Word32 deriving (DNSFlags -> DNSFlags -> Bool
(DNSFlags -> DNSFlags -> Bool)
-> (DNSFlags -> DNSFlags -> Bool) -> Eq DNSFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DNSFlags -> DNSFlags -> Bool
== :: DNSFlags -> DNSFlags -> Bool
$c/= :: DNSFlags -> DNSFlags -> Bool
/= :: DNSFlags -> DNSFlags -> Bool
Eq, Int -> DNSFlags -> ShowS
[DNSFlags] -> ShowS
DNSFlags -> String
(Int -> DNSFlags -> ShowS)
-> (DNSFlags -> String) -> ([DNSFlags] -> ShowS) -> Show DNSFlags
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DNSFlags -> ShowS
showsPrec :: Int -> DNSFlags -> ShowS
$cshow :: DNSFlags -> String
show :: DNSFlags -> String
$cshowList :: [DNSFlags] -> ShowS
showList :: [DNSFlags] -> ShowS
Show)
instance Semigroup DNSFlags where
(DNSFlags Word32
a) <> :: DNSFlags -> DNSFlags -> DNSFlags
<> (DNSFlags Word32
b) = Word32 -> DNSFlags
DNSFlags (Word32 -> DNSFlags) -> Word32 -> DNSFlags
forall a b. (a -> b) -> a -> b
$ (Word32
a Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
b) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
validBits
instance Monoid DNSFlags where
mempty :: DNSFlags
mempty = Word32 -> DNSFlags
DNSFlags Word32
0
instance Presentable DNSFlags where
present :: DNSFlags -> Builder -> Builder
present (DNSFlags Word32
fl) Builder
k =
case (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
fl (Int -> Bool) -> (Int -> Int) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall {a}. Integral a => a -> a
bitpos) [Int
0..Int
31] of
[] -> Char -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present Char
'-' Builder
k
(Int
v:[Int]
vs) -> Int -> Builder -> Builder
bitName Int
v (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ ((Builder -> Builder) -> Builder -> Builder)
-> Builder -> [Builder -> Builder] -> Builder
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
($) Builder
k [Int -> Builder -> Builder
bitNameSp Int
v' | Int
v' <- [Int]
vs]
where
bitpos :: a -> a
bitpos a
n = (a
15 a -> a -> a
forall a. Num a => a -> a -> a
- a
n) a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
32
bitNameSp :: Int -> Builder -> Builder
bitNameSp Int
n = Char -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present Char
' ' (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder -> Builder
bitName Int
n
bitName :: Int -> Builder -> Builder
bitName Int
n = case Word32 -> DNSFlags
DNSFlags (Word32 -> DNSFlags) -> Word32 -> DNSFlags
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
1 (Int -> Int
forall {a}. Integral a => a -> a
bitpos Int
n) of
DNSFlags
QRflag -> String -> Builder -> Builder
p String
"qr"
DNSFlags
AAflag -> String -> Builder -> Builder
p String
"aa"
DNSFlags
TCflag -> String -> Builder -> Builder
p String
"tc"
DNSFlags
RDflag -> String -> Builder -> Builder
p String
"rd"
DNSFlags
RAflag -> String -> Builder -> Builder
p String
"ra"
DNSFlags
Zflag -> String -> Builder -> Builder
p String
"z"
DNSFlags
ADflag -> String -> Builder -> Builder
p String
"ad"
DNSFlags
CDflag -> String -> Builder -> Builder
p String
"cd"
DNSFlags
DOflag -> String -> Builder -> Builder
p String
"do"
DNSFlags
_ -> String -> Builder -> Builder
p String
"bit" (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder -> Builder
forall a. Presentable a => a -> Builder -> Builder
present Int
n
p :: String -> Builder -> Builder
p = forall a. Presentable a => a -> Builder -> Builder
present @String
validBits :: Word32
validBits :: Word32
validBits = Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
0b0111_1000_0000_1111
extractRCODE :: Word16 -> RCODE
Word16
bits = Word16 -> RCODE
RCODE (Word16 -> RCODE) -> Word16 -> RCODE
forall a b. (a -> b) -> a -> b
$ Word16
bits Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0b1111
extractOpcode :: Word16 -> Opcode
Word16
bits = Word8 -> Opcode
Opcode (Word8 -> Opcode) -> (Word16 -> Word8) -> Word16 -> Opcode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Opcode) -> Word16 -> Opcode
forall a b. (a -> b) -> a -> b
$ (Word16
bits Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` Int
11) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0b1111
basicFlags :: Opcode
-> RCODE
-> DNSFlags
-> Word16
{-# INLINE basicFlags #-}
basicFlags :: Opcode -> RCODE -> DNSFlags -> Word16
basicFlags (Opcode Word8
op) (RCODE Word16
rc) (DNSFlags Word32
fl) =
Word16
opbits Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16
flbits Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16
rcbits
where
opbits :: Word16
opbits = (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
op Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0xF) Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
11
rcbits :: Word16
rcbits = (Word16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
rc Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0xF)
flbits :: Word16
flbits = (Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
fl Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0xFFFF)
extendedFlags :: DNSFlags
-> Word16
{-# INLINE extendedFlags #-}
extendedFlags :: DNSFlags -> Word16
extendedFlags (DNSFlags Word32
fl) = Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word16) -> Word32 -> Word16
forall a b. (a -> b) -> a -> b
$ Word32
fl Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
16 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFFFF
hasAllFlags :: DNSFlags -> DNSFlags -> Bool
hasAllFlags :: DNSFlags -> DNSFlags -> Bool
hasAllFlags DNSFlags
wanted DNSFlags
have = DNSFlags -> DNSFlags -> DNSFlags
maskDNSFlags DNSFlags
wanted DNSFlags
have DNSFlags -> DNSFlags -> Bool
forall a. Eq a => a -> a -> Bool
== DNSFlags
wanted
hasAnyFlags :: DNSFlags -> DNSFlags -> Bool
hasAnyFlags :: DNSFlags -> DNSFlags -> Bool
hasAnyFlags DNSFlags
wanted DNSFlags
have = DNSFlags -> DNSFlags -> DNSFlags
maskDNSFlags DNSFlags
wanted DNSFlags
have DNSFlags -> DNSFlags -> Bool
forall a. Eq a => a -> a -> Bool
/= DNSFlags
forall a. Monoid a => a
mempty
makeDNSFlags :: Integral a => a -> DNSFlags
makeDNSFlags :: forall a. Integral a => a -> DNSFlags
makeDNSFlags a
fl = Word32 -> DNSFlags
DNSFlags (Word32 -> DNSFlags) -> Word32 -> DNSFlags
forall a b. (a -> b) -> a -> b
$ a -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
fl Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
validBits
{-# INLINE makeDNSFlags #-}
maskDNSFlags :: DNSFlags -> DNSFlags -> DNSFlags
maskDNSFlags :: DNSFlags -> DNSFlags -> DNSFlags
maskDNSFlags (DNSFlags Word32
a) (DNSFlags Word32
b) = Word32 -> DNSFlags
DNSFlags (Word32 -> DNSFlags) -> Word32 -> DNSFlags
forall a b. (a -> b) -> a -> b
$ Word32
a Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
b
complementDNSFlags :: DNSFlags -> DNSFlags
complementDNSFlags :: DNSFlags -> DNSFlags
complementDNSFlags (DNSFlags Word32
fl) = Word32 -> DNSFlags
DNSFlags (Word32 -> DNSFlags) -> Word32 -> DNSFlags
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
fl Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
validBits
extendFlags :: DNSFlags -> Word16 -> DNSFlags
extendFlags :: DNSFlags -> Word16 -> DNSFlags
extendFlags (DNSFlags Word32
lo) Word16
hi =
Word32 -> DNSFlags
DNSFlags (Word32 -> DNSFlags) -> Word32 -> DNSFlags
forall a b. (a -> b) -> a -> b
$ (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
hi Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
lo Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFFFF)
pattern QRflag :: DNSFlags
pattern $mQRflag :: forall {r}. DNSFlags -> ((# #) -> r) -> ((# #) -> r) -> r
$bQRflag :: DNSFlags
QRflag = DNSFlags 0x8000
pattern AAflag :: DNSFlags
pattern $mAAflag :: forall {r}. DNSFlags -> ((# #) -> r) -> ((# #) -> r) -> r
$bAAflag :: DNSFlags
AAflag = DNSFlags 0x0400
pattern TCflag :: DNSFlags
pattern $mTCflag :: forall {r}. DNSFlags -> ((# #) -> r) -> ((# #) -> r) -> r
$bTCflag :: DNSFlags
TCflag = DNSFlags 0x0200
pattern RDflag :: DNSFlags
pattern $mRDflag :: forall {r}. DNSFlags -> ((# #) -> r) -> ((# #) -> r) -> r
$bRDflag :: DNSFlags
RDflag = DNSFlags 0x0100
pattern RAflag :: DNSFlags
pattern $mRAflag :: forall {r}. DNSFlags -> ((# #) -> r) -> ((# #) -> r) -> r
$bRAflag :: DNSFlags
RAflag = DNSFlags 0x0080
pattern Zflag :: DNSFlags
pattern $mZflag :: forall {r}. DNSFlags -> ((# #) -> r) -> ((# #) -> r) -> r
$bZflag :: DNSFlags
Zflag = DNSFlags 0x0040
pattern ADflag :: DNSFlags
pattern $mADflag :: forall {r}. DNSFlags -> ((# #) -> r) -> ((# #) -> r) -> r
$bADflag :: DNSFlags
ADflag = DNSFlags 0x0020
pattern CDflag :: DNSFlags
pattern $mCDflag :: forall {r}. DNSFlags -> ((# #) -> r) -> ((# #) -> r) -> r
$bCDflag :: DNSFlags
CDflag = DNSFlags 0x0010
pattern DOflag :: DNSFlags
pattern $mDOflag :: forall {r}. DNSFlags -> ((# #) -> r) -> ((# #) -> r) -> r
$bDOflag :: DNSFlags
DOflag = DNSFlags 0x80000000
data FlagOps =
FlagOps { FlagOps -> DNSFlags
clearBits :: DNSFlags
, FlagOps -> DNSFlags
setBits :: DNSFlags
} deriving (FlagOps -> FlagOps -> Bool
(FlagOps -> FlagOps -> Bool)
-> (FlagOps -> FlagOps -> Bool) -> Eq FlagOps
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FlagOps -> FlagOps -> Bool
== :: FlagOps -> FlagOps -> Bool
$c/= :: FlagOps -> FlagOps -> Bool
/= :: FlagOps -> FlagOps -> Bool
Eq, Int -> FlagOps -> ShowS
[FlagOps] -> ShowS
FlagOps -> String
(Int -> FlagOps -> ShowS)
-> (FlagOps -> String) -> ([FlagOps] -> ShowS) -> Show FlagOps
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FlagOps -> ShowS
showsPrec :: Int -> FlagOps -> ShowS
$cshow :: FlagOps -> String
show :: FlagOps -> String
$cshowList :: [FlagOps] -> ShowS
showList :: [FlagOps] -> ShowS
Show)
setFlagBits :: DNSFlags -> FlagOps -> FlagOps
setFlagBits :: DNSFlags -> FlagOps -> FlagOps
setFlagBits (DNSFlags Word32
fl) (FlagOps (DNSFlags Word32
fl0) (DNSFlags Word32
fl1)) =
DNSFlags -> DNSFlags -> FlagOps
FlagOps (Word32 -> DNSFlags
DNSFlags (Word32
fl0 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
fl))
(Word32 -> DNSFlags
DNSFlags (Word32
fl1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
fl))
clearFlagBits :: DNSFlags -> FlagOps -> FlagOps
clearFlagBits :: DNSFlags -> FlagOps -> FlagOps
clearFlagBits (DNSFlags Word32
fl) (FlagOps (DNSFlags Word32
fl0) (DNSFlags Word32
fl1)) =
DNSFlags -> DNSFlags -> FlagOps
FlagOps (Word32 -> DNSFlags
DNSFlags (Word32
fl0 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
fl))
(Word32 -> DNSFlags
DNSFlags (Word32
fl1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
fl))
resetFlagBits :: DNSFlags -> FlagOps -> FlagOps
resetFlagBits :: DNSFlags -> FlagOps -> FlagOps
resetFlagBits (DNSFlags Word32
fl) (FlagOps (DNSFlags Word32
fl0) (DNSFlags Word32
fl1)) =
DNSFlags -> DNSFlags -> FlagOps
FlagOps (Word32 -> DNSFlags
DNSFlags (Word32
fl0 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
fl))
(Word32 -> DNSFlags
DNSFlags (Word32
fl1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
fl))
emptyFlagOps :: FlagOps
emptyFlagOps :: FlagOps
emptyFlagOps = DNSFlags -> DNSFlags -> FlagOps
FlagOps (Word32 -> DNSFlags
DNSFlags Word32
0x0) (Word32 -> DNSFlags
DNSFlags Word32
0x0)
applyFlagOps :: FlagOps -> DNSFlags -> DNSFlags
applyFlagOps :: FlagOps -> DNSFlags -> DNSFlags
applyFlagOps (FlagOps (DNSFlags Word32
fl0) (DNSFlags Word32
fl1)) (DNSFlags Word32
fl) =
Word32 -> DNSFlags
DNSFlags (Word32
fl Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. (Word32 -> Word32
forall a. Bits a => a -> a
complement (Word32
fl0 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
validBits)) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
fl1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
validBits))
defaultQueryFlags :: DNSFlags
defaultQueryFlags :: DNSFlags
defaultQueryFlags = DNSFlags
RDflag