{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Trustworthy #-}
module Network.DNS
(
queryA
, queryAAAA
, queryCNAME
, queryPTR
, querySRV
, queryTXT
, query
, DnsException(..)
, resIsReentrant
, queryRaw
, sendRaw
, mkQueryRaw
, decodeMessage
, encodeMessage
, mkQueryMsg
, Label
, Labels(..)
, IsLabels(..)
, Name(..)
, caseFoldName
, CharStr(..)
, IPv4(..), arpaIPv4
, IPv6(..), arpaIPv6
, TTL(..)
, Class(..)
, classIN
, Type(..)
, TypeSym(..)
, typeFromSym
, typeToSym
, Msg(..)
, MsgHeader(..)
, MsgHeaderFlags(..), QR(..)
, MsgQuestion(..)
, MsgRR(..)
, RData(..)
, rdType
, SRV(..)
)
where
import Control.Exception
import Data.Bits (unsafeShiftR, (.&.))
import Data.Typeable (Typeable)
import Foreign.C
import Foreign.Marshal.Alloc
import Numeric (showInt)
import Prelude
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Compat
import Network.DNS.FFI
import Network.DNS.Message
data DnsException
= DnsEncodeException
| DnsDecodeException
| DnsHostNotFound
| DnsNoData
| DnsNoRecovery
| DnsTryAgain
deriving (Int -> DnsException -> ShowS
[DnsException] -> ShowS
DnsException -> String
(Int -> DnsException -> ShowS)
-> (DnsException -> String)
-> ([DnsException] -> ShowS)
-> Show DnsException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DnsException -> ShowS
showsPrec :: Int -> DnsException -> ShowS
$cshow :: DnsException -> String
show :: DnsException -> String
$cshowList :: [DnsException] -> ShowS
showList :: [DnsException] -> ShowS
Show, Typeable)
instance Exception DnsException
query :: IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query :: forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
cls n
name0 TypeSym
qtype
| Just Name
name <- n -> Maybe Name
forall n. IsLabels n => n -> Maybe Name
toName n
name0 = do
bs <- Class -> Name -> Type -> IO ByteString
queryRaw Class
cls Name
name (TypeSym -> Type
typeFromSym TypeSym
qtype)
msg <- evaluate (decodeMessage bs)
maybe (throwIO DnsDecodeException) pure msg
| Bool
otherwise = DnsException -> IO (Msg n)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DnsException
DnsEncodeException
queryRaw :: Class -> Name -> Type -> IO BS.ByteString
queryRaw :: Class -> Name -> Type -> IO ByteString
queryRaw (Class Word16
cls) (Name ByteString
name) Type
qtype = (Ptr CResState -> IO ByteString) -> IO ByteString
forall a. (Ptr CResState -> IO a) -> IO a
withCResState ((Ptr CResState -> IO ByteString) -> IO ByteString)
-> (Ptr CResState -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CResState
stptr -> do
Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
forall a. Num a => a
max_msg_size ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
resptr -> do
_ <- Ptr CChar -> CInt -> CSize -> IO (Ptr CChar)
forall a. Ptr a -> CInt -> CSize -> IO (Ptr a)
c_memset Ptr CChar
resptr CInt
0 CSize
forall a. Num a => a
max_msg_size
BS.useAsCString name $ \Ptr CChar
dn -> do
Ptr CResState -> IO ByteString -> IO ByteString
forall a. Ptr CResState -> IO a -> IO a
withCResInit Ptr CResState
stptr (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
reslen <- Ptr CResState
-> Ptr CChar -> CInt -> CInt -> Ptr CChar -> CInt -> IO CInt
c_res_query Ptr CResState
stptr Ptr CChar
dn (Word16 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
cls) CInt
qtypeVal Ptr CChar
resptr CInt
forall a. Num a => a
max_msg_size
unless (reslen <= max_msg_size) $
fail "res_query(3) message size overflow"
errno <- getErrno
when (reslen < 0) $ do
unless (errno == eOK) $
throwErrno "res_query"
h_errno <- c_get_h_errno stptr
case h_errno of
CInt
1 -> DnsException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DnsException
DnsHostNotFound
CInt
2 -> DnsException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DnsException
DnsNoData
CInt
3 -> DnsException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DnsException
DnsNoRecovery
CInt
4 -> DnsException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DnsException
DnsTryAgain
CInt
_ -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"res_query(3) failed"
BS.packCStringLen (resptr, fromIntegral reslen)
where
max_msg_size :: Num a => a
max_msg_size :: forall a. Num a => a
max_msg_size = a
0x10000
qtypeVal :: CInt
qtypeVal :: CInt
qtypeVal = case Type
qtype of Type Word16
w -> Word16 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w
sendRaw :: BS.ByteString -> IO BS.ByteString
sendRaw :: ByteString -> IO ByteString
sendRaw ByteString
req = (Ptr CResState -> IO ByteString) -> IO ByteString
forall a. (Ptr CResState -> IO a) -> IO a
withCResState ((Ptr CResState -> IO ByteString) -> IO ByteString)
-> (Ptr CResState -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CResState
stptr -> do
Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
forall a. Num a => a
max_msg_size ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
resptr -> do
_ <- Ptr CChar -> CInt -> CSize -> IO (Ptr CChar)
forall a. Ptr a -> CInt -> CSize -> IO (Ptr a)
c_memset Ptr CChar
resptr CInt
0 CSize
forall a. Num a => a
max_msg_size
BS.useAsCStringLen req $ \(Ptr CChar
reqptr,Int
reqlen) -> do
Ptr CResState -> IO ByteString -> IO ByteString
forall a. Ptr CResState -> IO a -> IO a
withCResInit Ptr CResState
stptr (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
reslen <- Ptr CResState -> Ptr CChar -> CInt -> Ptr CChar -> CInt -> IO CInt
c_res_send Ptr CResState
stptr Ptr CChar
reqptr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
reqlen) Ptr CChar
resptr CInt
forall a. Num a => a
max_msg_size
unless (reslen <= max_msg_size) $
fail "res_send(3) message size overflow"
errno <- getErrno
when (reslen < 0) $ do
unless (errno == eOK) $
throwErrno "res_send"
fail "res_send(3) failed"
BS.packCStringLen (resptr, fromIntegral reslen)
where
max_msg_size :: Num a => a
max_msg_size :: forall a. Num a => a
max_msg_size = a
0x10000
mkQueryMsg :: IsLabels n => Class -> n -> Type -> Msg n
mkQueryMsg :: forall n. IsLabels n => Class -> n -> Type -> Msg n
mkQueryMsg Class
cls n
l Type
qtype = MsgHeader
-> [MsgQuestion n] -> [MsgRR n] -> [MsgRR n] -> [MsgRR n] -> Msg n
forall l.
MsgHeader
-> [MsgQuestion l] -> [MsgRR l] -> [MsgRR l] -> [MsgRR l] -> Msg l
Msg (MsgHeader{Word16
MsgHeaderFlags
mhId :: Word16
mhFlags :: MsgHeaderFlags
mhQDCount :: Word16
mhANCount :: Word16
mhNSCount :: Word16
mhARCount :: Word16
mhARCount :: Word16
mhNSCount :: Word16
mhANCount :: Word16
mhQDCount :: Word16
mhFlags :: MsgHeaderFlags
mhId :: Word16
..})
[n -> Type -> Class -> MsgQuestion n
forall l. l -> Type -> Class -> MsgQuestion l
MsgQuestion n
l Type
qtype Class
cls]
[]
[]
[MsgRR {n
TTL
Class
RData n
forall {l}. RData l
rrName :: n
rrClass :: Class
rrTTL :: TTL
rrData :: forall {l}. RData l
rrData :: RData n
rrTTL :: TTL
rrClass :: Class
rrName :: n
..}]
where
mhId :: Word16
mhId = Word16
31337
mhFlags :: MsgHeaderFlags
mhFlags = MsgHeaderFlags
{ mhQR :: QR
mhQR = QR
IsQuery
, mhOpcode :: Word8
mhOpcode = Word8
0
, mhAA :: Bool
mhAA = Bool
False
, mhTC :: Bool
mhTC = Bool
False
, mhRD :: Bool
mhRD = Bool
True
, mhRA :: Bool
mhRA = Bool
False
, mhZ :: Bool
mhZ = Bool
False
, mhAD :: Bool
mhAD = Bool
True
, mhCD :: Bool
mhCD = Bool
False
, mhRCode :: Word8
mhRCode = Word8
0
}
mhQDCount :: Word16
mhQDCount = Word16
1
mhANCount :: Word16
mhANCount = Word16
0
mhNSCount :: Word16
mhNSCount = Word16
0
mhARCount :: Word16
mhARCount = Word16
1
rrName :: n
rrName = Labels -> n
forall s. IsLabels s => Labels -> s
fromLabels Labels
Root
rrClass :: Class
rrClass = Word16 -> Class
Class Word16
512
rrTTL :: TTL
rrTTL = Int32 -> TTL
TTL Int32
0x8000
rrData :: RData l
rrData = ByteString -> RData l
forall l. ByteString -> RData l
RDataOPT ByteString
""
mkQueryRaw :: Class -> Name -> Type -> IO BS.ByteString
mkQueryRaw :: Class -> Name -> Type -> IO ByteString
mkQueryRaw (Class Word16
cls) (Name ByteString
name) Type
qtype = (Ptr CResState -> IO ByteString) -> IO ByteString
forall a. (Ptr CResState -> IO a) -> IO a
withCResState ((Ptr CResState -> IO ByteString) -> IO ByteString)
-> (Ptr CResState -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CResState
stptr -> do
Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
forall a. Num a => a
max_msg_size ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
resptr -> do
_ <- Ptr CChar -> CInt -> CSize -> IO (Ptr CChar)
forall a. Ptr a -> CInt -> CSize -> IO (Ptr a)
c_memset Ptr CChar
resptr CInt
0 CSize
forall a. Num a => a
max_msg_size
BS.useAsCString name $ \Ptr CChar
dn -> do
Ptr CResState -> IO ByteString -> IO ByteString
forall a. Ptr CResState -> IO a -> IO a
withCResInit Ptr CResState
stptr (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
reslen <- Ptr CResState
-> Ptr CChar -> CInt -> CInt -> Ptr CChar -> CInt -> IO CInt
c_res_mkquery Ptr CResState
stptr Ptr CChar
dn (Word16 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
cls) CInt
qtypeVal Ptr CChar
resptr CInt
forall a. Num a => a
max_msg_size
unless (reslen <= max_msg_size) $
fail "res_mkquery(3) message size overflow"
errno <- getErrno
when (reslen < 0) $ do
unless (errno == eOK) $
throwErrno "res_query"
fail "res_mkquery(3) failed"
BS.packCStringLen (resptr, fromIntegral reslen)
where
max_msg_size :: Num a => a
max_msg_size :: forall a. Num a => a
max_msg_size = a
0x10000
qtypeVal :: CInt
qtypeVal :: CInt
qtypeVal = case Type
qtype of Type Word16
w -> Word16 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w
caseFoldName :: Name -> Name
caseFoldName :: Name -> Name
caseFoldName (Name ByteString
n) = (ByteString -> Name
Name ByteString
n'')
where
n' :: ByteString
n' = (Word8 -> Word8) -> ByteString -> ByteString
BS.map Word8 -> Word8
forall {a}. (Ord a, Num a) => a -> a
cf ByteString
n
n'' :: ByteString
n'' | ByteString -> Bool
BS.null ByteString
n' = ByteString
"."
| HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.last ByteString
n' Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x2e = ByteString
n'
| Bool
otherwise = ByteString
n' ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
`mappend` ByteString
"."
cf :: a -> a
cf a
w | a
0x61 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
w Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0x7a = a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
0x20
| Bool
otherwise = a
w
queryA :: Name -> IO [(TTL,IPv4)]
queryA :: Name -> IO [(TTL, IPv4)]
queryA Name
n = do
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypeA
pure [ (ttl,ip4) | MsgRR { rrData = RDataA ip4, rrTTL = ttl, rrName = n1, rrClass = Class 1 } <- msgAN res, caseFoldName n1 == n' ]
where
n' :: Name
n' = Name -> Name
caseFoldName Name
n
queryAAAA :: Name -> IO [(TTL,IPv6)]
queryAAAA :: Name -> IO [(TTL, IPv6)]
queryAAAA Name
n = do
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypeAAAA
pure [ (ttl,ip6) | MsgRR { rrData = RDataAAAA ip6, rrTTL = ttl, rrName = n1, rrClass = Class 1 } <- msgAN res, caseFoldName n1 == n' ]
where
n' :: Name
n' = Name -> Name
caseFoldName Name
n
queryCNAME :: Name -> IO [(TTL,Name)]
queryCNAME :: Name -> IO [(TTL, Name)]
queryCNAME Name
n = do
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypeAAAA
pure [ (ttl,cname) | MsgRR { rrData = RDataCNAME cname, rrTTL = ttl, rrName = n1, rrClass = Class 1 } <- msgAN res, caseFoldName n1 == n' ]
where
n' :: Name
n' = Name -> Name
caseFoldName Name
n
queryPTR :: Name -> IO [(TTL,Name)]
queryPTR :: Name -> IO [(TTL, Name)]
queryPTR Name
n = do
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypePTR
pure [ (ttl,ptrs) | MsgRR { rrData = RDataPTR ptrs, rrTTL = ttl, rrName = n1, rrClass = Class 1 } <- msgAN res, caseFoldName n1 == n' ]
where
n' :: Name
n' = Name -> Name
caseFoldName Name
n
queryTXT :: Name -> IO [(TTL,[CharStr])]
queryTXT :: Name -> IO [(TTL, [CharStr])]
queryTXT Name
n = do
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypeTXT
pure [ (ttl,txts) | MsgRR { rrData = RDataTXT txts, rrTTL = ttl, rrName = n1, rrClass = Class 1 } <- msgAN res, caseFoldName n1 == n' ]
where
n' :: Name
n' = Name -> Name
caseFoldName Name
n
querySRV :: Name -> IO [(TTL,SRV Name)]
querySRV :: Name -> IO [(TTL, SRV Name)]
querySRV Name
n = do
res <- Class -> Name -> TypeSym -> IO (Msg Name)
forall n. IsLabels n => Class -> n -> TypeSym -> IO (Msg n)
query Class
classIN Name
n' TypeSym
TypeSRV
pure [ (ttl,srv) | MsgRR { rrData = RDataSRV srv, rrTTL = ttl, rrName = n1, rrClass = Class 1 } <- msgAN res, caseFoldName n1 == n' ]
where
n' :: Name
n' = Name -> Name
caseFoldName Name
n
arpaIPv4 :: IPv4 -> Name
arpaIPv4 :: IPv4 -> Name
arpaIPv4 (IPv4 Word32
w) = ByteString -> Name
Name (String -> ByteString
BSC.pack String
s)
where
s :: String
s = Word8 -> ShowS
forall a. Integral a => a -> ShowS
showInt Word8
o0 (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> ShowS
forall a. Integral a => a -> ShowS
showInt Word8
o1 (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> ShowS
forall a. Integral a => a -> ShowS
showInt Word8
o2 (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> ShowS
forall a. Integral a => a -> ShowS
showInt Word8
o3 String
".in-addr.arpa.")))
o0, o1, o2, o3 :: Word8
o0 :: Word8
o0 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w
o1 :: Word8
o1 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
8
o2 :: Word8
o2 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
16
o3 :: Word8
o3 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
24
arpaIPv6 :: IPv6 -> Name
arpaIPv6 :: IPv6 -> Name
arpaIPv6 (IPv6 Word64
hi Word64
lo) = ByteString -> Name
Name (String -> ByteString
BSC.pack String
s)
where
s :: String
s = Int -> Word64 -> ShowS
go Int
16 Word64
lo (Int -> Word64 -> ShowS
go Int
16 Word64
hi String
"ip6.arpa.")
go :: Int -> Word64 -> ShowS
go :: Int -> Word64 -> ShowS
go Int
0 Word64
_ String
cont = String
cont
go Int
n Word64
w String
cont = Char
nib Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> Word64 -> ShowS
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Word64
w' String
cont
where
nib :: Char
nib :: Char
nib | Word64
x Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
10 = Int -> Char
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
0x30 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
x))
| Bool
otherwise = Int -> Char
forall a. Enum a => Int -> a
toEnum (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
0x57 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
x))
x :: Word64
x = Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xf
w' :: Word64
w' = Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4