{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.DNS.IO (
receive
, receiveVC
, send
, 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)
import Network.Socket.ByteString (recv)
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 sock :: Socket
sock = do
let bufsiz :: Int
bufsiz = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
maxUdpSize
ByteString
bs <- Socket -> Int -> IO ByteString
recv Socket
sock Int
bufsiz IO ByteString -> (IOException -> IO ByteString) -> IO ByteString
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \e :: IOException
e -> DNSError -> IO ByteString
forall e a. Exception e => e -> IO a
E.throwIO (DNSError -> IO ByteString) -> DNSError -> IO ByteString
forall a b. (a -> b) -> a -> b
$ IOException -> DNSError
NetworkFailure IOException
e
Elapsed (Seconds now :: Int64
now) <- IO Elapsed
timeCurrent
case Int64 -> ByteString -> Either DNSError DNSMessage
decodeAt Int64
now ByteString
bs of
Left e :: DNSError
e -> DNSError -> IO DNSMessage
forall e a. Exception e => e -> IO a
E.throwIO DNSError
e
Right msg :: DNSMessage
msg -> DNSMessage -> IO DNSMessage
forall (m :: * -> *) a. Monad m => a -> m a
return DNSMessage
msg
receiveVC :: Socket -> IO DNSMessage
receiveVC :: Socket -> IO DNSMessage
receiveVC sock :: Socket
sock = do
Int
len <- ByteString -> Int
forall p. Num p => ByteString -> p
toLen (ByteString -> Int) -> IO ByteString -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int -> IO ByteString
recvDNS Socket
sock 2
ByteString
bs <- Socket -> Int -> IO ByteString
recvDNS Socket
sock Int
len
Elapsed (Seconds now :: Int64
now) <- IO Elapsed
timeCurrent
case Int64 -> ByteString -> Either DNSError DNSMessage
decodeAt Int64
now ByteString
bs of
Left e :: DNSError
e -> DNSError -> IO DNSMessage
forall e a. Exception e => e -> IO a
E.throwIO DNSError
e
Right msg :: DNSMessage
msg -> DNSMessage -> IO DNSMessage
forall (m :: * -> *) a. Monad m => a -> m a
return DNSMessage
msg
where
toLen :: ByteString -> p
toLen bs :: ByteString
bs = case ByteString -> [Word8]
B.unpack ByteString
bs of
[hi :: Word8
hi, lo :: Word8
lo] -> 256 p -> p -> p
forall a. Num a => a -> a -> a
* (Word8 -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
hi) p -> p -> p
forall a. Num a => a -> a -> a
+ (Word8 -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
lo)
_ -> 0
recvDNS :: Socket -> Int -> IO ByteString
recvDNS :: Socket -> Int -> IO ByteString
recvDNS sock :: Socket
sock len :: Int
len = IO ByteString
recv1 IO ByteString -> (IOException -> IO ByteString) -> IO ByteString
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \e :: IOException
e -> DNSError -> IO ByteString
forall e a. Exception e => e -> IO a
E.throwIO (DNSError -> IO ByteString) -> DNSError -> IO ByteString
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len then
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs1
else do
ByteString -> IO ByteString
loop ByteString
bs1
loop :: ByteString -> IO ByteString
loop bs0 :: ByteString
bs0 = do
let left :: Int
left = Int
len Int -> Int -> Int
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len then
ByteString -> IO ByteString
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 "connection terminated" Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
recvCore :: Int -> IO ByteString
recvCore len0 :: Int
len0 = do
ByteString
bs <- Socket -> Int -> IO ByteString
recv Socket
sock Int
len0
if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "" then
IOException -> IO ByteString
forall e a. Exception e => e -> IO a
E.throwIO IOException
eofE
else
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
send :: Socket -> ByteString -> IO ()
send :: Socket -> ByteString -> IO ()
send = (IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> (ByteString -> IO Int) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)((ByteString -> IO Int) -> ByteString -> IO ())
-> (Socket -> ByteString -> IO Int)
-> Socket
-> ByteString
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> ByteString -> IO Int
Socket.send
{-# INLINE send #-}
sendVC :: Socket -> ByteString -> IO ()
sendVC :: Socket -> ByteString -> IO ()
sendVC = ((ByteString -> IO ())
-> (ByteString -> ByteString) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
encodeVC)((ByteString -> IO ()) -> ByteString -> IO ())
-> (Socket -> ByteString -> IO ()) -> Socket -> ByteString -> IO ()
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 idt :: Word16
idt q :: Question
q ctls :: QueryControls
ctls = DNSMessage -> ByteString
encode (DNSMessage -> ByteString) -> DNSMessage -> ByteString
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 legacyQuery :: ByteString
legacyQuery =
let len :: ByteString
len = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Int16 -> Builder
BB.int16BE (Int16 -> Builder) -> Int16 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int16) -> Int -> Int16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
legacyQuery
in ByteString
len ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
legacyQuery
{-# INLINE encodeVC #-}
responseA :: Identifier -> Question -> [IPv4] -> DNSMessage
responseA :: Word16 -> Question -> [IPv4] -> DNSMessage
responseA idt :: Word16
idt q :: Question
q ips :: [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 300 (RData -> ResourceRecord)
-> (IPv4 -> RData) -> IPv4 -> ResourceRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv4 -> RData
RD_A (IPv4 -> ResourceRecord) -> [IPv4] -> Answers
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 idt :: Word16
idt q :: Question
q ips :: [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 300 (RData -> ResourceRecord)
-> (IPv6 -> RData) -> IPv6 -> ResourceRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv6 -> RData
RD_AAAA (IPv6 -> ResourceRecord) -> [IPv6] -> Answers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IPv6]
ips