{-# 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 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
                    forall a. Semigroup a => a -> a -> a
<> SPut
putNums
                    forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map Question -> SPut
putQuestion [Question]
qs)
                    forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map ResourceRecord -> SPut
putResourceRecord Answers
an)
                    forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map ResourceRecord -> SPut
putResourceRecord Answers
au)
                    forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map ResourceRecord -> SPut
putResourceRecord Answers
ad)
  where
    putNums :: SPut
putNums = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> SPut
putInt16 [ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Question]
qs
                                      , forall (t :: * -> *) a. Foldable t => t a -> Int
length Answers
an
                                      , forall (t :: * -> *) a. Foldable t => t a -> Int
length Answers
au
                                      , forall (t :: * -> *) a. Foldable t => t a -> Int
length Answers
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 :: Answers
an = DNSMessage -> Answers
answer DNSMessage
msg
    au :: Answers
au = DNSMessage -> Answers
authority DNSMessage
msg
    hd :: DNSHeader
hd = forall a. EDNSheader -> a -> a -> a
ifEDNS EDNSheader
eh DNSHeader
hm forall a b. (a -> b) -> a -> b
$ DNSHeader
hm { flags :: DNSFlags
flags = DNSFlags
fl { rcode :: RCODE
rcode = RCODE
rc } }
    rc :: RCODE
rc = forall a. EDNSheader -> a -> a -> a
ifEDNS EDNSheader
eh forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> a
id forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RCODE -> RCODE
nonEDNSrcode forall a b. (a -> b) -> a -> b
$ DNSFlags -> RCODE
rcode DNSFlags
fl
      where
        nonEDNSrcode :: RCODE -> RCODE
nonEDNSrcode RCODE
code | RCODE -> Word16
fromRCODE RCODE
code forall a. Ord a => a -> a -> Bool
< Word16
16 = RCODE
code
                          | Bool
otherwise           = RCODE
FormatErr
    ad :: Answers
ad = Answers -> Answers
prependOpt forall a b. (a -> b) -> a -> b
$ DNSMessage -> Answers
additional DNSMessage
msg
      where
        prependOpt :: Answers -> Answers
prependOpt Answers
ads = forall a. EDNSheader -> (EDNS -> a) -> a -> a
mapEDNS EDNSheader
eh (Answers -> Word16 -> EDNS -> Answers
fromEDNS Answers
ads forall a b. (a -> b) -> a -> b
$ RCODE -> Word16
fromRCODE RCODE
rc) Answers
ads
          where
            fromEDNS :: AdditionalRecords -> Word16 -> EDNS -> AdditionalRecords
            fromEDNS :: Answers -> Word16 -> EDNS -> Answers
fromEDNS Answers
rrs Word16
rc' EDNS
edns = ByteString -> TYPE -> Word16 -> TTL -> RData -> ResourceRecord
ResourceRecord ByteString
name' TYPE
type' Word16
class' TTL
ttl' RData
rdata' forall a. a -> [a] -> [a]
: Answers
rrs
              where
                name' :: ByteString
name'  = Char -> ByteString
BS.singleton Char
'.'
                type' :: TYPE
type'  = TYPE
OPT
                class' :: Word16
class' = Word16
maxUdpSize forall a. Ord a => a -> a -> a
`min` (Word16
minUdpSize forall a. Ord a => a -> a -> a
`max` EDNS -> Word16
ednsUdpSize EDNS
edns)
                ttl0' :: TTL
ttl0'  = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
rc' forall a. Bits a => a -> a -> a
.&. Word16
0xff0) forall a. Bits a => a -> Int -> a
`shiftL` Int
20
                vers' :: TTL
vers'  = forall a b. (Integral a, Num b) => a -> b
fromIntegral (EDNS -> Word8
ednsVersion EDNS
edns) forall a. Bits a => a -> Int -> a
`shiftL` Int
16
                ttl' :: TTL
ttl'
                  | EDNS -> Bool
ednsDnssecOk EDNS
edns = TTL
ttl0' forall a. Bits a => a -> Int -> a
`setBit` Int
15 forall a. Bits a => a -> a -> a
.|. TTL
vers'
                  | Bool
otherwise         = TTL
ttl0' forall a. Bits a => a -> a -> a
.|. TTL
vers'
                rdata' :: RData
rdata' = [OData] -> RData
RD_OPT 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)
                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 = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Bits a => a -> a -> a
.|. Word16
byte)

    st :: State Word16 ()
    st :: State Word16 ()
st = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
              [ Word16 -> State Word16 ()
set (RCODE -> Word16
fromRCODE RCODE
rcode forall a. Bits a => a -> a -> a
.&. Word16
0x0f)
              , forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
chkDisable          forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (forall a. Bits a => Int -> a
bit Int
4)
              , forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
authenData          forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (forall a. Bits a => Int -> a
bit Int
5)
              , forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
recAvailable        forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (forall a. Bits a => Int -> a
bit Int
7)
              , forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
recDesired          forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (forall a. Bits a => Int -> a
bit Int
8)
              , forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
trunCation          forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (forall a. Bits a => Int -> a
bit Int
9)
              , forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
authAnswer          forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (forall a. Bits a => Int -> a
bit Int
10)
              , Word16 -> State Word16 ()
set (OPCODE -> Word16
fromOPCODE OPCODE
opcode forall a. Bits a => a -> Int -> a
`shiftL` Int
11)
              , forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QorR
qOrRforall a. Eq a => a -> a -> Bool
==QorR
QR_Response) forall a b. (a -> b) -> a -> b
$ Word16 -> State Word16 ()
set (forall a. Bits a => Int -> a
bit Int
15)
              ]

    word :: Word16
word = 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
                           forall a. Semigroup a => a -> a -> a
<> Word16 -> SPut
put16 (TYPE -> Word16
fromTYPE TYPE
qtype)
                           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
..} = 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
LBS.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ Builder
rDataBuilder
        let rlenBuilder :: Builder
rlenBuilder = Int16 -> Builder
BB.int16BE Int16
rdataLength
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Builder
rlenBuilder 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 -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ 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 -> 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 forall a. Semigroup a => a -> a -> a
<> ByteString -> SPut
putDomain ByteString
dname
    RD_AAAA              IPv6
address -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ 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 -> forall a. Monoid a => [a] -> a
mconcat 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 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 = 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 forall a. Semigroup a => a -> a -> a
<> if ByteString -> Bool
BS.null ByteString
t
                then 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 = 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 = 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
..} = forall a. Monoid a => [a] -> a
mconcat
        [ Word16 -> SPut
put16 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 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
rrsigExpiration
        , TTL -> SPut
put32 forall a b. (a -> b) -> a -> b
$ 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 = 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 = 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 = 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 = 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 = forall a. Monoid a => [a] -> a
mconcat
        [ Word8 -> SPut
put8 Word8
flags
        , ByteString -> SPut
putByteStringWithLength (forall s. CI s -> s
CI.original CI ByteString
tag)
        , ByteString -> SPut
putByteString ByteString
value
        ]

-- | Encode DNSSEC NSEC type bits
putNsecTypes :: [TYPE] -> SPut
putNsecTypes :: [TYPE] -> SPut
putNsecTypes [TYPE]
types = [Word16] -> SPut
putTypeList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TYPE -> Word16
fromTYPE [TYPE]
types
  where
    putTypeList :: [Word16] -> SPut
    putTypeList :: [Word16] -> SPut
putTypeList [Word16]
ts =
        forall a. Monoid a => [a] -> a
mconcat [ Int -> [Int] -> SPut
putWindow (forall a. Eq a => [a] -> a
the [Int]
top8) [Int]
bot8 |
                  Word16
t <- [Word16]
ts,
                  let top8 :: Int
top8 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
t forall a. Bits a => a -> Int -> a
`shiftR` Int
8,
                  let bot8 :: Int
bot8 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
t forall a. Bits a => a -> a -> a
.&. Int
0xff,
                  then group by Int
top8
                       using 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 = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
bot8s forall a. Bits a => a -> Int -> a
`shiftR` Int
3
         in Int -> SPut
putInt8 Int
top8
            forall a. Semigroup a => a -> a -> a
<> Word8 -> SPut
put8 (Word8
1 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
blks)
            forall a. Semigroup a => a -> a -> a
<> Int -> [(Int, Word8)] -> SPut
putBits Int
0 [ (forall a. Eq a => [a] -> a
the [Int]
block, forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Bits a => a -> Int -> a
mergeBits Word8
0 [Int]
bot8) |
                           Int
bot8 <- [Int]
bot8s,
                           let block :: Int
block = Int
bot8 forall a. Bits a => a -> Int -> a
`shiftR` Int
3,
                           then group by Int
block
                                using 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 = forall a. Bits a => a -> Int -> a
setBit a
acc (Int
7 forall a. Num a => a -> a -> a
- Int
bforall a. Bits a => a -> a -> a
.&.Int
0x07)

    putBits :: Int -> [(Int, Word8)] -> SPut
    putBits :: Int -> [(Int, Word8)] -> SPut
putBits Int
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
    putBits Int
n ((Int
block, Word8
octet) : [(Int, Word8)]
rest) =
        Int -> Word8 -> SPut
putReplicate (Int
blockforall a. Num a => a -> a -> a
-Int
n) Word8
0
        forall a. Semigroup a => a -> a -> a
<> Word8 -> SPut
put8 Word8
octet
        forall a. Semigroup a => a -> a -> a
<> Int -> [(Int, Word8)] -> SPut
putBits (Int
block 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 =
     forall a. Monoid a => [a] -> a
mconcat [ Word16 -> SPut
put16 Word16
code
             , Int -> SPut
putInt16 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
ws
             , forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ 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 =
    forall a. Monoid a => [a] -> a
mconcat [ Word16 -> SPut
put16 Word16
code
            , Int -> SPut
putInt16 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ (Word8
srcBits forall a. Num a => a -> a -> a
+ Word8
7) forall a. Integral a => a -> a -> a
`div` Word8
8
        prefix :: a -> a
prefix a
addr = forall a. AddrRange a -> a
Data.IP.addr forall a b. (a -> b) -> a -> b
$ forall a. Addr a => a -> Int -> AddrRange a
makeAddrRange a
addr forall a b. (a -> b) -> a -> b
$ 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, forall a. Int -> [a] -> [a]
take Int
octets forall a b. (a -> b) -> a -> b
$ IPv4 -> [Int]
fromIPv4  forall a b. (a -> b) -> a -> b
$ forall {a}. Addr a => a -> a
prefix IPv4
ip4)
                        IPv6 IPv6
ip6 -> (Word16
2, forall a. Int -> [a] -> [a]
take Int
octets forall a b. (a -> b) -> a -> b
$ IPv6 -> [Int]
fromIPv6b forall a b. (a -> b) -> a -> b
$ forall {a}. Addr a => a -> a
prefix IPv6
ip6)
        dataLen :: Int
dataLen = Int
2 forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
+ Int
octets
     in forall a. Monoid a => [a] -> a
mconcat [ Word16 -> SPut
put16 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
                , forall a. Monoid a => [a] -> a
mconcat 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) =
    forall a. Monoid a => [a] -> a
mconcat [ Word16 -> SPut
put16 forall a b. (a -> b) -> a -> b
$ OptCode -> Word16
fromOptCode OptCode
ClientSubnet
            , Int -> SPut
putInt16 forall a b. (a -> b) -> a -> b
$ Int
4 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs) -- put the length of the given string
                          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 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 <- 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
                        -- Pointers are limited to 14-bits!
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cur forall a. Ord a => a -> a -> Bool
<= Int
0x3fff) forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> State WState ()
wsPush ByteString
dom Int
cur
                        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) = 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 forall a. Eq a => a -> a -> Bool
/= Word8
0x2e Bool -> Bool -> Bool
&& ByteString -> Bool
BS.null (forall a b. (a, b) -> b
snd (ByteString, ByteString)
p) -> Word8 -> (ByteString, ByteString)
loop Word8
0x2e
                    | Bool
otherwise -> (ByteString, ByteString)
p
            Left DNSError
e -> forall a e. Exception e => e -> a
E.throw DNSError
e

    c2w :: Char -> Word8
c2w = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum

putPointer :: Int -> SPut
putPointer :: Int -> SPut
putPointer Int
pos = Int -> SPut
putInt16 (Int
pos forall a. Bits a => a -> a -> a
.|. Int
0xc000)

putPartialDomain :: Domain -> SPut
putPartialDomain :: ByteString -> SPut
putPartialDomain = ByteString -> SPut
putByteStringWithLength