{-# LANGUAGE OverloadedStrings #-}
module Network.DNS.IO (
receive
, receiveFrom
, receiveVC
, send
, sendTo
, sendVC
, sendAll
, encodeQuestion
, encodeVC
, responseA
, responseAAAA
) where
import qualified Control.Exception as E
import qualified Data.ByteString as B
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 (IPv4, IPv6)
import Time.System (timeCurrent)
import Time.Types (Elapsed(..), Seconds(..))
import Network.Socket (Socket, SockAddr)
import Network.Socket.ByteString (recv, recvFrom)
import qualified Network.Socket.ByteString as Socket
import System.IO.Error
import Network.DNS.Decode (decodeAt)
import Network.DNS.Encode (encode)
import Network.DNS.Imports
import Network.DNS.Types.Internal
receive :: Socket -> IO DNSMessage
receive :: Socket -> IO DNSMessage
receive Socket
sock = do
let bufsiz :: Int
bufsiz = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
maxUdpSize
ByteString
bs <- Socket -> Int -> IO ByteString
recv Socket
sock Int
bufsiz forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \IOException
e -> forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ IOException -> DNSError
NetworkFailure IOException
e
Elapsed (Seconds Int64
now) <- IO Elapsed
timeCurrent
case Int64 -> ByteString -> Either DNSError DNSMessage
decodeAt Int64
now ByteString
bs of
Left DNSError
e -> forall e a. Exception e => e -> IO a
E.throwIO DNSError
e
Right DNSMessage
msg -> forall (m :: * -> *) a. Monad m => a -> m a
return DNSMessage
msg
receiveFrom :: Socket -> IO (DNSMessage, SockAddr)
receiveFrom :: Socket -> IO (DNSMessage, SockAddr)
receiveFrom Socket
sock = do
let bufsiz :: Int
bufsiz = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
maxUdpSize
(ByteString
bs, SockAddr
client) <- Socket -> Int -> IO (ByteString, SockAddr)
recvFrom Socket
sock Int
bufsiz forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \IOException
e -> forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ IOException -> DNSError
NetworkFailure IOException
e
Elapsed (Seconds Int64
now) <- IO Elapsed
timeCurrent
case Int64 -> ByteString -> Either DNSError DNSMessage
decodeAt Int64
now ByteString
bs of
Left DNSError
e -> forall e a. Exception e => e -> IO a
E.throwIO DNSError
e
Right DNSMessage
msg -> forall (m :: * -> *) a. Monad m => a -> m a
return (DNSMessage
msg, SockAddr
client)
receiveVC :: Socket -> IO DNSMessage
receiveVC :: Socket -> IO DNSMessage
receiveVC Socket
sock = do
Int
len <- forall {a}. Num a => ByteString -> a
toLen forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int -> IO ByteString
recvDNS Socket
sock Int
2
ByteString
bs <- Socket -> Int -> IO ByteString
recvDNS Socket
sock Int
len
Elapsed (Seconds Int64
now) <- IO Elapsed
timeCurrent
case Int64 -> ByteString -> Either DNSError DNSMessage
decodeAt Int64
now ByteString
bs of
Left DNSError
e -> forall e a. Exception e => e -> IO a
E.throwIO DNSError
e
Right DNSMessage
msg -> forall (m :: * -> *) a. Monad m => a -> m a
return DNSMessage
msg
where
toLen :: ByteString -> a
toLen ByteString
bs = case ByteString -> [Word8]
B.unpack ByteString
bs of
[Word8
hi, Word8
lo] -> a
256 forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
hi) forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
lo)
[Word8]
_ -> a
0
recvDNS :: Socket -> Int -> IO ByteString
recvDNS :: Socket -> Int -> IO ByteString
recvDNS Socket
sock Int
len = IO ByteString
recv1 forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \IOException
e -> forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ IOException -> DNSError
NetworkFailure IOException
e
where
recv1 :: IO ByteString
recv1 = do
ByteString
bs1 <- Int -> IO ByteString
recvCore Int
len
if ByteString -> Int
BS.length ByteString
bs1 forall a. Eq a => a -> a -> Bool
== Int
len then
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs1
else do
ByteString -> IO ByteString
loop ByteString
bs1
loop :: ByteString -> IO ByteString
loop ByteString
bs0 = do
let left :: Int
left = Int
len forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
bs0
ByteString
bs1 <- Int -> IO ByteString
recvCore Int
left
let bs :: ByteString
bs = ByteString
bs0 ByteString -> ByteString -> ByteString
`BS.append` ByteString
bs1
if ByteString -> Int
BS.length ByteString
bs forall a. Eq a => a -> a -> Bool
== Int
len then
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
else
ByteString -> IO ByteString
loop ByteString
bs
eofE :: IOException
eofE = IOErrorType
-> String -> Maybe Handle -> Maybe String -> IOException
mkIOError IOErrorType
eofErrorType String
"connection terminated" forall a. Maybe a
Nothing forall a. Maybe a
Nothing
recvCore :: Int -> IO ByteString
recvCore Int
len0 = do
ByteString
bs <- Socket -> Int -> IO ByteString
recv Socket
sock Int
len0
if ByteString
bs forall a. Eq a => a -> a -> Bool
== ByteString
"" then
forall e a. Exception e => e -> IO a
E.throwIO IOException
eofE
else
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
send :: Socket -> ByteString -> IO ()
send :: Socket -> ByteString -> IO ()
send = (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
.)forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> ByteString -> IO Int
Socket.send
{-# INLINE send #-}
sendTo :: Socket -> ByteString -> SockAddr -> IO ()
sendTo :: Socket -> ByteString -> SockAddr -> IO ()
sendTo Socket
sock ByteString
str SockAddr
addr = Socket -> ByteString -> SockAddr -> IO Int
Socket.sendTo Socket
sock ByteString
str SockAddr
addr forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE sendTo #-}
sendVC :: Socket -> ByteString -> IO ()
sendVC :: Socket -> ByteString -> IO ()
sendVC = (forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
encodeVC)forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> ByteString -> IO ()
sendAll
{-# INLINE sendVC #-}
sendAll :: Socket -> BS.ByteString -> IO ()
sendAll :: Socket -> ByteString -> IO ()
sendAll = Socket -> ByteString -> IO ()
Socket.sendAll
{-# INLINE sendAll #-}
encodeQuestion :: Identifier
-> Question
-> QueryControls
-> ByteString
encodeQuestion :: Word16 -> Question -> QueryControls -> ByteString
encodeQuestion Word16
idt Question
q QueryControls
ctls = DNSMessage -> ByteString
encode forall a b. (a -> b) -> a -> b
$ Word16 -> Question -> QueryControls -> DNSMessage
makeQuery Word16
idt Question
q QueryControls
ctls
encodeVC :: ByteString -> ByteString
encodeVC :: ByteString -> ByteString
encodeVC ByteString
legacyQuery =
let len :: ByteString
len = ByteString -> ByteString
LBS.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ Int16 -> Builder
BB.int16BE forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
legacyQuery
in ByteString
len forall a. Semigroup a => a -> a -> a
<> ByteString
legacyQuery
{-# INLINE encodeVC #-}
responseA :: Identifier -> Question -> [IPv4] -> DNSMessage
responseA :: Word16 -> Question -> [IPv4] -> DNSMessage
responseA Word16
idt Question
q [IPv4]
ips = Word16 -> Question -> Answers -> DNSMessage
makeResponse Word16
idt Question
q Answers
as
where
dom :: ByteString
dom = Question -> ByteString
qname Question
q
as :: Answers
as = ByteString -> TYPE -> Word16 -> TTL -> RData -> ResourceRecord
ResourceRecord ByteString
dom TYPE
A Word16
classIN TTL
300 forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv4 -> RData
RD_A forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IPv4]
ips
responseAAAA :: Identifier -> Question -> [IPv6] -> DNSMessage
responseAAAA :: Word16 -> Question -> [IPv6] -> DNSMessage
responseAAAA Word16
idt Question
q [IPv6]
ips = Word16 -> Question -> Answers -> DNSMessage
makeResponse Word16
idt Question
q Answers
as
where
dom :: ByteString
dom = Question -> ByteString
qname Question
q
as :: Answers
as = ByteString -> TYPE -> Word16 -> TTL -> RData -> ResourceRecord
ResourceRecord ByteString
dom TYPE
AAAA Word16
classIN TTL
300 forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv6 -> RData
RD_AAAA forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IPv6]
ips