{-# LANGUAGE
    BangPatterns
  , RecordWildCards
  , TransformListComp
  #-}

-- | DNS Message builder.
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 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 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
putHeader :: DNSHeader -> SPut
putHeader 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
chkDisable :: DNSFlags -> Bool
authenData :: DNSFlags -> Bool
recAvailable :: DNSFlags -> Bool
recDesired :: DNSFlags -> Bool
trunCation :: DNSFlags -> Bool
authAnswer :: DNSFlags -> Bool
opcode :: DNSFlags -> OPCODE
qOrR :: DNSFlags -> QorR
chkDisable :: Bool
authenData :: Bool
rcode :: RCODE
recAvailable :: Bool
recDesired :: Bool
trunCation :: Bool
authAnswer :: Bool
opcode :: OPCODE
qOrR :: QorR
rcode :: DNSFlags -> RCODE
..} = 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

-- XXX: Use question class when implemented
--
putQuestion :: Question -> SPut
putQuestion :: Question -> SPut
putQuestion Question{ByteString
TYPE
qtype :: Question -> TYPE
qname :: Question -> ByteString
qtype :: TYPE
qname :: ByteString
..} = 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
rdata :: ResourceRecord -> RData
rrttl :: ResourceRecord -> TTL
rrclass :: ResourceRecord -> Word16
rrtype :: ResourceRecord -> TYPE
rrname :: ResourceRecord -> ByteString
rdata :: RData
rrttl :: TTL
rrclass :: Word16
rrtype :: TYPE
rrname :: ByteString
..} = [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 -- "simulate" putInt16
        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 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_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 (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
    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
        ]
    -- TXT record string fragments are at most 255 bytes
    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
rrsigValue :: RD_RRSIG -> ByteString
rrsigZone :: RD_RRSIG -> ByteString
rrsigKeyTag :: RD_RRSIG -> Word16
rrsigInception :: RD_RRSIG -> Int64
rrsigExpiration :: RD_RRSIG -> Int64
rrsigTTL :: RD_RRSIG -> TTL
rrsigNumLabels :: RD_RRSIG -> Word8
rrsigKeyAlg :: RD_RRSIG -> Word8
rrsigType :: RD_RRSIG -> TYPE
rrsigValue :: ByteString
rrsigZone :: ByteString
rrsigKeyTag :: Word16
rrsigInception :: Int64
rrsigExpiration :: Int64
rrsigTTL :: TTL
rrsigNumLabels :: Word8
rrsigKeyAlg :: Word8
rrsigType :: TYPE
..} = [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
        ]

-- | Encode DNSSEC NSEC type bits
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 ((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 Int
top8 [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` 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 (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 ((Int, Int) -> Int) -> [(Int, Int)] -> [[(Int, Int)]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith ]
      where
        -- | Combine type bits in network bit order, i.e. bit 0 first.
        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 (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

-- | Encode EDNS OPTION consisting of a list of octets.
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 (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
             ]

-- | Encode an EDNS OPTION byte string.
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) =
    -- https://tools.ietf.org/html/rfc7871#section-6
    --
    -- o  ADDRESS, variable number of octets, contains either an IPv4 or
    --    IPv6 address, depending on FAMILY, which MUST be truncated to the
    --    number of bits indicated by the SOURCE PREFIX-LENGTH field,
    --    padding with 0 bits to pad to the end of the last octet needed.
    --
    -- o  A server receiving an ECS option that uses either too few or too
    --    many ADDRESS octets, or that has non-zero ADDRESS bits set beyond
    --    SOURCE PREFIX-LENGTH, SHOULD return FORMERR to reject the packet,
    --    as a signal to the software developer making the request to fix
    --    their implementation.
    --
    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 (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

-- In the case of the TXT record, we need to put the string length
-- fixme : What happens with the length > 256 ?
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) -- put the length of the given string
                          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  -> ByteString -> Int -> State WState ()
wsPush ByteString
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 [ ByteString -> SPut
putPartialDomain ByteString
hd
                                , Char -> ByteString -> SPut
putDomain' Char
'.' ByteString
tl
                                ]
  where
    -- Try with the preferred separator if present, else fall back to '.'.
    (ByteString
hd, ByteString
tl) =
        let p :: (ByteString, ByteString)
p = Word8 -> ByteString -> (ByteString, ByteString)
parseLabel (Char -> Word8
c2w Char
sep) ByteString
dom
         in if Char
sep Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.' Bool -> Bool -> Bool
&& ByteString -> Bool
BS.null ((ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (ByteString, ByteString)
p)
            then Word8 -> ByteString -> (ByteString, ByteString)
parseLabel (Char -> Word8
c2w Char
'.') ByteString
dom
            else (ByteString, ByteString)
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 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