{-# LANGUAGE RecordWildCards #-}

-- | Encoders for DNS.
module Network.DNS.Encode (
    -- * Encoder
    encode
    -- ** Encoder for Each Part
  , encodeResourceRecord
  , encodeDNSHeader
  , encodeDNSFlags
  , encodeDomain
  , encodeMailbox
  ) 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 Data.IP (IP(..), fromIPv4, fromIPv6b)

import Network.DNS.Imports
import Network.DNS.StateBinary
import Network.DNS.Types

----------------------------------------------------------------

-- | Encoding DNS query or response.
encode :: DNSMessage -> ByteString
encode :: DNSMessage -> ByteString
encode = SPut -> ByteString
runSPut (SPut -> ByteString)
-> (DNSMessage -> SPut) -> DNSMessage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSMessage -> SPut
putDNSMessage

-- | Encoding DNS flags.
encodeDNSFlags :: DNSFlags -> ByteString
encodeDNSFlags :: DNSFlags -> ByteString
encodeDNSFlags = SPut -> ByteString
runSPut (SPut -> ByteString)
-> (DNSFlags -> SPut) -> DNSFlags -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSFlags -> SPut
putDNSFlags

-- | Encoding DNS header.
encodeDNSHeader :: DNSHeader -> ByteString
encodeDNSHeader :: DNSHeader -> ByteString
encodeDNSHeader = SPut -> ByteString
runSPut (SPut -> ByteString)
-> (DNSHeader -> SPut) -> DNSHeader -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSHeader -> SPut
putHeader

-- | Encoding domain.
encodeDomain :: Domain -> ByteString
encodeDomain :: ByteString -> ByteString
encodeDomain = SPut -> ByteString
runSPut (SPut -> ByteString)
-> (ByteString -> SPut) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> SPut
putDomain

-- | Encoding mailbox.
encodeMailbox :: Mailbox -> ByteString
encodeMailbox :: ByteString -> ByteString
encodeMailbox = SPut -> ByteString
runSPut (SPut -> ByteString)
-> (ByteString -> SPut) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> SPut
putMailbox

-- | Encoding resource record.
encodeResourceRecord :: ResourceRecord -> ByteString
encodeResourceRecord :: ResourceRecord -> ByteString
encodeResourceRecord ResourceRecord
rr = SPut -> ByteString
runSPut (SPut -> ByteString) -> SPut -> ByteString
forall a b. (a -> b) -> a -> b
$ ResourceRecord -> SPut
putResourceRecord ResourceRecord
rr

----------------------------------------------------------------

putDNSMessage :: DNSMessage -> SPut
putDNSMessage :: DNSMessage -> SPut
putDNSMessage DNSMessage
msg = DNSHeader -> SPut
putHeader DNSHeader
hdr
                    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
                                         ]
    hdr :: DNSHeader
hdr = DNSMessage -> DNSHeader
header 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
    ad :: [ResourceRecord]
ad = DNSMessage -> [ResourceRecord]
additional DNSMessage
msg

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
authenData :: DNSFlags -> Bool
rcode :: DNSFlags -> RCODE
recAvailable :: DNSFlags -> Bool
recDesired :: DNSFlags -> Bool
trunCation :: DNSFlags -> Bool
authAnswer :: DNSFlags -> Bool
opcode :: DNSFlags -> OPCODE
qOrR :: DNSFlags -> QorR
authenData :: Bool
rcode :: RCODE
recAvailable :: Bool
recDesired :: Bool
trunCation :: Bool
authAnswer :: Bool
opcode :: OPCODE
qOrR :: QorR
..} = Word16 -> SPut
put16 Word16
word
  where
    word16 :: Enum a => a -> Word16
    word16 :: a -> Word16
word16 = Int -> Word16
forall a. Enum a => Int -> a
toEnum (Int -> Word16) -> (a -> Int) -> a -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum

    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 (Word16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word16) -> Word16 -> Word16
forall a b. (a -> b) -> a -> b
$ RCODE -> Word16
fromRCODEforHeader RCODE
rcode)
              , 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
forall a. Enum a => a -> Word16
word16 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
ip         -> [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
ip)
    RD_AAAA IPv6
ip      -> [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
ip)
    RD_NS ByteString
dom       -> ByteString -> SPut
putDomain ByteString
dom
    RD_CNAME ByteString
dom    -> ByteString -> SPut
putDomain ByteString
dom
    RD_DNAME ByteString
dom    -> ByteString -> SPut
putDomain ByteString
dom
    RD_PTR ByteString
dom      -> ByteString -> SPut
putDomain ByteString
dom
    RD_MX Word16
prf ByteString
dom   -> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat [Word16 -> SPut
put16 Word16
prf, ByteString -> SPut
putDomain ByteString
dom]
    RD_TXT ByteString
txt      -> ByteString -> SPut
putByteStringWithLength ByteString
txt
    RD_OPT [OData]
opts     -> [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]
opts
    RD_SOA ByteString
mn ByteString
mr TTL
serial TTL
refresh TTL
retry TTL
expire TTL
min' -> [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
min'
        ]
    RD_SRV Word16
prio Word16
weight Word16
port ByteString
dom -> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
        [ Word16 -> SPut
put16 Word16
prio
        , Word16 -> SPut
put16 Word16
weight
        , Word16 -> SPut
put16 Word16
port
        , ByteString -> SPut
putDomain ByteString
dom
        ]
    RD_TLSA Word8
u Word8
s Word8
m ByteString
d -> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
        [ Word8 -> SPut
put8 Word8
u
        , Word8 -> SPut
put8 Word8
s
        , Word8 -> SPut
put8 Word8
m
        , ByteString -> SPut
putByteString ByteString
d
        ]
    RD_DS Word16
t Word8
a Word8
dt ByteString
dv -> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
        [ Word16 -> SPut
put16 Word16
t
        , Word8 -> SPut
put8 Word8
a
        , Word8 -> SPut
put8 Word8
dt
        , ByteString -> SPut
putByteString ByteString
dv
        ]
    RData
RD_NULL -> Builder -> SPut
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
forall a. Monoid a => a
mempty
    (RD_DNSKEY Word16
f Word8
p Word8
a ByteString
k) -> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
        [ Word16 -> SPut
put16 Word16
f
        , Word8 -> SPut
put8 Word8
p
        , Word8 -> SPut
put8 Word8
a
        , ByteString -> SPut
putByteString ByteString
k
        ]
    (RD_NSEC3PARAM Word8
h Word8
f Word16
i ByteString
s) -> [SPut] -> SPut
forall a. Monoid a => [a] -> a
mconcat
        [ Word8 -> SPut
put8 Word8
h
        , Word8 -> SPut
put8 Word8
f
        , Word16 -> SPut
put16 Word16
i
        , ByteString -> SPut
putByteStringWithLength ByteString
s
        ]
    UnknownRData ByteString
bytes -> ByteString -> SPut
putByteString ByteString
bytes

putOData :: OData -> SPut
putOData :: OData -> SPut
putOData (OD_ClientSubnet Word8
srcNet Word8
scpNet IP
ip) =
    let dropZeroes :: [Int] -> [Int]
dropZeroes = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0)
        (Int
fam,[Int]
raw) = case IP
ip of
                        IPv4 IPv4
ip4 -> (Int
1,[Int] -> [Int]
dropZeroes ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ IPv4 -> [Int]
fromIPv4 IPv4
ip4)
                        IPv6 IPv6
ip6 -> (Int
2,[Int] -> [Int]
dropZeroes ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ IPv6 -> [Int]
fromIPv6b 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] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
raw
     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
                , Int -> SPut
putInt16 Int
fam
                , Word8 -> SPut
put8 Word8
srcNet
                , Word8 -> SPut
put8 Word8
scpNet
                , [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 (UnknownOData OptCode
code ByteString
bs) =
    [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
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
            ]

-- 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
    (ByteString
hd, ByteString
tl') = case Char
sep of
        Char
'.' -> (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') ByteString
dom
        Char
_ | Char
sep Char -> ByteString -> Bool
`BS.elem` ByteString
dom -> (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
sep) ByteString
dom
          | Bool
otherwise -> (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') ByteString
dom
    tl :: ByteString
tl = if ByteString -> Bool
BS.null ByteString
tl' then ByteString
tl' else Int -> ByteString -> ByteString
BS.drop Int
1 ByteString
tl'

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