{-# 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 Data.ByteString.Builder as BB
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
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 msg :: 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> SPut
putInt16 [ [Question] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Question]
qs
, [ResourceRecord] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResourceRecord]
an
, [ResourceRecord] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResourceRecord]
au
, [ResourceRecord] -> 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 :: DNSFlags
flags = DNSFlags
fl { rcode :: RCODE
rcode = 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 (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 code :: RCODE
code | RCODE -> Word16
fromRCODE RCODE
code Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< 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 ads :: [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 rrs :: [ResourceRecord]
rrs rc' :: Word16
rc' edns :: EDNS
edns = Domain -> TYPE -> Word16 -> TTL -> RData -> ResourceRecord
ResourceRecord Domain
name' TYPE
type' Word16
class' TTL
ttl' RData
rdata' ResourceRecord -> [ResourceRecord] -> [ResourceRecord]
forall a. a -> [a] -> [a]
: [ResourceRecord]
rrs
where
name' :: Domain
name' = Char -> Domain
BS.singleton '.'
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
.&. 0xff0) TTL -> Int -> TTL
forall a. Bits a => a -> Int -> a
`shiftL` 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` 16
ttl' :: TTL
ttl'
| EDNS -> Bool
ednsDnssecOk EDNS
edns = TTL
ttl0' TTL -> Int -> TTL
forall a. Bits a => a -> Int -> a
`setBit` 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
hdr :: 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{..} = Word16 -> SPut
put16 Word16
word
where
set :: Word16 -> State Word16 ()
set :: Word16 -> State Word16 ()
set byte :: 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
.&. 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 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 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 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 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 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 10)
, Word16 -> State Word16 ()
set (OPCODE -> Word16
fromOPCODE OPCODE
opcode Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` 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 15)
]
word :: Word16
word = State Word16 () -> Word16 -> Word16
forall s a. State s a -> s -> s
execState State Word16 ()
st 0
putQuestion :: Question -> SPut
putQuestion :: Question -> SPut
putQuestion Question{..} = Domain -> SPut
putDomain Domain
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{..} = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [
Domain -> SPut
putDomain Domain
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 rd :: RData
rd = do
Int -> State WState ()
addPositionW 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 (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 rd :: RData
rd = case RData
rd of
RD_A address :: 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 nsdname :: Domain
nsdname -> Domain -> SPut
putDomain Domain
nsdname
RD_CNAME cname :: Domain
cname -> Domain -> SPut
putDomain Domain
cname
RD_SOA a :: Domain
a b :: Domain
b c :: TTL
c d :: TTL
d e :: TTL
e f :: TTL
f g :: TTL
g -> Domain -> Domain -> TTL -> TTL -> TTL -> TTL -> TTL -> SPut
putSOA Domain
a Domain
b TTL
c TTL
d TTL
e TTL
f TTL
g
RD_NULL bytes :: Domain
bytes -> Domain -> SPut
putByteString Domain
bytes
RD_PTR ptrdname :: Domain
ptrdname -> Domain -> SPut
putDomain Domain
ptrdname
RD_MX pref :: Word16
pref exch :: Domain
exch -> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [Word16 -> SPut
put16 Word16
pref, Domain -> SPut
putDomain Domain
exch]
RD_TXT textstring :: Domain
textstring -> Domain -> SPut
putTXT Domain
textstring
RD_AAAA address :: 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 pri :: Word16
pri wei :: Word16
wei prt :: Word16
prt tgt :: Domain
tgt -> Word16 -> Word16 -> Word16 -> Domain -> SPut
putSRV Word16
pri Word16
wei Word16
prt Domain
tgt
RD_DNAME dname :: Domain
dname -> Domain -> SPut
putDomain Domain
dname
RD_OPT options :: [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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OData -> SPut
putOData [OData]
options
RD_DS kt :: Word16
kt ka :: Word8
ka dt :: Word8
dt d :: Domain
d -> Word16 -> Word8 -> Word8 -> Domain -> SPut
putDS Word16
kt Word8
ka Word8
dt Domain
d
RD_CDS kt :: Word16
kt ka :: Word8
ka dt :: Word8
dt d :: Domain
d -> Word16 -> Word8 -> Word8 -> Domain -> SPut
putDS Word16
kt Word8
ka Word8
dt Domain
d
RD_RRSIG rrsig :: RD_RRSIG
rrsig -> RD_RRSIG -> SPut
putRRSIG RD_RRSIG
rrsig
RD_NSEC next :: Domain
next types :: [TYPE]
types -> Domain -> SPut
putDomain Domain
next SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> [TYPE] -> SPut
putNsecTypes [TYPE]
types
RD_DNSKEY f :: Word16
f p :: Word8
p alg :: Word8
alg key :: Domain
key -> Word16 -> Word8 -> Word8 -> Domain -> SPut
putDNSKEY Word16
f Word8
p Word8
alg Domain
key
RD_CDNSKEY f :: Word16
f p :: Word8
p alg :: Word8
alg key :: Domain
key -> Word16 -> Word8 -> Word8 -> Domain -> SPut
putDNSKEY Word16
f Word8
p Word8
alg Domain
key
RD_NSEC3 a :: Word8
a f :: Word8
f i :: Word16
i s :: Domain
s h :: Domain
h types :: [TYPE]
types -> Word8 -> Word8 -> Word16 -> Domain -> Domain -> [TYPE] -> SPut
putNSEC3 Word8
a Word8
f Word16
i Domain
s Domain
h [TYPE]
types
RD_NSEC3PARAM a :: Word8
a f :: Word8
f iter :: Word16
iter salt :: Domain
salt -> Word8 -> Word8 -> Word16 -> Domain -> SPut
putNSEC3PARAM Word8
a Word8
f Word16
iter Domain
salt
RD_TLSA u :: Word8
u s :: Word8
s m :: Word8
m dgst :: Domain
dgst -> Word8 -> Word8 -> Word8 -> Domain -> SPut
putTLSA Word8
u Word8
s Word8
m Domain
dgst
UnknownRData bytes :: Domain
bytes -> Domain -> SPut
putByteString Domain
bytes
where
putSOA :: Domain -> Domain -> TTL -> TTL -> TTL -> TTL -> TTL -> SPut
putSOA mn :: Domain
mn mr :: Domain
mr serial :: TTL
serial refresh :: TTL
refresh retry :: TTL
retry expire :: TTL
expire minttl :: TTL
minttl = [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
[ Domain -> SPut
putDomain Domain
mn
, Domain -> SPut
putMailbox Domain
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 :: Domain -> SPut
putTXT textstring :: Domain
textstring =
let (!Domain
h, !Domain
t) = Int -> Domain -> (Domain, Domain)
BS.splitAt 255 Domain
textstring
in Domain -> SPut
putByteStringWithLength Domain
h SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> if Domain -> Bool
BS.null Domain
t
then SPut
forall a. Monoid a => a
mempty
else Domain -> SPut
putTXT Domain
t
putSRV :: Word16 -> Word16 -> Word16 -> Domain -> SPut
putSRV priority :: Word16
priority weight :: Word16
weight port :: Word16
port target :: Domain
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
, Domain -> SPut
putDomain Domain
target
]
putDS :: Word16 -> Word8 -> Word8 -> Domain -> SPut
putDS keytag :: Word16
keytag keyalg :: Word8
keyalg digestType :: Word8
digestType digest :: Domain
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
, Domain -> SPut
putByteString Domain
digest
]
putRRSIG :: RD_RRSIG -> SPut
putRRSIG RDREP_RRSIG{..} = [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
, Domain -> SPut
putDomain Domain
rrsigZone
, Domain -> SPut
putByteString Domain
rrsigValue
]
putDNSKEY :: Word16 -> Word8 -> Word8 -> Domain -> SPut
putDNSKEY flags :: Word16
flags protocol :: Word8
protocol alg :: Word8
alg key :: Domain
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
, Domain -> SPut
putByteString Domain
key
]
putNSEC3 :: Word8 -> Word8 -> Word16 -> Domain -> Domain -> [TYPE] -> SPut
putNSEC3 alg :: Word8
alg flags :: Word8
flags iterations :: Word16
iterations salt :: Domain
salt hash :: Domain
hash types :: [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
, Domain -> SPut
putByteStringWithLength Domain
salt
, Domain -> SPut
putByteStringWithLength Domain
hash
, [TYPE] -> SPut
putNsecTypes [TYPE]
types
]
putNSEC3PARAM :: Word8 -> Word8 -> Word16 -> Domain -> SPut
putNSEC3PARAM alg :: Word8
alg flags :: Word8
flags iterations :: Word16
iterations salt :: Domain
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
, Domain -> SPut
putByteStringWithLength Domain
salt
]
putTLSA :: Word8 -> Word8 -> Word8 -> Domain -> SPut
putTLSA usage :: Word8
usage selector :: Word8
selector mtype :: Word8
mtype assocData :: Domain
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
, Domain -> SPut
putByteString Domain
assocData
]
putNsecTypes :: [TYPE] -> SPut
putNsecTypes :: [TYPE] -> SPut
putNsecTypes types :: [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 ts :: [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` 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
.&. 0xff,
then group by Int
top8
using ((Int, Int) -> Int) -> [(Int, Int)] -> [[(Int, Int)]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith ]
putWindow :: Int -> [Int] -> SPut
putWindow :: Int -> [Int] -> SPut
putWindow top8 :: Int
top8 bot8s :: [Int]
bot8s =
let blks :: Int
blks = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
bot8s Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` 3
in Int -> SPut
putInt8 Int
top8
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> Word8 -> SPut
put8 (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 0 [ ([Int] -> Int
forall a. Eq a => [a] -> a
the [Int]
block, (Word8 -> Int -> Word8) -> Word8 -> [Int] -> Word8
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 0 [Int]
bot8) |
Int
bot8 <- [Int]
bot8s,
let block :: Int
block = Int
bot8 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` 3,
then group by Int
block
using ((Int, Int) -> Int) -> [(Int, Int)] -> [[(Int, Int)]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith ]
where
mergeBits :: a -> Int -> a
mergeBits acc :: a
acc b :: Int
b = a -> Int -> a
forall a. Bits a => a -> Int -> a
setBit a
acc (7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bInt -> Int -> Int
forall a. Bits a => a -> a -> a
.&.0x07)
putBits :: Int -> [(Int, Word8)] -> SPut
putBits :: Int -> [(Int, Word8)] -> SPut
putBits _ [] = Builder -> SPut
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
forall a. Monoid a => a
mempty
putBits n :: Int
n ((block :: Int
block, octet :: Word8
octet) : rest :: [(Int, Word8)]
rest) =
Int -> Word8 -> SPut
putReplicate (Int
blockInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n) 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
+ 1) [(Int, Word8)]
rest
putODWords :: Word16 -> [Word8] -> SPut
putODWords :: Word16 -> [Word8] -> SPut
putODWords code :: Word16
code ws :: [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 (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 -> Domain -> SPut
putODBytes code :: Word16
code bs :: Domain
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
$ Domain -> Int
BS.length Domain
bs
, Domain -> SPut
putByteString Domain
bs
]
putOData :: OData -> SPut
putOData :: OData -> SPut
putOData (OD_NSID nsid :: Domain
nsid) = Word16 -> Domain -> SPut
putODBytes (OptCode -> Word16
fromOptCode OptCode
NSID) Domain
nsid
putOData (OD_DAU as :: [Word8]
as) = Word16 -> [Word8] -> SPut
putODWords (OptCode -> Word16
fromOptCode OptCode
DAU) [Word8]
as
putOData (OD_DHU hs :: [Word8]
hs) = Word16 -> [Word8] -> SPut
putODWords (OptCode -> Word16
fromOptCode OptCode
DHU) [Word8]
hs
putOData (OD_N3U hs :: [Word8]
hs) = Word16 -> [Word8] -> SPut
putODWords (OptCode -> Word16
fromOptCode OptCode
N3U) [Word8]
hs
putOData (OD_ClientSubnet srcBits :: Word8
srcBits scpBits :: Word8
scpBits ip :: 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
+ 7) Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` 8
prefix :: a -> a
prefix addr :: 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
(family :: Word16
family, raw :: [Int]
raw) = case IP
ip of
IPv4 ip4 :: IPv4
ip4 -> (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 ip6 :: IPv6
ip6 -> (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 = 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> SPut
putInt8 [Int]
raw
]
putOData (OD_ECSgeneric family :: Word16
family srcBits :: Word8
srcBits scpBits :: Word8
scpBits addr :: Domain
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
$ 4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Domain -> Int
BS.length Domain
addr
, Word16 -> SPut
put16 Word16
family
, Word8 -> SPut
put8 Word8
srcBits
, Word8 -> SPut
put8 Word8
scpBits
, Domain -> SPut
putByteString Domain
addr
]
putOData (UnknownOData code :: Word16
code bs :: Domain
bs) = Word16 -> Domain -> SPut
putODBytes Word16
code Domain
bs
putByteStringWithLength :: BS.ByteString -> SPut
putByteStringWithLength :: Domain -> SPut
putByteStringWithLength bs :: Domain
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
$ Domain -> Int
BS.length Domain
bs)
SPut -> SPut -> SPut
forall a. Semigroup a => a -> a -> a
<> Domain -> SPut
putByteString Domain
bs
rootDomain :: Domain
rootDomain :: Domain
rootDomain = String -> Domain
BS.pack "."
putDomain :: Domain -> SPut
putDomain :: Domain -> SPut
putDomain = Char -> Domain -> SPut
putDomain' '.'
putMailbox :: Mailbox -> SPut
putMailbox :: Domain -> SPut
putMailbox = Char -> Domain -> SPut
putDomain' '@'
putDomain' :: Char -> ByteString -> SPut
putDomain' :: Char -> Domain -> SPut
putDomain' sep :: Char
sep dom :: Domain
dom
| Domain -> Bool
BS.null Domain
dom Bool -> Bool -> Bool
|| Domain
dom Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
== Domain
rootDomain = Word8 -> SPut
put8 0
| Bool
otherwise = do
Maybe Int
mpos <- Domain -> State WState (Maybe Int)
wsPop Domain
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 pos :: Int
pos -> Int -> SPut
putPointer Int
pos
Nothing -> Domain -> Int -> State WState ()
wsPush Domain
dom Int
cur State WState () -> SPut -> SPut
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
[SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [ Domain -> SPut
putPartialDomain Domain
hd
, Char -> Domain -> SPut
putDomain' '.' Domain
tl
]
where
(hd :: Domain
hd, tl :: Domain
tl) =
let p :: (Domain, Domain)
p = Word8 -> Domain -> (Domain, Domain)
parseLabel (Char -> Word8
c2w Char
sep) Domain
dom
in if Char
sep Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '.' Bool -> Bool -> Bool
&& Domain -> Bool
BS.null ((Domain, Domain) -> Domain
forall a b. (a, b) -> b
snd (Domain, Domain)
p)
then Word8 -> Domain -> (Domain, Domain)
parseLabel (Char -> Word8
c2w Char
'.') Domain
dom
else (Domain, Domain)
p
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 pos :: Int
pos = Int -> SPut
putInt16 (Int
pos Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. 0xc000)
putPartialDomain :: Domain -> SPut
putPartialDomain :: Domain -> SPut
putPartialDomain = Domain -> SPut
putByteStringWithLength