{-# LANGUAGE
BangPatterns
, RecordWildCards
, TransformListComp
#-}
module Network.DNS.Encode.Builders (
putDNSMessage
, putDNSFlags
, putHeader
, putDomain
, putMailbox
, putResourceRecord
) where
import Control.Monad.State (State, modify, execState, gets)
import qualified Control.Exception as E
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.CaseInsensitive as CI
import qualified Data.IP
import Data.IP (IP(..), fromIPv4, fromIPv6b, makeAddrRange)
import GHC.Exts (the, groupWith)
import Network.DNS.Imports
import Network.DNS.StateBinary
import Network.DNS.Types.Internal
putDNSMessage :: DNSMessage -> SPut
putDNSMessage :: DNSMessage -> SPut
putDNSMessage DNSMessage
msg = DNSHeader -> SPut
putHeader DNSHeader
hd
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> SPut
putNums
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat ((Question -> SPut) -> [Question] -> [SPut]
forall a b. (a -> b) -> [a] -> [b]
map Question -> SPut
putQuestion [Question]
qs)
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat ((ResourceRecord -> SPut) -> [ResourceRecord] -> [SPut]
forall a b. (a -> b) -> [a] -> [b]
map ResourceRecord -> SPut
putResourceRecord [ResourceRecord]
an)
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat ((ResourceRecord -> SPut) -> [ResourceRecord] -> [SPut]
forall a b. (a -> b) -> [a] -> [b]
map ResourceRecord -> SPut
putResourceRecord [ResourceRecord]
au)
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat ((ResourceRecord -> SPut) -> [ResourceRecord] -> [SPut]
forall a b. (a -> b) -> [a] -> [b]
map ResourceRecord -> SPut
putResourceRecord [ResourceRecord]
ad)
where
putNums :: SPut
putNums = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat ([SPut] -> SPut) -> [SPut] -> SPut
forall a b. (a -> b) -> a -> b
$ (Int -> SPut) -> [Int] -> [SPut]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> SPut
putInt16 [ [Question] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Question]
qs
, [ResourceRecord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResourceRecord]
an
, [ResourceRecord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResourceRecord]
au
, [ResourceRecord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResourceRecord]
ad
]
hm :: DNSHeader
hm = DNSMessage -> DNSHeader
header DNSMessage
msg
fl :: DNSFlags
fl = DNSHeader -> DNSFlags
flags DNSHeader
hm
eh :: EDNSheader
eh = DNSMessage -> EDNSheader
ednsHeader DNSMessage
msg
qs :: [Question]
qs = DNSMessage -> [Question]
question DNSMessage
msg
an :: [ResourceRecord]
an = DNSMessage -> [ResourceRecord]
answer DNSMessage
msg
au :: [ResourceRecord]
au = DNSMessage -> [ResourceRecord]
authority DNSMessage
msg
hd :: DNSHeader
hd = EDNSheader -> DNSHeader -> DNSHeader -> DNSHeader
forall a. EDNSheader -> a -> a -> a
ifEDNS EDNSheader
eh DNSHeader
hm (DNSHeader -> DNSHeader) -> DNSHeader -> DNSHeader
forall a b. (a -> b) -> a -> b
$ DNSHeader
hm { flags = fl { rcode = rc } }
rc :: RCODE
rc = EDNSheader -> RCODE -> RCODE -> RCODE
forall a. EDNSheader -> a -> a -> a
ifEDNS EDNSheader
eh (RCODE -> RCODE -> RCODE)
-> (RCODE -> RCODE) -> RCODE -> RCODE -> RCODE
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RCODE -> RCODE
forall a. a -> a
id (RCODE -> RCODE -> RCODE) -> (RCODE -> RCODE) -> RCODE -> RCODE
forall a b. (RCODE -> a -> b) -> (RCODE -> a) -> RCODE -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RCODE -> RCODE
nonEDNSrcode (RCODE -> RCODE) -> RCODE -> RCODE
forall a b. (a -> b) -> a -> b
$ DNSFlags -> RCODE
rcode DNSFlags
fl
where
nonEDNSrcode :: RCODE -> RCODE
nonEDNSrcode RCODE
code | RCODE -> Word16
fromRCODE RCODE
code Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
16 = RCODE
code
| Bool
otherwise = RCODE
FormatErr
ad :: [ResourceRecord]
ad = [ResourceRecord] -> [ResourceRecord]
prependOpt ([ResourceRecord] -> [ResourceRecord])
-> [ResourceRecord] -> [ResourceRecord]
forall a b. (a -> b) -> a -> b
$ DNSMessage -> [ResourceRecord]
additional DNSMessage
msg
where
prependOpt :: [ResourceRecord] -> [ResourceRecord]
prependOpt [ResourceRecord]
ads = EDNSheader
-> (EDNS -> [ResourceRecord])
-> [ResourceRecord]
-> [ResourceRecord]
forall a. EDNSheader -> (EDNS -> a) -> a -> a
mapEDNS EDNSheader
eh ([ResourceRecord] -> Word16 -> EDNS -> [ResourceRecord]
fromEDNS [ResourceRecord]
ads (Word16 -> EDNS -> [ResourceRecord])
-> Word16 -> EDNS -> [ResourceRecord]
forall a b. (a -> b) -> a -> b
$ RCODE -> Word16
fromRCODE RCODE
rc) [ResourceRecord]
ads
where
fromEDNS :: AdditionalRecords -> Word16 -> EDNS -> AdditionalRecords
fromEDNS :: [ResourceRecord] -> Word16 -> EDNS -> [ResourceRecord]
fromEDNS [ResourceRecord]
rrs Word16
rc' EDNS
edns = ByteString -> TYPE -> Word16 -> TTL -> RData -> ResourceRecord
ResourceRecord ByteString
name' TYPE
type' Word16
class' TTL
ttl' RData
rdata' ResourceRecord -> [ResourceRecord] -> [ResourceRecord]
forall a. a -> [a] -> [a]
: [ResourceRecord]
rrs
where
name' :: ByteString
name' = Char -> ByteString
BS.singleton Char
'.'
type' :: TYPE
type' = TYPE
OPT
class' :: Word16
class' = Word16
maxUdpSize Word16 -> Word16 -> Word16
forall a. Ord a => a -> a -> a
`min` (Word16
minUdpSize Word16 -> Word16 -> Word16
forall a. Ord a => a -> a -> a
`max` EDNS -> Word16
ednsUdpSize EDNS
edns)
ttl0' :: TTL
ttl0' = Word16 -> TTL
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
rc' Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0xff0) TTL -> Int -> TTL
forall a. Bits a => a -> Int -> a
`shiftL` Int
20
vers' :: TTL
vers' = Word8 -> TTL
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EDNS -> Word8
ednsVersion EDNS
edns) TTL -> Int -> TTL
forall a. Bits a => a -> Int -> a
`shiftL` Int
16
ttl' :: TTL
ttl'
| EDNS -> Bool
ednsDnssecOk EDNS
edns = TTL
ttl0' TTL -> Int -> TTL
forall a. Bits a => a -> Int -> a
`setBit` Int
15 TTL -> TTL -> TTL
forall a. Bits a => a -> a -> a
.|. TTL
vers'
| Bool
otherwise = TTL
ttl0' TTL -> TTL -> TTL
forall a. Bits a => a -> a -> a
.|. TTL
vers'
rdata' :: RData
rdata' = [OData] -> RData
RD_OPT ([OData] -> RData) -> [OData] -> RData
forall a b. (a -> b) -> a -> b
$ EDNS -> [OData]
ednsOptions EDNS
edns
putHeader :: DNSHeader -> SPut
DNSHeader
hdr = Word16 -> SPut
putIdentifier (DNSHeader -> Word16
identifier DNSHeader
hdr)
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> DNSFlags -> SPut
putDNSFlags (DNSHeader -> DNSFlags
flags DNSHeader
hdr)
where
putIdentifier :: Word16 -> SPut
putIdentifier = Word16 -> SPut
put16
putDNSFlags :: DNSFlags -> SPut
putDNSFlags :: DNSFlags -> SPut
putDNSFlags DNSFlags{Bool
RCODE
OPCODE
QorR
rcode :: DNSFlags -> RCODE
qOrR :: QorR
opcode :: OPCODE
authAnswer :: Bool
trunCation :: Bool
recDesired :: Bool
recAvailable :: Bool
rcode :: RCODE
authenData :: Bool
chkDisable :: Bool
qOrR :: DNSFlags -> QorR
opcode :: DNSFlags -> OPCODE
authAnswer :: DNSFlags -> Bool
trunCation :: DNSFlags -> Bool
recDesired :: DNSFlags -> Bool
recAvailable :: DNSFlags -> Bool
authenData :: DNSFlags -> Bool
chkDisable :: DNSFlags -> Bool
..} = Word16 -> SPut
put16 Word16
word
where
set :: Word16 -> State Word16 ()
set :: Word16 -> State Word16 ()
set Word16
byte = (Word16 -> Word16) -> State Word16 ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16
byte)
st :: State Word16 ()
st :: State Word16 ()
st = [State Word16 ()] -> State Word16 ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
[ Word16 -> State Word16 ()
set (RCODE -> Word16
fromRCODE RCODE
rcode Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x0f)
, Bool -> State Word16 () -> State Word16 ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
chkDisable (State Word16 () -> State Word16 ())
-> State Word16 () -> State Word16 ()
forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (Int -> Word16
forall a. Bits a => Int -> a
bit Int
4)
, Bool -> State Word16 () -> State Word16 ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
authenData (State Word16 () -> State Word16 ())
-> State Word16 () -> State Word16 ()
forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (Int -> Word16
forall a. Bits a => Int -> a
bit Int
5)
, Bool -> State Word16 () -> State Word16 ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
recAvailable (State Word16 () -> State Word16 ())
-> State Word16 () -> State Word16 ()
forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (Int -> Word16
forall a. Bits a => Int -> a
bit Int
7)
, Bool -> State Word16 () -> State Word16 ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
recDesired (State Word16 () -> State Word16 ())
-> State Word16 () -> State Word16 ()
forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (Int -> Word16
forall a. Bits a => Int -> a
bit Int
8)
, Bool -> State Word16 () -> State Word16 ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
trunCation (State Word16 () -> State Word16 ())
-> State Word16 () -> State Word16 ()
forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (Int -> Word16
forall a. Bits a => Int -> a
bit Int
9)
, Bool -> State Word16 () -> State Word16 ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
authAnswer (State Word16 () -> State Word16 ())
-> State Word16 () -> State Word16 ()
forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (Int -> Word16
forall a. Bits a => Int -> a
bit Int
10)
, Word16 -> State Word16 ()
set (OPCODE -> Word16
fromOPCODE OPCODE
opcode Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
11)
, Bool -> State Word16 () -> State Word16 ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QorR
qOrRQorR -> QorR -> Bool
forall a. Eq a => a -> a -> Bool
==QorR
QR_Response) (State Word16 () -> State Word16 ())
-> State Word16 () -> State Word16 ()
forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (Int -> Word16
forall a. Bits a => Int -> a
bit Int
15)
]
word :: Word16
word = State Word16 () -> Word16 -> Word16
forall s a. State s a -> s -> s
execState State Word16 ()
st Word16
0
putQuestion :: Question -> SPut
putQuestion :: Question -> SPut
putQuestion Question{ByteString
TYPE
qname :: ByteString
qtype :: TYPE
qname :: Question -> ByteString
qtype :: Question -> TYPE
..} = ByteString -> SPut
putDomain ByteString
qname
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> Word16 -> SPut
put16 (TYPE -> Word16
fromTYPE TYPE
qtype)
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> Word16 -> SPut
put16 Word16
classIN
putResourceRecord :: ResourceRecord -> SPut
putResourceRecord :: ResourceRecord -> SPut
putResourceRecord ResourceRecord{Word16
TTL
ByteString
RData
TYPE
rrname :: ByteString
rrtype :: TYPE
rrclass :: Word16
rrttl :: TTL
rdata :: RData
rrname :: ResourceRecord -> ByteString
rrtype :: ResourceRecord -> TYPE
rrclass :: ResourceRecord -> Word16
rrttl :: ResourceRecord -> TTL
rdata :: ResourceRecord -> RData
..} = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [
ByteString -> SPut
putDomain ByteString
rrname
, Word16 -> SPut
put16 (TYPE -> Word16
fromTYPE TYPE
rrtype)
, Word16 -> SPut
put16 Word16
rrclass
, TTL -> SPut
put32 TTL
rrttl
, RData -> SPut
putResourceRData RData
rdata
]
where
putResourceRData :: RData -> SPut
putResourceRData :: RData -> SPut
putResourceRData RData
rd = do
Int -> State WState ()
addPositionW Int
2
Builder
rDataBuilder <- RData -> SPut
putRData RData
rd
let rdataLength :: Int16
rdataLength = Int64 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int16) -> (Builder -> Int64) -> Builder -> Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
LBS.length (ByteString -> Int64)
-> (Builder -> ByteString) -> Builder -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString (Builder -> Int16) -> Builder -> Int16
forall a b. (a -> b) -> a -> b
$ Builder
rDataBuilder
let rlenBuilder :: Builder
rlenBuilder = Int16 -> Builder
BB.int16BE Int16
rdataLength
Builder -> SPut
forall a. a -> StateT WState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> SPut) -> Builder -> SPut
forall a b. (a -> b) -> a -> b
$ Builder
rlenBuilder Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
rDataBuilder
putRData :: RData -> SPut
putRData :: RData -> SPut
putRData RData
rd = case RData
rd of
RD_A IPv4
address -> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat ([SPut] -> SPut) -> [SPut] -> SPut
forall a b. (a -> b) -> a -> b
$ (Int -> SPut) -> [Int] -> [SPut]
forall a b. (a -> b) -> [a] -> [b]
map Int -> SPut
putInt8 (IPv4 -> [Int]
fromIPv4 IPv4
address)
RD_NS ByteString
nsdname -> ByteString -> SPut
putDomain ByteString
nsdname
RD_CNAME ByteString
cname -> ByteString -> SPut
putDomain ByteString
cname
RD_SOA ByteString
a ByteString
b TTL
c TTL
d TTL
e TTL
f TTL
g -> ByteString -> ByteString -> TTL -> TTL -> TTL -> TTL -> TTL -> SPut
putSOA ByteString
a ByteString
b TTL
c TTL
d TTL
e TTL
f TTL
g
RD_NULL ByteString
bytes -> ByteString -> SPut
putByteString ByteString
bytes
RD_PTR ByteString
ptrdname -> ByteString -> SPut
putDomain ByteString
ptrdname
RD_MX Word16
pref ByteString
exch -> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [Word16 -> SPut
put16 Word16
pref, ByteString -> SPut
putDomain ByteString
exch]
RD_TXT ByteString
textstring -> ByteString -> SPut
putTXT ByteString
textstring
RD_RP ByteString
mbox ByteString
dname -> ByteString -> SPut
putMailbox ByteString
mbox SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> ByteString -> SPut
putDomain ByteString
dname
RD_AAAA IPv6
address -> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat ([SPut] -> SPut) -> [SPut] -> SPut
forall a b. (a -> b) -> a -> b
$ (Int -> SPut) -> [Int] -> [SPut]
forall a b. (a -> b) -> [a] -> [b]
map Int -> SPut
putInt8 (IPv6 -> [Int]
fromIPv6b IPv6
address)
RD_SRV Word16
pri Word16
wei Word16
prt ByteString
tgt -> Word16 -> Word16 -> Word16 -> ByteString -> SPut
putSRV Word16
pri Word16
wei Word16
prt ByteString
tgt
RD_DNAME ByteString
dname -> ByteString -> SPut
putDomain ByteString
dname
RD_OPT [OData]
options -> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat ([SPut] -> SPut) -> [SPut] -> SPut
forall a b. (a -> b) -> a -> b
$ (OData -> SPut) -> [OData] -> [SPut]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OData -> SPut
putOData [OData]
options
RD_DS Word16
kt Word8
ka Word8
dt ByteString
d -> Word16 -> Word8 -> Word8 -> ByteString -> SPut
putDS Word16
kt Word8
ka Word8
dt ByteString
d
RD_CDS Word16
kt Word8
ka Word8
dt ByteString
d -> Word16 -> Word8 -> Word8 -> ByteString -> SPut
putDS Word16
kt Word8
ka Word8
dt ByteString
d
RD_RRSIG RD_RRSIG
rrsig -> RD_RRSIG -> SPut
putRRSIG RD_RRSIG
rrsig
RD_NSEC ByteString
next [TYPE]
types -> ByteString -> SPut
putDomain ByteString
next SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> [TYPE] -> SPut
putNsecTypes [TYPE]
types
RD_DNSKEY Word16
f Word8
p Word8
alg ByteString
key -> Word16 -> Word8 -> Word8 -> ByteString -> SPut
putDNSKEY Word16
f Word8
p Word8
alg ByteString
key
RD_CDNSKEY Word16
f Word8
p Word8
alg ByteString
key -> Word16 -> Word8 -> Word8 -> ByteString -> SPut
putDNSKEY Word16
f Word8
p Word8
alg ByteString
key
RD_NSEC3 Word8
a Word8
f Word16
i ByteString
s ByteString
h [TYPE]
types -> Word8
-> Word8 -> Word16 -> ByteString -> ByteString -> [TYPE] -> SPut
putNSEC3 Word8
a Word8
f Word16
i ByteString
s ByteString
h [TYPE]
types
RD_NSEC3PARAM Word8
a Word8
f Word16
iter ByteString
salt -> Word8 -> Word8 -> Word16 -> ByteString -> SPut
putNSEC3PARAM Word8
a Word8
f Word16
iter ByteString
salt
RD_TLSA Word8
u Word8
s Word8
m ByteString
dgst -> Word8 -> Word8 -> Word8 -> ByteString -> SPut
putTLSA Word8
u Word8
s Word8
m ByteString
dgst
RD_CAA Word8
f CI ByteString
t ByteString
v -> Word8 -> CI ByteString -> ByteString -> SPut
putCAA Word8
f CI ByteString
t ByteString
v
UnknownRData ByteString
bytes -> ByteString -> SPut
putByteString ByteString
bytes
where
putSOA :: ByteString -> ByteString -> TTL -> TTL -> TTL -> TTL -> TTL -> SPut
putSOA ByteString
mn ByteString
mr TTL
serial TTL
refresh TTL
retry TTL
expire TTL
minttl = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
[ ByteString -> SPut
putDomain ByteString
mn
, ByteString -> SPut
putMailbox ByteString
mr
, TTL -> SPut
put32 TTL
serial
, TTL -> SPut
put32 TTL
refresh
, TTL -> SPut
put32 TTL
retry
, TTL -> SPut
put32 TTL
expire
, TTL -> SPut
put32 TTL
minttl
]
putTXT :: ByteString -> SPut
putTXT ByteString
textstring =
let (!ByteString
h, !ByteString
t) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
255 ByteString
textstring
in ByteString -> SPut
putByteStringWithLength ByteString
h SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> if ByteString -> Bool
BS.null ByteString
t
then SPut
forall a. Monoid a => a
mempty
else ByteString -> SPut
putTXT ByteString
t
putSRV :: Word16 -> Word16 -> Word16 -> ByteString -> SPut
putSRV Word16
priority Word16
weight Word16
port ByteString
target = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
[ Word16 -> SPut
put16 Word16
priority
, Word16 -> SPut
put16 Word16
weight
, Word16 -> SPut
put16 Word16
port
, ByteString -> SPut
putDomain ByteString
target
]
putDS :: Word16 -> Word8 -> Word8 -> ByteString -> SPut
putDS Word16
keytag Word8
keyalg Word8
digestType ByteString
digest = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
[ Word16 -> SPut
put16 Word16
keytag
, Word8 -> SPut
put8 Word8
keyalg
, Word8 -> SPut
put8 Word8
digestType
, ByteString -> SPut
putByteString ByteString
digest
]
putRRSIG :: RD_RRSIG -> SPut
putRRSIG RDREP_RRSIG{Int64
Word8
Word16
TTL
ByteString
TYPE
rrsigType :: TYPE
rrsigKeyAlg :: Word8
rrsigNumLabels :: Word8
rrsigTTL :: TTL
rrsigExpiration :: Int64
rrsigInception :: Int64
rrsigKeyTag :: Word16
rrsigZone :: ByteString
rrsigValue :: ByteString
rrsigType :: RD_RRSIG -> TYPE
rrsigKeyAlg :: RD_RRSIG -> Word8
rrsigNumLabels :: RD_RRSIG -> Word8
rrsigTTL :: RD_RRSIG -> TTL
rrsigExpiration :: RD_RRSIG -> Int64
rrsigInception :: RD_RRSIG -> Int64
rrsigKeyTag :: RD_RRSIG -> Word16
rrsigZone :: RD_RRSIG -> ByteString
rrsigValue :: RD_RRSIG -> ByteString
..} = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
[ Word16 -> SPut
put16 (Word16 -> SPut) -> Word16 -> SPut
forall a b. (a -> b) -> a -> b
$ TYPE -> Word16
fromTYPE TYPE
rrsigType
, Word8 -> SPut
put8 Word8
rrsigKeyAlg
, Word8 -> SPut
put8 Word8
rrsigNumLabels
, TTL -> SPut
put32 TTL
rrsigTTL
, TTL -> SPut
put32 (TTL -> SPut) -> TTL -> SPut
forall a b. (a -> b) -> a -> b
$ Int64 -> TTL
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
rrsigExpiration
, TTL -> SPut
put32 (TTL -> SPut) -> TTL -> SPut
forall a b. (a -> b) -> a -> b
$ Int64 -> TTL
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
rrsigInception
, Word16 -> SPut
put16 Word16
rrsigKeyTag
, ByteString -> SPut
putDomain ByteString
rrsigZone
, ByteString -> SPut
putByteString ByteString
rrsigValue
]
putDNSKEY :: Word16 -> Word8 -> Word8 -> ByteString -> SPut
putDNSKEY Word16
flags Word8
protocol Word8
alg ByteString
key = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
[ Word16 -> SPut
put16 Word16
flags
, Word8 -> SPut
put8 Word8
protocol
, Word8 -> SPut
put8 Word8
alg
, ByteString -> SPut
putByteString ByteString
key
]
putNSEC3 :: Word8
-> Word8 -> Word16 -> ByteString -> ByteString -> [TYPE] -> SPut
putNSEC3 Word8
alg Word8
flags Word16
iterations ByteString
salt ByteString
hash [TYPE]
types = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
[ Word8 -> SPut
put8 Word8
alg
, Word8 -> SPut
put8 Word8
flags
, Word16 -> SPut
put16 Word16
iterations
, ByteString -> SPut
putByteStringWithLength ByteString
salt
, ByteString -> SPut
putByteStringWithLength ByteString
hash
, [TYPE] -> SPut
putNsecTypes [TYPE]
types
]
putNSEC3PARAM :: Word8 -> Word8 -> Word16 -> ByteString -> SPut
putNSEC3PARAM Word8
alg Word8
flags Word16
iterations ByteString
salt = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
[ Word8 -> SPut
put8 Word8
alg
, Word8 -> SPut
put8 Word8
flags
, Word16 -> SPut
put16 Word16
iterations
, ByteString -> SPut
putByteStringWithLength ByteString
salt
]
putTLSA :: Word8 -> Word8 -> Word8 -> ByteString -> SPut
putTLSA Word8
usage Word8
selector Word8
mtype ByteString
assocData = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
[ Word8 -> SPut
put8 Word8
usage
, Word8 -> SPut
put8 Word8
selector
, Word8 -> SPut
put8 Word8
mtype
, ByteString -> SPut
putByteString ByteString
assocData
]
putCAA :: Word8 -> CI ByteString -> ByteString -> SPut
putCAA Word8
flags CI ByteString
tag ByteString
value = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
[ Word8 -> SPut
put8 Word8
flags
, ByteString -> SPut
putByteStringWithLength (CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
tag)
, ByteString -> SPut
putByteString ByteString
value
]
putNsecTypes :: [TYPE] -> SPut
putNsecTypes :: [TYPE] -> SPut
putNsecTypes [TYPE]
types = [Word16] -> SPut
putTypeList ([Word16] -> SPut) -> [Word16] -> SPut
forall a b. (a -> b) -> a -> b
$ (TYPE -> Word16) -> [TYPE] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map TYPE -> Word16
fromTYPE [TYPE]
types
where
putTypeList :: [Word16] -> SPut
putTypeList :: [Word16] -> SPut
putTypeList [Word16]
ts =
[SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [ Int -> [Int] -> SPut
putWindow ([Int] -> Int
forall a. Eq a => [a] -> a
the [Int]
top8) [Int]
bot8 |
Word16
t <- [Word16]
ts,
let top8 :: Int
top8 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
t Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
8,
let bot8 :: Int
bot8 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
t Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xff,
then group by Int
top8
using (a -> Int) -> [a] -> [[a]]
((Int, Int) -> Int) -> [(Int, Int)] -> [[(Int, Int)]]
forall {a}. (a -> Int) -> [a] -> [[a]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith ]
putWindow :: Int -> [Int] -> SPut
putWindow :: Int -> [Int] -> SPut
putWindow Int
top8 [Int]
bot8s =
let blks :: Int
blks = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
bot8s Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
3
in Int -> SPut
putInt8 Int
top8
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> Word8 -> SPut
put8 (Word8
1 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
blks)
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> Int -> [(Int, Word8)] -> SPut
putBits Int
0 [ ([Int] -> Int
forall a. Eq a => [a] -> a
the [Int]
block, (Word8 -> Int -> Word8) -> Word8 -> [Int] -> Word8
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
mergeBits Word8
0 [Int]
bot8) |
Int
bot8 <- [Int]
bot8s,
let block :: Int
block = Int
bot8 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
3,
then group by Int
block
using (a -> Int) -> [a] -> [[a]]
((Int, Int) -> Int) -> [(Int, Int)] -> [[(Int, Int)]]
forall {a}. (a -> Int) -> [a] -> [[a]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith ]
where
mergeBits :: a -> Int -> a
mergeBits a
acc Int
b = a -> Int -> a
forall a. Bits a => a -> Int -> a
setBit a
acc (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bInt -> Int -> Int
forall a. Bits a => a -> a -> a
.&.Int
0x07)
putBits :: Int -> [(Int, Word8)] -> SPut
putBits :: Int -> [(Int, Word8)] -> SPut
putBits Int
_ [] = Builder -> SPut
forall a. a -> StateT WState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
forall a. Monoid a => a
mempty
putBits Int
n ((Int
block, Word8
octet) : [(Int, Word8)]
rest) =
Int -> Word8 -> SPut
putReplicate (Int
blockInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n) Word8
0
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> Word8 -> SPut
put8 Word8
octet
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> Int -> [(Int, Word8)] -> SPut
putBits (Int
block Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Int, Word8)]
rest
putODWords :: Word16 -> [Word8] -> SPut
putODWords :: Word16 -> [Word8] -> SPut
putODWords Word16
code [Word8]
ws =
[SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [ Word16 -> SPut
put16 Word16
code
, Int -> SPut
putInt16 (Int -> SPut) -> Int -> SPut
forall a b. (a -> b) -> a -> b
$ [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
ws
, [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat ([SPut] -> SPut) -> [SPut] -> SPut
forall a b. (a -> b) -> a -> b
$ (Word8 -> SPut) -> [Word8] -> [SPut]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> SPut
put8 [Word8]
ws
]
putODBytes :: Word16 -> ByteString -> SPut
putODBytes :: Word16 -> ByteString -> SPut
putODBytes Word16
code ByteString
bs =
[SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [ Word16 -> SPut
put16 Word16
code
, Int -> SPut
putInt16 (Int -> SPut) -> Int -> SPut
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs
, ByteString -> SPut
putByteString ByteString
bs
]
putOData :: OData -> SPut
putOData :: OData -> SPut
putOData (OD_NSID ByteString
nsid) = Word16 -> ByteString -> SPut
putODBytes (OptCode -> Word16
fromOptCode OptCode
NSID) ByteString
nsid
putOData (OD_DAU [Word8]
as) = Word16 -> [Word8] -> SPut
putODWords (OptCode -> Word16
fromOptCode OptCode
DAU) [Word8]
as
putOData (OD_DHU [Word8]
hs) = Word16 -> [Word8] -> SPut
putODWords (OptCode -> Word16
fromOptCode OptCode
DHU) [Word8]
hs
putOData (OD_N3U [Word8]
hs) = Word16 -> [Word8] -> SPut
putODWords (OptCode -> Word16
fromOptCode OptCode
N3U) [Word8]
hs
putOData (OD_ClientSubnet Word8
srcBits Word8
scpBits IP
ip) =
let octets :: Int
octets = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ (Word8
srcBits Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
7) Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` Word8
8
prefix :: a -> a
prefix a
addr = 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
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
srcBits
(Word16
family, [Int]
raw) = case IP
ip of
IPv4 IPv4
ip4 -> (Word16
1, Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
octets ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ IPv4 -> [Int]
fromIPv4 (IPv4 -> [Int]) -> IPv4 -> [Int]
forall a b. (a -> b) -> a -> b
$ IPv4 -> IPv4
forall {a}. Addr a => a -> a
prefix IPv4
ip4)
IPv6 IPv6
ip6 -> (Word16
2, Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
octets ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ IPv6 -> [Int]
fromIPv6b (IPv6 -> [Int]) -> IPv6 -> [Int]
forall a b. (a -> b) -> a -> b
$ IPv6 -> IPv6
forall {a}. Addr a => a -> a
prefix IPv6
ip6)
dataLen :: Int
dataLen = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
octets
in [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [ Word16 -> SPut
put16 (Word16 -> SPut) -> Word16 -> SPut
forall a b. (a -> b) -> a -> b
$ OptCode -> Word16
fromOptCode OptCode
ClientSubnet
, Int -> SPut
putInt16 Int
dataLen
, Word16 -> SPut
put16 Word16
family
, Word8 -> SPut
put8 Word8
srcBits
, Word8 -> SPut
put8 Word8
scpBits
, [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat ([SPut] -> SPut) -> [SPut] -> SPut
forall a b. (a -> b) -> a -> b
$ (Int -> SPut) -> [Int] -> [SPut]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> SPut
putInt8 [Int]
raw
]
putOData (OD_ECSgeneric Word16
family Word8
srcBits Word8
scpBits ByteString
addr) =
[SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [ Word16 -> SPut
put16 (Word16 -> SPut) -> Word16 -> SPut
forall a b. (a -> b) -> a -> b
$ OptCode -> Word16
fromOptCode OptCode
ClientSubnet
, Int -> SPut
putInt16 (Int -> SPut) -> Int -> SPut
forall a b. (a -> b) -> a -> b
$ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
addr
, Word16 -> SPut
put16 Word16
family
, Word8 -> SPut
put8 Word8
srcBits
, Word8 -> SPut
put8 Word8
scpBits
, ByteString -> SPut
putByteString ByteString
addr
]
putOData (UnknownOData Word16
code ByteString
bs) = Word16 -> ByteString -> SPut
putODBytes Word16
code ByteString
bs
putByteStringWithLength :: BS.ByteString -> SPut
putByteStringWithLength :: ByteString -> SPut
putByteStringWithLength ByteString
bs = Int -> SPut
putInt8 (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs)
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> ByteString -> SPut
putByteString ByteString
bs
rootDomain :: Domain
rootDomain :: ByteString
rootDomain = String -> ByteString
BS.pack String
"."
putDomain :: Domain -> SPut
putDomain :: ByteString -> SPut
putDomain = Char -> ByteString -> SPut
putDomain' Char
'.'
putMailbox :: Mailbox -> SPut
putMailbox :: ByteString -> SPut
putMailbox = Char -> ByteString -> SPut
putDomain' Char
'@'
putDomain' :: Char -> ByteString -> SPut
putDomain' :: Char -> ByteString -> SPut
putDomain' Char
sep ByteString
dom
| ByteString -> Bool
BS.null ByteString
dom Bool -> Bool -> Bool
|| ByteString
dom ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
rootDomain = Word8 -> SPut
put8 Word8
0
| Bool
otherwise = do
Maybe Int
mpos <- ByteString -> State WState (Maybe Int)
wsPop ByteString
dom
Int
cur <- (WState -> Int) -> StateT WState Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WState -> Int
wsPosition
case Maybe Int
mpos of
Just Int
pos -> Int -> SPut
putPointer Int
pos
Maybe Int
Nothing -> do
Bool -> State WState () -> State WState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cur Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x3fff) (State WState () -> State WState ())
-> State WState () -> State WState ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> State WState ()
wsPush ByteString
dom Int
cur
[SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> SPut
putPartialDomain ByteString
hd
, Char -> ByteString -> SPut
putDomain' Char
'.' ByteString
tl
]
where
(ByteString
hd, ByteString
tl) = Word8 -> (ByteString, ByteString)
loop (Char -> Word8
c2w Char
sep)
where
loop :: Word8 -> (ByteString, ByteString)
loop Word8
w = case Word8 -> ByteString -> Either DNSError (ByteString, ByteString)
parseLabel Word8
w ByteString
dom of
Right (ByteString, ByteString)
p | Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0x2e Bool -> Bool -> Bool
&& ByteString -> Bool
BS.null ((ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (ByteString, ByteString)
p) -> Word8 -> (ByteString, ByteString)
loop Word8
0x2e
| Bool
otherwise -> (ByteString, ByteString)
p
Left DNSError
e -> DNSError -> (ByteString, ByteString)
forall a e. Exception e => e -> a
E.throw DNSError
e
c2w :: Char -> Word8
c2w = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum
putPointer :: Int -> SPut
putPointer :: Int -> SPut
putPointer Int
pos = Int -> SPut
putInt16 (Int
pos Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
0xc000)
putPartialDomain :: Domain -> SPut
putPartialDomain :: ByteString -> SPut
putPartialDomain = ByteString -> SPut
putByteStringWithLength