dns 1.0.0 → 1.1.0

raw patch · 3 files changed

+69/−25 lines, 3 files

Files

• Network/DNS/Internal.hs +7/−1
• Network/DNS/Resolver.hs +61/−23
• dns.cabal +1/−1

@@ -1,10 +1,14 @@+{-# LANGUAGE DeriveDataTypeable #-}+ module Network.DNS.Internal where +import Control.Exception (Exception) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Char import Data.IP import Data.Maybe+import Data.Typeable (Typeable)  ---------------------------------------------------------------- @@ -57,7 +61,9 @@   -- | The answer has the correct sequence number, but returned an   --   unexpected RDATA format.   | UnexpectedRDATA-  deriving (Eq, Show)+  deriving (Eq, Show, Typeable)++instance Exception DNSError  -- | Raw data format for DNS Query and Response. data DNSFormat = DNSFormat {

@@ -8,7 +8,7 @@   -- ** Intermediate data type for resolver   , ResolvSeed, makeResolvSeed   -- ** Type and function for resolver-  , Resolver(..), withResolver+  , Resolver(..), withResolver, withResolvers   -- ** Looking up functions   , lookup, lookupAuth, lookupRaw   ) where@@ -33,6 +33,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Control.Monad (when) #endif+ ----------------------------------------------------------------  @@ -53,6 +54,7 @@ data ResolvConf = ResolvConf {     resolvInfo :: FileOrNumericHost   , resolvTimeout :: Int+  , resolvRetry :: Int   -- | This field was obsoleted.   , resolvBufsize :: Integer }@@ -64,6 +66,8 @@ -- --     * 'resolvTimeout' is 3,000,000 micro seconds. --+--     * 'resolvRetry' is 5.+-- --     * 'resolvBufsize' is 512. (obsoleted) -- --  Example (use Google's public DNS cache instead of resolv.conf):@@ -75,6 +79,7 @@ defaultResolvConf = ResolvConf {     resolvInfo = RCFilePath "/etc/resolv.conf"   , resolvTimeout = 3 * 1000 * 1000+  , resolvRetry = 5   , resolvBufsize = 512 } @@ -84,6 +89,7 @@ data ResolvSeed = ResolvSeed {     addrInfo :: AddrInfo   , rsTimeout :: Int+  , rsRetry :: Int   , rsBufsize :: Integer } @@ -92,6 +98,7 @@     genId   :: IO Int   , dnsSock :: Socket   , dnsTimeout :: Int+  , dnsRetry :: Int   , dnsBufsize :: Integer } @@ -107,6 +114,7 @@ makeResolvSeed :: ResolvConf -> IO ResolvSeed makeResolvSeed conf = ResolvSeed <$> addr                                  <*> pure (resolvTimeout conf)+                                 <*> pure (resolvRetry conf)                                  <*> pure (resolvBufsize conf)   where     addr = case resolvInfo conf of@@ -134,18 +142,38 @@ --   argument. 'withResolver' should be passed to 'forkIO'. For --   examples, see "Network.DNS.Lookup". withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a-withResolver seed func = do-  let ai = addrInfo seed-  sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)-  connect sock (addrAddress ai)-  let resolv = Resolver {-          genId = getRandom-        , dnsSock = sock-        , dnsTimeout = rsTimeout seed-        , dnsBufsize = rsBufsize seed-        }-  func resolv `finally` sClose sock+withResolver seed func = bracket (openSocket seed) sClose $ \sock -> do+    connectSocket sock seed+    func $ makeResolver seed sock +withResolvers :: [ResolvSeed] -> ([Resolver] -> IO a) -> IO a+withResolvers seeds func = bracket openSockets closeSockets $ \socks -> do+    mapM_ (uncurry connectSocket) $ zip socks seeds+    let resolvs = map (uncurry makeResolver) $ zip seeds socks+    func resolvs+  where+    openSockets = mapM openSocket seeds+    closeSockets = mapM sClose++openSocket :: ResolvSeed -> IO Socket+openSocket seed = socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)+  where+    ai = addrInfo seed++connectSocket :: Socket -> ResolvSeed -> IO ()+connectSocket sock seed = connect sock (addrAddress ai)+  where+    ai = addrInfo seed++makeResolver :: ResolvSeed -> Socket -> Resolver+makeResolver seed sock = Resolver {+    genId = getRandom+  , dnsSock = sock+  , dnsTimeout = rsTimeout seed+  , dnsRetry = rsRetry seed+  , dnsBufsize = rsBufsize seed+  }+ getRandom :: IO Int getRandom = getStdRandom (randomR (0,65535)) @@ -233,21 +261,31 @@ lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSFormat) lookupRaw rlv dom typ = do     seqno <- genId rlv-    sendAll sock (composeQuery seqno [q])-    response <- timeout tm (receive sock)-    return $ case response of-               Nothing -> Left TimeoutExpired-               Just y  -> check seqno y+    let query = composeQuery seqno [q]+        checkSeqno = check seqno+    loop query checkSeqno 0 False   where+    loop query checkSeqno cnt mismatch+      | cnt == retry = do+          let ret | mismatch  = SequenceNumberMismatch+                  | otherwise = TimeoutExpired+          return $ Left ret+      | otherwise    = do+          sendAll sock query+          response <- timeout tm (receive sock)+          case response of+              Nothing  -> loop query checkSeqno (cnt + 1) False+              Just res -> do+                  let valid = checkSeqno res+                  if valid then+                      return $ Right res+                    else+                      loop query checkSeqno (cnt + 1) False     sock = dnsSock rlv     tm = dnsTimeout rlv+    retry = dnsRetry rlv     q = makeQuestion dom typ-    check seqno res = do-        let hdr = header res-        if identifier hdr == seqno then-            Right res-          else-            Left SequenceNumberMismatch+    check seqno res = identifier (header res) == seqno  #if mingw32_HOST_OS == 1     -- Windows does not support sendAll in Network.ByteString.Lazy.

@@ -1,5 +1,5 @@ Name:                   dns-Version:                1.0.0+Version:                1.1.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3