module Network.DNS.IO (
receive
, receiveVC
, send
, sendVC
, encodeQuestions
, composeQuery
, composeQueryAD
, responseA
, responseAAAA
) where
#if !defined(mingw32_HOST_OS)
#define POSIX
#else
#define WIN
#endif
#if __GLASGOW_HASKELL__ < 709
#define GHC708
#endif
import qualified Control.Monad.State as ST
import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Char (ord)
import Data.Conduit (($$), ($$+), ($$+-), (=$), Sink)
import Data.Conduit.Attoparsec (sinkParser)
import qualified Data.Conduit.Binary as CB
import Data.Conduit.Network (sourceSocket)
import Data.IP (IPv4, IPv6)
import Data.Monoid ((<>))
import Network (Socket)
#ifdef GHC708
import Control.Applicative ((<$>))
#endif
#if defined(WIN) && defined(GHC708)
import Network.Socket (send)
import qualified Data.ByteString.Char8 as BS
import Control.Monad (when)
#else
import Network.Socket.ByteString (sendAll)
#endif
import Network.DNS.Types
import Network.DNS.Encode (encode)
import Network.DNS.Decode.Internal (getResponse)
import Network.DNS.StateBinary (PState, initialState)
sink :: Sink ByteString IO (DNSMessage, PState)
sink = sinkParser $ ST.runStateT getResponse initialState
receive :: Socket -> IO DNSMessage
receive sock = fst <$> (sourceSocket sock $$ sink)
receiveVC :: Socket -> IO DNSMessage
receiveVC sock = do
(src, lenbytes) <- sourceSocket sock $$+ CB.take 2
let len = case map ord $ LBS.unpack lenbytes of
[hi, lo] -> 256 * hi + lo
_ -> 0
fst <$> (src $$+- CB.isolate len =$ sink)
send :: Socket -> ByteString -> IO ()
send sock legacyQuery = sendAll sock legacyQuery
sendVC :: Socket -> ByteString -> IO ()
sendVC vc legacyQuery = sendAll vc $ encodeVC legacyQuery
encodeVC :: ByteString -> ByteString
encodeVC legacyQuery =
let len = LBS.toStrict . BB.toLazyByteString $ BB.int16BE $ fromIntegral $ BS.length legacyQuery
in len <> legacyQuery
#if defined(WIN) && defined(GHC708)
sendAll :: Socket -> BS.ByteString -> IO ()
sendAll sock bs = do
sent <- send sock (BS.unpack bs)
when (sent < fromIntegral (BS.length bs)) $ sendAll sock (BS.drop (fromIntegral sent) bs)
#endif
encodeQuestions :: Identifier
-> [Question]
-> [ResourceRecord]
-> Bool
-> ByteString
encodeQuestions idt qs adds auth = encode qry
where
hdr = header defaultQuery
flg = flags hdr
qry = defaultQuery {
header = hdr {
identifier = idt,
flags = flg {
authenData = auth
}
}
, question = qs
, additional = adds
}
composeQuery :: Identifier -> [Question] -> ByteString
composeQuery idt qs = encodeQuestions idt qs [] False
composeQueryAD :: Identifier -> [Question] -> ByteString
composeQueryAD idt qs = encodeQuestions idt qs [] True
responseA :: Identifier -> Question -> [IPv4] -> DNSMessage
responseA ident q ips =
let hd = header defaultResponse
dom = qname q
an = ResourceRecord dom A classIN 300 . RD_A <$> ips
in defaultResponse {
header = hd { identifier=ident }
, question = [q]
, answer = an
}
responseAAAA :: Identifier -> Question -> [IPv6] -> DNSMessage
responseAAAA ident q ips =
let hd = header defaultResponse
dom = qname q
an = ResourceRecord dom AAAA classIN 300 . RD_AAAA <$> ips
in defaultResponse {
header = hd { identifier=ident }
, question = [q]
, answer = an
}